subroutine fingrd
c     =================
c
c     storing the complete, interpolated, opacity table 
c
      INCLUDE 'PARAMS.FOR'
      INCLUDE 'MODELP.FOR'
      INCLUDE 'SYNTHP.FOR'
      real*4 absgrd(mttab,mrtab,mfgrid)
      common/gridp0/tempg(mttab),densg(mttab,mrtab),elecgr(mttab,mrtab),
     *              densg0(mttab),temp1,ntemp,ndens,nden(mttab)
      common/gridf0/wlgrid(mfgrid),nfgrid
      common/fintab/absgrd
      common/relabu/relabn(matom),popul0(mlevel,1)
      character*(80) tabname
      common/tabout/tabname,ibingr,idens
c
      if(ifeos.gt.0) return
c
      close(53)
      iophmp=iophmi
      if(ielhm.gt.0.and.relabn(1).gt.0.) iophmp=1 
      if(ibingr.eq.0) then
         open(53,file=tabname,status='unknown')
         write(53,600) 
         do iat=1,92
            write(53,601) typat(iat),abnd(iat),abnd(iat)*relabn(iat)
         end do
         write(53,602) ifmol,tmolim
         write(53,603) iophmp,ioph2p,iophem,iopch,iopoh,ioph2m,
     *                 ioh2h2,ioh2he,ioh2h1,iohhe
         if(idens.lt.10) then
            ndens=nden(1)
            write(53,611) nfgrid,ntemp,nden(1)
            write(53,612) (log(tempg(i)),i=1,ntemp)
            write(53,613) (log(densg(1,j)),j=1,nden(1))
            write(53,614) ((log(elecgr(i,j)),j=1,nden(1)),i=1,ntemp)
            do k = 1, nfgrid
               write(53,615) k,wlgrid(k),2.997925e18/wlgrid(k)
               do j = 1,ndens
                  write(53,616) (absgrd(i,j,k),i=1,ntemp)
               end do
            end do
          else
            write(53,611) nfgrid,ntemp,-nden(1)
            write(53,610) (nden(i),i=1,ntemp)
            write(53,612) (log(tempg(i)),i=1,ntemp)
            write(53,622)
            do i=1,ntemp
               ndens=nden(i)
               write(53,623) (log(densg(i,j)),j=1,ndens)
            end do
            write(53,624)
            do i=1,ntemp
               ndens=nden(i)
               write(53,623) (log(elecgr(i,j)),j=1,ndens)
            end do
            do k = 1,nfgrid
               write(53,615) k,wlgrid(k),2.997925e18/wlgrid(k)
               do i=1,ntemp
                  ndens=nden(i)
                  write(53,616) (absgrd(i,j,k),j=1,ndens)
               end do
            end do
         end if
  600    format('opacity table with element abundances:'/
     *          'element   for EOS   for opacities')
  601    format('  ',a4,1p2e12.3)
  602    format(/'molecules - ifmol,tmolim:'/,i4,f10.1)
  603    format('additional opacities'/
     *   '  H-  H2+ He- CH  OH  H2- CIA: H2H2 H2He H2H  HHe'/
     *          6i4,4x,4i4)
  610    format(30i3)
  611    format(/'number of frequencies, temperatures, densities:'
     *          /10x,3i10)
  612    format('log temperatures'/(6F11.6))
  613    format('log densities'/(6F11.6))
  614    format('log electron densities from EOS'/(6f11.6))
  615    format(/' *** frequency # : ',i8,f15.5/1pe20.8)
  616    format((1p6e14.6))
c 621    format('log temperatures')
  622    format('log densities')
  623    format(6f14.6)
  624    format('log electron densities from EOS')
       end if
         do iat=1,92
            write(63) typat(iat),abnd(iat),abnd(iat)*relabn(iat)
         end do
         write(63) ifmol,tmolim
         write(63) iophmp,ioph2p,iophem,iopch,iopoh,ioph2m,
     *             ioh2h2,ioh2he,ioh2h1,iohhe

         if(idens.lt.10) then
            ndens=nden(1)
            write(63) nfgrid,ntemp,nden(1)
            write(63) (log(tempg(i)),i=1,ntemp)
            write(63) (log(densg(1,j)),j=1,nden(1))
            write(63) ((log(elecgr(i,j)),j=1,nden(1)),i=1,ntemp)
            do k = 1, nfgrid
               write(63) 2.997925e18/wlgrid(k)
               do j = 1,ndens
                  write(63) (absgrd(i,j,k),i=1,ntemp)
               end do
            end do
          else
            write(63) nfgrid,ntemp,-nden(1)
            write(63) (nden(i),i=1,ntemp)
            write(63) (log(tempg(i)),i=1,ntemp)
            do i=1,ntemp
               ndens=nden(i)
               write(63) (log(densg(i,j)),j=1,ndens)
            end do
            do i=1,ntemp
               ndens=nden(i)
               write(63) (log(elecgr(i,j)),j=1,ndens)
            end do
            do k = 1,nfgrid
               write(63) 2.997925e18/wlgrid(k)
               do i=1,ntemp
                  ndens=nden(i)
                  write(63) (absgrd(i,j,k),j=1,ndens)
                if(k.le.100) write(*,*) 'abs(1)',i,ndens,
     *                     (absgrd(i,j,k),j=1,ndens)
               end do
            end do
         end if
c     end if
c
      close(63)
      return
      end