c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine driver

c Computes a full trajectory from start to finish.

      implicit none
      include 'param.f'
      include 'c_sys.f'
      include 'c_traj.f'
      include 'c_ran.f'
      include 'c_output.f'

c     temporary use information
      common/tmp/tmpprint
      double precision tmpprint(50)
      double precision taup(3),taup2(3)
      common/tauprint/taup,taup2
      double precision h12x,h12y
      common/pesh12/h12x,h12y

c     number of bins for binning the radial distribution function
      integer nbinrad,im
      parameter(nbinrad=60)

      integer i,j,k,ii,iturn,i1,i2,ithistraj,frusflag(mnsurf),
     &  newsurf,iramp,ncross,nbz2
      double precision rminmax,ravg,ce,hrad,dot,peim,tbz2,tbz0,tbzf
      double precision rr(3),rhor(mnsurf,mnsurf),eig(3),dum3(3),
     &  rhoi(mnsurf,mnsurf),step,timeprev,phop(mnsurf),tmp1,tmp2,tmp3,
     &  dmag,dmag1,dmag2,gvmag,rrr,rmax(mnoutcome),rmin(mnoutcome),
     &  dvec(3,mnat,mnsurf,mnsurf),gpem(3,mnat,mnsurf),
     &  arij(mnat,mnat),arij2(mnat,mnat),lind,ppp(3),ppy,ppm,
     &  raddist(0:nbinrad+1),egap,rtmp,rcom,tmp4,ecom,ecom2,
     &  lastgap0,lastgap,plz,plz0,elz,plzx,elz0,elzx,lastcross,
     &  hlz,hlz0,hlzx,glz,glzx,glz0,r1,r10,r1x,r2,r20,r2x,
     7  a123,a1230,a123x,r3,vlz,vlz0,vlzx,pairy(2),pairy0(2),pairyx(2)
      logical lhop

c used for FSTU
      double precision tu_xx(3,mnat,mnsurf),tu_pp(3,mnat,mnsurf),
     & tu_cre(mnsurf,mnsurf),tu_cim(mnsurf,mnsurf),tu_hstep(mnsurf),
     & tu_time(mnsurf),tu_phase(mnsurf,mnsurf),tu_maxt(mnsurf),
     & deltforw,deltback,tu_maxtime
      integer tu_istep(mnsurf)
      logical lfrust

c Andersen thermostat
      logical lhit

c stochastic decoherence
      integer nhop
      double precision stodecotime,stodecotau,electau

      integer wellindex1,wellindex2,n1,n2,ijk
      double precision xwell,rvdw,evdw
      logical lzflag
      lzflag=.false.
      if (tflag(4).lt.0) lzflag=.true.
c      rvdw=0.d0
      evdw=1000.d0

c initialize for this trajectory
      lastgap0 =0.d0 ! TEMP AJ
      lastgap =0.d0 ! TEMP AJ
      lastcross =0.d0 ! TEMP AJ
      ncross =0 ! TEMP AJ
      nhop = 0
      time = 0.d0
      stodecotime = -1.d0
      stodecotau = 4.d0/autofs
      dmag1 = 0.d0
      dmag2 = 0.d0
      do i=1,nsurft
        phase(i) = 0.d0
        tu_time(i) = -1.d0
      enddo
      lfrust = .false.
      do i=1,mnat
      do j=1,mnat
        arij(i,j) = 0.d0
        arij2(i,j) = 0.d0
      enddo
      enddo
      atemp = 0.d0
      atemp2 = 0.d0
      stemp = 0.d0
      iramp = 0
      do i=0,nbinrad+1
        raddist(i) = 0.d0
      enddo
      outcome = -1   ! OUTCOME should get reassigned when the traj finishes. A final value of -1 indicates a failure of some kind.
      istep = 0
      istepw = 0
      step = 0.d0

      if (lchkdis.eq..true.) then
        iturn = 0
      else
        iturn =1
      endif

c calculate and save initial values of things for later analysis
c     initial coordinates and momenta
      do i=1,nat
      do j=1,3
         xxi(j,i)=xx(j,i)
         ppi(j,i)=pp(j,i)
      enddo
      enddo
      call gettemp(pp,mm,nat,tempi,kei)
      call getgrad(xx,pp,nsurf,pei,cre,cim,gv,gcre,gcim,nat,
     & phop,dmag,dvec,pem,gpem,phase)
      lastgap0 = lastgap  ! TEMP AJ
      lastgap = pem(1)-pem(2)  ! TEMP AJ
      call getplz(pp,mm,gpem,nat,plz,elz,hlz,glz,pairy,nsurf)  ! TEMP AJ

      tei=kei+pei
      call ange(xx,pp,mm,nat,eig,bigji,bigjtoti,eroti,erottoti)
      write(6,106)"Initial overall ang momentum = ",bigjtoti," au"
      write(6,106)"Initial overall rot energy   = ",erottoti*autoev,
     & " eV"
      write(6,106)"Initial kinetic energy       = ",kei*autoev," eV"
      write(6,106)"Initial potential energy     = ",pei*autoev," eV"
      write(6,106)"Initial total energy         = ",tei*autoev," eV"
      write(6,106)"Initial temp                 = ",tempi," K"
 106  format(1x,a,f15.5,1x,a)
 107  format(1x,a,3f12.5,1x,a)
      write(6,*)

      if(nsurft.gt.1) then
      do i=1,nsurft
      write(6,*)"Potential for surf ",i," = ",pem(i)*autoev," eV"
      enddo
      endif
      write(6,*)

c photoexcite
      if (tflag(3).eq.1) then
        egap = dabs(pem(ntarget)-pem(nsurf))
        if (dabs(egap-ephoton).lt.wphoton) then
c         successful excitation
          write(6,*)"Exciting from state ",nsurf," to state ",ntarget,
     &               " with a photon energy of ",egap*autoev
          nsurf=ntarget
          pei = pem(nsurf)
          tei = kei + pei
          call initelec
        else
          write(6,*)"Unsuccessful excitation"
          write(6,*)"Egap = ",egap*autoev," eV"
          write(6,*)"Photon energy = ",ephoton*autoev," +/- ",
     &             wphoton*autoev," eV"
          outcome = -2
          go to 999
        endif
      endif

c get trajectory index
      if (tflag(2).eq.1) then
        ithistraj = trajlist(itraj)
      else
        ithistraj = itraj
      endif

c write initial coordinates and momenta to output
      if (lwrite(10)) then
      write(10,*)ithistraj
      write(10,*)1,pei*autoev
      do i=1,nat
c      write(10,1010)symbol(i),mm(i)/amutoau,(xx(j,i)*autoang,j=1,3)
      write(10,1010)symbol(i),(xx(j,i)*autoang,j=1,3)
      enddo
      endif
      if (lwrite(11)) then
      write(11,*)ithistraj
      write(11,*)1,kei*autoev
      do i=1,nat
c      write(11,1010)symbol(i),mm(i)/amutoau,(pp(j,i),j=1,3)
      write(11,1010)symbol(i),(pp(j,i),j=1,3)
      enddo
      endif

 1010 format(5x,a2,4f20.8)

c trajectory output
      if (termflag.eq.2) then
      write(6,'(20a15)')"          step",
     &                  "      time(fs)",
     &                  "        PE(eV)",
     &                  " |gradV|(eV/A)"
      else
      if (nsurft.eq.1.and.lwell.le.0) then
      write(6,'(20a15)')"           step",
     &                  "       time(fs)",
     &                  "           T(K)",
     &                  "         KE(eV)",
     &                  "         PE(eV)",
     &                  "         TE(eV)",
     &                  "      Lindemann",
     &                  "         <T(K)>",
     &                  "   st.dev(T(K))"
      else if (nsurft.eq.1.and.lwell.gt.0) then
      write(6,'(20a15)')"           step",
     &                  "          stepw",
     &                  "       time(fs)",
     &                  "           T(K)",
     &                  "         KE(eV)",
     &                  "         PE(eV)",
     &                  "         TE(eV)",
     &                  "      Lindemann",
     &                  "         <T(K)>",
     &                  "   st.dev(T(K))"
      else
      write(6,'(20a15)')"           step",
     &                  "       time(fs)",
     &                  "           T(K)",
     &                  "         KE(eV)",
     &                  "         PE(eV)",
     &                  "         TE(eV)",
     &                  "          Probs"
      endif
      endif

c ######################################################################
c INTEGRATE TRAJECTORY
c ######################################################################
!      call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,  ! HACK
!     &   phop,dmag,dvec,pem,gpem,phase)
      do 10 while (.true.)
      istep = istep + 1

c      call state

c check for trajectory termination here
c when termination occurs we skip out of the infinite
c "do 10 while" loop with "go to 999"

c     quit if we exceed max number of steps
      if (lwell.le.0.and.istep.gt.t_nstep.and.t_nstep.ne.-1) then
        outcome = 0
        go to 999
      else if (lwell.gt.0.and.istepw.ge.t_nstep.and.t_nstep.ne.-1) then
        outcome = 0
        go to 999
      endif

c     quit if we've integrated long enough (TERMFLAG = 1)
      if (termflag.eq.1.and.time.gt.t_stime) then
        outcome = 0
        go to 999
      endif

c     converge gradient (TERMFLAG = 2)
      if (termflag.eq.2) then
        gvmag = 0.d0
        do i=1,nat
        do j=1,3
        gvmag = gvmag + gv(j,i)**2
        enddo
        enddo
        if (gvmag.le.t_gradmag**2) then
          write(6,*)"Gradient converged to ",
     &               dsqrt(gvmag)*autoev/autoang,"eV/A"
          write(6,*)"At the geometry "
          do i=1,nat
            write(*,1090)symbol(i),mm(i)/amutoau,(xx(j,i)*autoang,j=1,3)
 1090       format(a2,f15.6,3f21.8)
          enddo
          tmp1=-1.d0
          tmp2=-1.d0
          call addrot(pp,xx,mm,nat,tmp1,tmp2,sampjbrot1,sampjbrot2,
     &       tmp3,tmp4,dum3)

          if (lwrite(77)) then  ! special output file
            open(77,file="dint.geo")
            write(77,*)pem(1)*autoev,
     &" ! Optimized energy (eV), rot constants (cm-1), and geometry (A)"
            write(77,*)dum3
            do i=1,nat
           write(77,1090)symbol(i),mm(i)/amutoau,(xx(j,i)*autoang,j=1,3)
            enddo
          endif

          go to 999
        endif
      endif

c     monitor bond dissociation (TERMFLAG = 3)
      if (termflag.eq.3) then
c       find maximum and minimum bond distance corresponding to each outcome
        do k=1,t_noutcome
          rmax(k) = 0.d0
          rmin(k) = 1000.d0
        enddo

        do k=1,t_noutcome
          if ( ( t_symb(k,1).eq.'cm'.and.
     &      t_symb(k,2).eq.'cm'      ) ) then
            call getrel(rcom,ecom)
            rmin(k)=rcom
            rmax(k)=rcom
          endif
          do i1=1,nat
            do i2=i1+1,nat
              if ( ( t_symb(k,1).eq.symbol(i1).and.
     &               t_symb(k,2).eq.symbol(i2)      ) .or.
     &             ( t_symb(k,1).eq.symbol(i2).and.
     &               t_symb(k,2).eq.symbol(i1)      ) ) then
                rrr = 0.d0
                do j=1,3
                  rrr = rrr + (xx(j,i1)-xx(j,i2))**2
                enddo
                rrr = dsqrt(rrr)
                if (rmax(k).lt.rrr) then
                  rmax(k) = rrr
                  if (t_r(k).gt.0.d0) then
                    aind(k,1) = i1
                    aind(k,2) = i2
                  endif
                endif
                if (rmin(k).gt.rrr) then
                  rmin(k) = rrr
                  if (t_r(k).lt.0.d0) then
                    aind(k,1) = i1
                    aind(k,2) = i2
                  endif
                endif
              endif
            enddo
          enddo
        enddo

c       ITURN starts each trajectory at 0
c       ITURN is set to 1 when all the distances are less than 95% of the
c             dissociation termination distances
c       This prevents the trajectories from "dissociating" before the collision
        if (iturn.eq.0) then
          iturn = 1
c         write(6,*)rmax(1)*autoang,t_r(1)*autoang,tmpprint(2)*autoang
          do k=1,t_noutcome
            if (rmax(k).gt.0.95d0*t_r(k).and.t_r(k).gt.0.d0) iturn = 0
          enddo
        endif
c       monitor dissociation
        if (iturn.eq.1) then
          do k=1,t_noutcome
            rtmp=rmax(k)
            if (t_symb(k,2).eq.'x') rtmp=rmin(k)
            if (rtmp.gt.t_r(k).and.t_r(k).gt.0.d0) then
            if (lfrust) then
            else
              outcome = k
              go to 999
            endif
            endif
          enddo
        endif
c       monitor association
        do k=1,t_noutcome
          if (rmin(k).lt.dabs(t_r(k)).and.t_r(k).lt.0.d0) then
            outcome = k
            go to 999
          endif
        enddo
      endif

c Andersen thermostat
      lhit=.false.
      if (tflag(1).eq.3) call andersen(pp,mm,nat,step,lhit)
      if (lhit.and.scandth.gt.0.d0) then
        call gettemp(pp,mm,nat,temp,ke)
        do i=1,nat
        do j=1,3
          pp(j,i)=pp(j,i)*dsqrt((scandth+pei-pe)/ke)
        enddo
        enddo
        call gettemp(pp,mm,nat,temp,ke)
      endif

c     update information if we changed momentum
      if (lhit) call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     & phop,dmag,dvec,pem,gpem,phase)

c take step
      timeprev = time
      call takestep
      step = time - timeprev
c      if (step*autofs.lt.1.d-2) then
c         outcome=0
c         go to 999
c      endif
      if (lwrite(85)) write(85,*)
      if (lwrite(85)) write(85,*)ithistraj,istep,time*autofs

c transport
c      rtmp=xx(1,1)**2+xx(2,1)**2+xx(3,1)**2
c      rtmp=rtmp/6.d0
c      rtrans=(rtrans*(time-step)+rtmp*step)/time
c      if (mod(istep,1000).eq.0) write(6,*)"D = ",rtrans/time

c ramp temperature
      if (tflag(1).eq.2) then
c hard-coded parameters
c      ramptime = 2.d4 ! in fs
c      nramp = 10 ! number of ramping cycles
c      rampfact = 1.02 ! increase temp by this factor each ramp
      if (time > ramptime) then
      call lindemann(xx,nat,step,time,arij,arij2,lind)
      call radialdist(ithistraj,xx,nat,step,time,nbinrad,raddist,1)
      if (lwrite(42)) call honey(ithistraj,xx,nat,time)
      iramp = iramp + 1
      if (lwrite(40)) write(40,*)ithistraj,iramp,atemp/time,stemp,lind
 1040 format(2i7,3f15.5)
      if (iramp.eq.nramp) go to 999
      do i=1,mnat
      do j=1,mnat
        arij(i,j) = 0.d0
        arij2(i,j) = 0.d0
      enddo
      enddo
      do i=0,nbinrad+1
        raddist(i) = 0.d0
      enddo
      atemp = 0.d0
      atemp2 = 0.d0
      stemp = 0.d0
      time = step
      do i=1,nat
      do j=1,3
        pp(j,i)=pp(j,i)*rampfact
      enddo
      enddo
      endif
      endif

c stochastic decoherence
      if (stodecoflag) then
      call stodeco(ithistraj,istep,cre,cim,pem,nsurf,time,
     &   stodecotime,stodecotau,step)
      endif

c update info at new geometry
      call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     &   phop,dmag,dvec,pem,gpem,phase)
      if (lzflag) then
      r10=r1
      r20=r2
      a1230=a123
      r1=0.d0
      r2=0.d0
      r3=0.d0
      do i=1,3
      r1=r1+(xx(i,1)-xx(i,2))**2
      r2=r2+(xx(i,3)-xx(i,2))**2
      r3=r3+(xx(i,3)-xx(i,1))**2
      enddo
      a123=(r1+r2-r3)/dsqrt(4.d0*r1*r2)
      r1=dsqrt(r1)*autoang
      r2=dsqrt(r2)*autoang
      a123=dacos(a123)/dacos(-1.d0)*180.d0
      lastgap0 = lastgap  ! TEMP AJ
      lastgap = pem(1)-pem(2)  ! TEMP AJ
      vlz0=vlz
      vlz=(pem(1)+pem(2))/2.d0
      pairy0(1)=pairy(1)
      pairy0(2)=pairy(2)
      plz0=plz
      elz0=elz
      hlz0=hlz
      vlz0=vlz
      glz0=glz
      call getplz(pp,mm,gpem,nat,plz,elz,hlz,glz,pairy,nsurf)  ! TEMP AJ
      if (lastgap0*lastgap.lt.0.d0) then
      ncross=ncross+1
      if (ncross.eq.abs(tflag(4))) go to 999
c     crude interpolation
      r1x=(dabs(lastgap0)*r1+dabs(lastgap)*r10)
     &         /(dabs(lastgap)+dabs(lastgap0))
      r2x=(dabs(lastgap0)*r2+dabs(lastgap)*r20)
     &         /(dabs(lastgap)+dabs(lastgap0))
      a123x=(dabs(lastgap0)*a123+dabs(lastgap)*a1230)
     &         /(dabs(lastgap)+dabs(lastgap0))
      plzx=(dabs(lastgap0)*plz+dabs(lastgap)*plz0)
     &         /(dabs(lastgap)+dabs(lastgap0))
      pairyx(1)=(dabs(lastgap0)*pairy(1)+dabs(lastgap)*pairy0(1))
     &         /(dabs(lastgap)+dabs(lastgap0))
      pairyx(2)=(dabs(lastgap0)*pairy(2)+dabs(lastgap)*pairy0(2))
     &         /(dabs(lastgap)+dabs(lastgap0))
      elzx=(dabs(lastgap0)*elz+dabs(lastgap)*elz0)
     &         /(dabs(lastgap)+dabs(lastgap0))
      hlzx=(dabs(lastgap0)*hlz+dabs(lastgap)*hlz0)
     &         /(dabs(lastgap)+dabs(lastgap0))
      vlzx=(dabs(lastgap0)*vlz+dabs(lastgap)*vlz0)
     &         /(dabs(lastgap)+dabs(lastgap0))
      glzx=(dabs(lastgap0)*glz+dabs(lastgap)*glz0)
     &         /(dabs(lastgap)+dabs(lastgap0))
        n1 = 2  ! current state
        n2 = 1  ! target state
        call elecdeco(ithistraj,istep,time,nat,n1,n2,
     &   pem,gpem,dvec,xx,pp,stodecotau)   ! returns STODECOTAU, which is the
        call getrho(cre,cim,rhor,rhoi,nsurft)
      if (lwrite(16))
     &  write(16,'(2f13.5,2e18.5,3e18.5,i5,100e20.5)')
     &  time*autofs,dmag,phop(1)*step,rhor(1,1),
c     &  (taup(i)*autofs,i=1,3),
     &  (taup2(i)*autofs,i=1,3),
     &  ncross,
     &  (time-lastcross)*autofs,
     &  plzx,elzx*autoev,hlzx*autocmi,glzx,
     &  vlzx*autoev,pairyx(1),pairyx(2)
c     &  r1x,r2x,a123x,vlzx*autoev,pairyx(1),pairyx(2)
!      write(6,*)"CROSS",plzx,pairyx,pairy,pairy0
      lastcross=time
c      ijk=1
      else
        n1 = 2  ! current state
        n2 = 1  ! target state
        call elecdeco(ithistraj,istep,time,nat,n1,n2,
     &   pem,gpem,dvec,xx,pp,stodecotau)   ! returns STODECOTAU, which is the
      if (lwrite(16))
     & write(16,'(2f13.5,2e18.5,3e18.5)')time*autofs,dmag,
     & phop(1)*step,rhor(1,1),
     & (taup2(i)*autofs,i=1,3)
      endif
      endif

      call getrel(rcom,ecom)

c HACK
      do j=1,3
      ppp(j)=0.d0
      do i=1,natom(1)
      ppp(j)=ppp(j)+pp(j,i)  ! com
      enddo
      enddo
      ppy=0.d0
      do i=1,natom(1)
      ppy=ppy+mm(i)
      enddo
      ke=0.d0
      do i=1,natom(1)
      do j=1,3
         ke = ke + 0.5d0*(pp(j,i)-ppp(j)*mm(i)/ppy)**2/mm(i)
      enddo
      enddo
c HACK
      if ( (mod(istep,nprint).eq.0.or.istep.eq.1) .and. lwrite(90) )
     &  write(90,'(i5,19f15.5)')ithistraj,time*autofs,
     &  tmpprint(2)*autoang,
     &  tmpprint(1)*autocmi,
     &  ecom*autocmi,(tmpprint(1)+ecom)*autocmi,
     &  tmpprint(11)*autocmi,
     &  ke*autocmi,(tmpprint(11)+ke)*autocmi
c     &  ecom2*autocmi,(tmpprint(11)+ecom2)*autocmi
      if (tmpprint(1).lt.evdw) then
         evdw=tmpprint(1)
         rvdw=tmpprint(2)
      endif

c Stop at the first DMAG minimum
      if (termflag.eq.4) then
      if( (dmag1-dmag2).lt.0.d0 .AND. (dmag-dmag1).gt.0.d0 ) go to 999
      dmag2 = dmag1
      dmag1 = dmag
      endif

c reinitialize CSDM
      if (methflag.eq.4) then
      if (istep.gt.2) then
        if( (dmag1-dmag2).lt.0.d0 .AND. (dmag-dmag1).gt.0.d0 ) then
          write(6,*)"Electronic reinitialization!"
          do i=1,nsurft
            i2 = i + nsurft
            cre(i2)=cre(i)
            cim(i2)=cim(i)
            gcre(i2)=gcre(i)
            gcim(i2)=gcim(i)
          enddo
c         update information (check this)
          call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     &     phop,dmag,dvec,pem,gpem,phase)
        endif
      endif
      dmag2 = dmag1
      dmag1 = dmag
      endif

c multiply hopping probability by stepsize for both surface hopping
c and DM methods
      phop(nsurf) = 1.d0
      do i=1,nsurft
        if (i.ne.nsurf) then
          phop(i)=phop(i)*step
          phop(i)=max(phop(i),0.d0)
c         Note:  phop can be > 1 if the probabilities are changing too
c         quickly.  But this shouldn't happen too often.  For better
c         results we'd need to integrate the hopping probability so
c         that the integrator takes smaller steps when necessary.
          phop(i)=min(phop(i),1.d0)
c         prob of staying in NSURF = 1 - sum of all hopping probs
          phop(nsurf) = phop(nsurf) - phop(i)
        endif
      enddo

c FSTU, check for frustrated hop
      if (methflag.eq.5) then
        call checkfrus(nat,nsurf,pp,pem,dvec,frusflag,tu_maxt)
        do k=1,nsurft
          if ((.not.lfrust).and.frusflag(k).eq.0) then
c           at this time a hop is allowed, save information
c           for k = nsurf, we save the current info
c           when lfrust = true, we are looking for a hopping
c           location, so we do not save info
            do i=1,nat
            do j=1,3
              tu_xx(j,i,k) = xx(j,i)
              tu_pp(j,i,k) = pp(j,i)
            enddo
            enddo
            do i=1,nsurft
              tu_cre(i,k) = cre(i)
              tu_cim(i,k) = cim(i)
              tu_phase(i,k) = phase(i)
            enddo
            tu_hstep(k) = hstep
            tu_istep(k) = istep
            tu_time(k) = time
          endif
        enddo
      endif

c TFS and FSTU check for a hop
      if (methflag.eq.1.or.(methflag.eq.5.and.(.not.lfrust))) then
        lhop = .false.
        call checkhop(phop,nsurf,lhop,newsurf)
      endif

c intercept a frustrated hop for FSTU
      if (methflag.eq.5.and.lhop) then
        if (frusflag(newsurf).ne.0) then
c       this hop would be frustrated
        lfrust = .true.
        lhop = .false.
        tu_maxtime = tu_maxt(newsurf)
        endif
      endif

c handle frustrated hop with FSTU
      if (methflag.eq.5.and.lfrust) then
        deltback = tu_time(nsurf) - tu_time(newsurf)
        deltforw = time - tu_time(nsurf)
        if (tu_time(newsurf).ge.0.d0.and.deltback.lt.deltforw.and.
     &                                   deltback.le.tu_maxtime) then
c         do a TU hop backward
          write(6,*)"BACKWARD HOP!"
          do i=1,nat
          do j=1,3
            xx(j,i) = tu_xx(j,i,newsurf)
            pp(j,i) = tu_pp(j,i,newsurf)
          enddo
          enddo
          do i=1,nsurft
            cre(i) = tu_cre(i,newsurf)
            cim(i) = tu_cim(i,newsurf)
            phase(i) = tu_phase(i,newsurf)
          enddo
          hstep = tu_hstep(newsurf)
          istep = tu_istep(newsurf)
          time = tu_time(newsurf)
          lhop = .true.
        else if (frusflag(newsurf).eq.0.and.deltforw.le.tu_maxtime) then
c         do a TU hop forward
          write(6,*)"FORWARD HOP!"
          lhop = .true.
        else if (deltforw.gt.tu_maxtime) then
c         do a frustrated hop at the original hopping location
          do i=1,nat
          do j=1,3
            xx(j,i) = tu_xx(j,i,nsurf)
            pp(j,i) = tu_pp(j,i,nsurf)
          enddo
          enddo
          do i=1,nsurft
            cre(i) = tu_cre(i,nsurf)
            cim(i) = tu_cim(i,nsurf)
            phase(i) = tu_phase(i,nsurf)
          enddo
          hstep = tu_hstep(nsurf)
          istep = tu_istep(nsurf)
          time = tu_time(nsurf)
          lhop = .true.
        endif
        if (lhop) then
        lfrust = .false.
        call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     &   phop,dmag,dvec,pem,gpem,phase)
          do i=1,nsurft
c           reset all backward hops
            tu_time(i) = -1.d0
          enddo
        endif
      endif

c hop or do a frustrated hop
      if ((methflag.eq.1.or.methflag.eq.5).and.lhop) then
        n1 = nsurf  ! current state
        n2 = newsurf  ! target state
        if (stodecoflag) then
        stodecotime=time ! save the time of this hopping event in STODECOTIME
        call elecdeco(ithistraj,istep,time,nat,n1,n2,
     &   pem,gpem,dvec,xx,pp,stodecotau)   ! returns STODECOTAU, which is the
                                           ! characteristic decoherence time computed
                                           ! using the JCP paper formula
!        write(6,*)"Setting stodecotau to ",stodecotau*autofs," fs"
        endif

        nhop = nhop + 1
c       switch surfaces or reflect/ignore frustrated hop
        call hop(ithistraj,istep,time,nat,nsurf,newsurf,
     &   pem,gpem,dvec,xx,pp,stodecotau)
        call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     &   phop,dmag,dvec,pem,gpem,phase)
c AJAJAJAJ
c Switch commented out parts to stop allowing TU hops up at the last hop down
            do i=1,nat
            do j=1,3
              tu_pp(j,i,n1) = pp(j,i)
              tu_pp(j,i,n2) = pp(j,i)
            enddo
            enddo
c        do i=1,nsurft
c         reset all backward hops
c          tu_time(i) = -1.d0
c        enddo
c AJAJAJAJ
      endif

c for Semiclassical Ehrenfest, change NSURF according to RHOR
      if (methflag.eq.2) then
        call getrho(cre,cim,rhor,rhoi,nsurft)
        tmp1 = 0.d0
        do i=1,nsurft
          if (rhor(i,i).gt.tmp1) then
            tmp1 = rhor(i,i)
            nsurf = i
          endif
        enddo
      endif

c SCDM and CSDM, check for a decoherence state switch
      if (methflag.eq.3.or.methflag.eq.4) then
        lhop = .false.
        call decocheck(phop,nsurf,lhop)
        if (lhop) then
        hstep=hstep0/5.d0
        call getgrad(xx,pp,nsurf,pe,cre,cim,gv,gcre,gcim,nat,
     &    phop,dmag,dvec,pem,gpem,phase)
        endif
      endif

c for steepest descent (TFLAG(1) = 1 or 4)
c set PP to zero at every step
      if (tflag(1).eq.1.or.tflag(1).eq.4) then
        do i=1,nat
        do j=1,3
        pp(j,i) = 0.d0
        enddo
        enddo
      endif

c on-the-fly analyses
      ce = -pe/dble(nat)
      call gettemp(pp,mm,nat,temp,ke)
      call angmom(xx,pp,mm,nat,bigj,bigjtot)
      te = ke + pe
      call lindemann(xx,nat,step,time,arij,arij2,lind)
      if ( (mod(istep,nprint).eq.0.or.istep.eq.1) .and. lwrite(43) )
     &                           call rarray(ithistraj,time,xx,nat)
      if (lwrite(41)) then
        if (mod(istep,nprint).eq.0.or.istep.eq.1) then
          call radialdist(ithistraj,xx,nat,step,time,nbinrad,raddist,1)
        else
          call radialdist(ithistraj,xx,nat,step,time,nbinrad,raddist,0)
        endif
      endif
      atemp = atemp + temp*step
      atemp2 = atemp2 + (temp**2)*step
      stemp = dsqrt(atemp2/time - (atemp/time)**2)

      if (rhor(1,1).ge.0.2d0.and.rhor(1,1).le.0.8d0.and.lwrite(35)) then
      write(35,1035)ithistraj,istep,time*autofs,step*autofs,
     &     taup(1)*autofs,taup(2)*autofs,
     &     taup(3)*autofs,rhor(1,1),rhor(2,2)
      endif
 1035  format(2i8,10f15.5)

c write info every nprint steps
      call getrho(cre,cim,rhor,rhoi,nsurft)
      if (mod(istep,nprint).eq.0.or.istep.eq.1) then
c molden format
       nistep = nistep + 1
       if (lwrite(81)) then
          write(81,*)nat
          write(81,1081)istep,pe
          do i=1,nat
            write(81,1080)symbol(i),(pp(j,i),j=1,3)
          enddo
       endif
       if (lwrite(80)) then
          write(80,*)nat
          write(80,1081)istep,pe,time*autofs
          do i=1,nat
            write(80,1080)symbol(i),(xx(j,i)*autoang,j=1,3)
 1080       format(a2,3E18.8)
 1081       format(i7,3E18.8)
          enddo
       endif
       if (lwrite(82)) write(82,REC=nistep)nat,istep,pe,
     &  (symbol(i),i=1,nat),((xx(j,i)*autoang,j=1,3),i=1,nat)
       if (lwrite(83)) write(83,REC=nistep)nat,istep,pe,
     &  (symbol(i),i=1,nat),((pp(j,i),j=1,3),i=1,nat)
       if (lwell.gt.0) then
         call detwell(pe,xx,welli)
         if (welli.eq.lwell) then
           istepw=istepw+1
           nistepw=nistepw+1
           if (lwrite(86)) then
             write(86,*)nat
             write(86,1081)istepw,pe
             do i=1,nat
               write(86,1080)symbol(i),(xx(j,i)*autoang,j=1,3)
             enddo
           endif
           if (lwrite(87)) then
             write(87,*)nat
             write(87,1081)istepw,pe
             do i=1,nat
               write(87,1080)symbol(i),(pp(j,i),j=1,3)
             enddo
           endif
           if (lwrite(88)) write(88,REC=nistepw)nat,istepw,pe,
     &      (symbol(i),i=1,nat),((xx(j,i)*autoang,j=1,3),i=1,nat)
           if (lwrite(89)) write(89,REC=nistepw)nat,istepw,pe,
     &      (symbol(i),i=1,nat),((pp(j,i),j=1,3),i=1,nat)
         else if (welli.eq.3) then
           write(6,*)"welli=",welli," not supported"
         endif
       endif
       if (lwrite(42)) call honey(ithistraj,xx,nat,time)
       if (termflag.eq.2) then
          if(nsurft.eq.1) then
            write(6,101)istep,time*autofs,pe*autoev,
     &    dsqrt(gvmag)*autoev/autoang
          else
            write(6,101)istep,time*autofs,(pem(j)*autoev,j=1,nsurft),
     &    dsqrt(gvmag)*autoev/autoang
          endif
       else
        if (nsurft.eq.1.and.lwell.eq.0) then
c          write(6,101)istep,time*autofs,temp,
c     &    ke*autoev,pe*autoev,te*autoev,
c     &    lind,atemp/time,stemp
          write(6,103)istep,time*autofs,temp,
     &    ke*autoev,pe*autoev,te*autoev,
     &    lind,atemp/time,stemp
c     &    ,wellindex1,wellindex2,xwell
        else if (nsurft.eq.1.and.lwell.gt.0) then
          write(6,104)istep,istepw,time*autofs,temp,
     &    ke*autoev,pe*autoev,te*autoev,
     &    lind,atemp/time,stemp
        else
c          write(6,101)istep,time*autofs,temp,
c     &    ke*autoev,pe*autoev,te*autoev,
c     &    (rhor(k,k),k=1,nsurft),pem(1)*autoev,pem(2)*autoev
c temp
          write(6,102)istep,time*autofs,temp,
     &    ke*autoev,pe*autoev,te*autoev,
     &    (rhor(k,k),k=1,nsurft),(pem(k)*autoev,k=1,nsurft)
     &     ,dmag,h12x*autocmi
c     &     dmag,h12x*autocmi,h12y*autocmi
c     &    ,wellindex1,wellindex2,xwell
        endif
       endif
      endif
 101  format(i15,f15.3,20f21.9)
 102  format(i15,f15.3,100f15.5)
 103  format(i15,f15.3,7f15.5,2i5,f8.2)
 104  format(i15,i15,f15.3,7f15.5,2i5,f8.2)
 105  format(i15,i15,f15.3,20f15.5)

 10   continue

c ######################################################################
c ######################################################################

 999  continue

      if (lwrite(16))
     & write(16,'(2f13.5,2e18.5,3e18.5)')time*autofs,1.d4,
     & phop(1)*step,rhor(1,1),
     & (taup2(i)*autofs,i=1,3)

c trajectory has ended
      if (lwrite(96))
     & write(96,1096)ithistraj,outcome,nbz2,2.d0*bqci/bmaxqc,
     & tbz2*autofs,tbz0*autofs,tbzf*autofs
 1096  format(3i5,10f15.3)

c write final coordinates and momenta to output
      IF (outcome.ge.0) THEN
      if (termflag.eq.2) then
          write(6,101)istep,time*autofs,
     &    pe*autoev,dsqrt(gvmag)*autoev/autoang
      else
        if (nsurft.eq.1.and.lwell.eq.0) then
          write(6,101)istep,time*autofs,temp,
     &    ke*autoev,pe*autoev,te*autoev,
     &    lind,atemp/time,stemp
        else if (nsurft.eq.1.and.lwell.gt.0) then
          write(6,105)istep,istepw,time*autofs,temp,
     &    ke*autoev,pe*autoev,te*autoev,
     &    lind,atemp/time,stemp
        else
          write(6,101)istep,time*autofs,temp,
     &     ke*autoev,pe*autoev,te*autoev,
     &     (rhor(k,k),k=1,nsurft)
        endif
      endif
      if (lwrite(41)) then
      call radialdist(ithistraj,xx,nat,step,time,nbinrad,raddist,1)
      endif
      if (lwrite(42)) call honey(ithistraj,xx,nat,time)
      ENDIF

      if (lwrite(20)) then
      write(20,*)ithistraj,pe*autoev
      do i=1,nat
      write(20,1010)symbol(i),mm(i)/amutoau,(xx(j,i)*autoang,j=1,3)
      enddo
      endif

      if (lwrite(21)) then
      write(21,*)ithistraj,ke*autoev
      do i=1,nat
      write(21,1010)symbol(i),mm(i)/amutoau,(pp(j,i),j=1,3)
      enddo
      endif

      if (lwrite(91)) write(91,*)ithistraj,rvdw*autoang,evdw*autocmi

 1001 return
      end


      SUBROUTINE READ_MDS
     &          (lu_mds,print_mds,
     &           bearng,rhomx,rlat,rlon,rrho,
     &           mxprm1,nrprm1,param1,
     &           mxeigen,nreigen,eigen,
     &           mxprm2,nrprm2,param2,
     &           begin_file,end_file)

c***********************************************************************
c                         subroutine read_mds
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     10 Apr 1990

c  Function:
c     Reads mode solution data.

c  Parameters passed:
c     lu_mds           [i] number of the logical unit; must already be
c                          openned by the calling routine
c     print_mds        [i] >0 prints parameters from passed data

c     mxprm1           [i] dimension of array PARAM1 in the calling
c                          routine
c     mxeigen          [i] dimension of array EIGEN in the calling
c                          routine
c     mxprm2           [i] dimension of array PARAM2 in the calling
c                          routine

c     begin_file       [l] indicates beginning of file; must be set to
c                          .TRUE. at  by the calling routine

c  Parameters returned:
c     bearng           [r] bearing of path; degrees E of N
c     rhomx            [r] maximum range of path; km
c     rlat             [r] receiver  latitude; degrees N
c     rlon             [r] receiver longitude; degrees W
c     rrho             [r] range to receiver; km

c     nrprm1           [i] number of PARAM1
c     param1           [r] path parameters (see below)

c     nreigen          [i] number of EIGEN
c     eigen            [c] mode solutions

c     nrprm2           [i] number of PARAM2
c     param2           [c] mode parameters (see below)

c     end_file         [l] indicates end of the input file; set to
c                          .TRUE. by this routine as required

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     print
c     read

c  References:

c  Change History:
c     20 Feb 92     Added profile index to PARAM1.

c     03 Jan 94     Added END= and ERR= to read statements to aid
c                   error handling.

c     21 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c  Notes:
c     Wherever indicated, ranges are distances from the transmitter.

c     The file begins with a header record which identifies the program
c     which generated the data, the date the program was run,
c     transmitter parameters and the parameters of the paths. This
c     record is processed by the routine READ_HDR.

c     Subsequent records contain data for the individual segments of the
c     path followed by records for each mode within that segment. To
c     allow for future expansion, the path parameters are passed in an
c     array along with the number of elements in the array. This program
c     reads these parameters into the array, PARAM1, which is assumed to
c     contain the following:

c      1)lat        latitude;  degrees North
c      2)lon        longitude; degrees West
c      3)rho        range to the segment; km
c      4)azim       geomagnetic azimuth; degrees E of path direction
c      5)dip        geomagnetic dip; degrees below horizontal
c      6)bfield     geomagnetic intensity; Gauss
c      7)sigma      ground conductivity; Seimens
c      8)epsr       ground dielectric constant
c      9)beta       exponential ionospheric conductivity slope; km-1
c     10)hprime     exponential ionospheric conductivity height; km
c     11)pindex     profile index for non-exponential profiles

Change: 20 Feb 92   This parameter added
c     11)pindex     profile index for non-exponential profiles

c     The mode parameters are read into the complex arrays EIGEN and
c     PARAM2. The array PARAM2 contains the terms required to calculate
c     excitation factors: T1, T2, T3, T4 and f(R).

c     The last segment is indicated by a record with NRPRM1=1 and LAT=99

c     The mode generation programs sometimes experience problems and
c     do not successfully obtain mode solutions. These cases are
c     indicated by NREIGEN<1.

c*******************!***************************************************

c     LWPC parameters
      include      'lwpc_lun.cmn'

      logical       begin_file,end_file,new_path
      integer       lu_mds,print_mds,
     &              mxprm1,nrprm1,mxeigen,nreigen,mxprm2,nrprm2
      real     *  4 bearng,rhomx,rlat,rlon,rrho,param1(mxprm1)
      complex  *  8 eigen(mxeigen),param2(mxprm2,mxeigen)

      if (begin_file) then

c        At the start of the file
         begin_file=.false.
         end_file=.false.
         new_path=.true.
      end if

      read (lu_mds,end=99,err=98)
     &      bearng,rhomx,rlat,rlon,rrho,
     &      nrprm1,nreigen,nrprm2,
     &     (param1(i),i=1,nrprm1)

      if (nreigen .gt. 0)
     &   read (lu_mds,end=99,err=98)
     &        (eigen(m),(param2(i,m),i=1,nrprm2),m=1,nreigen)

      if (print_mds .gt. 0) then

         if (new_path) then

            write(lwpcLOG_lun,
     &          '(''bearng   rlat    rlon    rrho''/
     &              f6.1,f7.1,f8.1,f8.0)')
     &              bearng,rlat,rlon,rrho

            write(lwpcLOG_lun,
     &          '(''mds    lat     lon    rho    azim    dip '',
     &            ''bfield   sigma epsr  beta   hpr  ndx'')')

            new_path=.false.
         end if

         if (param1(1) .eq. 99.) then

            write(lwpcLOG_lun,'(3x,f7.1)') param1(1)
            new_path=.true.
         else

            write(lwpcLOG_lun,
     &          '(i3,f7.1,f8.1,f8.0,f7.1,f7.1,f7.3,1pe8.0,0pf5.0,
     &            f6.2,f6.1,f6.0)')
     &            nreigen,(param1(i),i=1,nrprm1)

            if (nreigen .gt. 0 .and. print_mds .gt. 1) then

               write(lwpcLOG_lun,'(''     m  EIGENr   EIGENi '')')
               neigen=1
               do while (neigen .le. nreigen)
                  write(lwpcLOG_lun,'(3x,i3,2f9.4,1p10e10.2)')
     &                  neigen,eigen(neigen),
     &                 (param2(i,neigen),i=1,nrprm2)
                  neigen=neigen+1
               end do
               write(lwpcLOG_lun,
     &             '(/''mds    lat     lon    rho    azim    dip '',
     &                ''bfield  sigma epsr   beta   hpr  ndx'')')
            end if
         end if
      end if

c     End of segment
      RETURN

c     Error reading file; incomplete segment
98    param1(1)=-99.

c     End of file
99    end_file=.true.
      RETURN
      END      ! READ_MDS


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!    Date:       5 Oct 1992
!    Time:       22:20
!    Program:    CECCAL.FOR
!    Version:    6.00.00
!    Programmer: Nicolaas M de Rooij
!
      subroutine ceccal
!        ceccalc computes pie cec for compartment k
!        procedure equivalent to phcalc
      include  'char1.inc'
      character*6 cacec,cecc,capl
      DATA CACEC/'CACEC '/
      DATA CECC/'CEC   '/
      DATA CAPL/'CA++  '/
      do 10 i=1,m
      if(nr(i,1).eq.cacec) go to 20
   10 continue
      go to 60
   20 do 30 j=1,ntot
      if(kn(j).eq.cacec) go to 40
   30 continue
      go to 60
   40 do 50 i=1,m
      if(nr(i,1).eq.capl ) go to 80
   50 continue
   60 do 70 i=1,m
      if(nr(i,1).eq.cecc) go to 90
   70 continue
      go to 99
   80 if( x(j) .lt. 1.0d-60 .or. xbar(jcomp(j)) .lt. 1.0d-60 )go to 99
      ceck= divide( x(j),xbar(jcomp(j)) )
      ceck= dlog( ceck ) -0.5d+00 * pie(i)
      return
   90 ceck=  pie(i)
      return
   99 ceck  = -0.0d+00
      return
      end


      SUBROUTINE PHO_HACODE(Id1,Id2,Idcpc1,Idcpc2)
C*********************************************************************
C
C     determination of hadron index from quarks
C
C     input:   ID1,ID2   parton code according to PDG conventions
C
C     output:  IDcpc1,2  CPC particle codes
C
C*********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER Id1 , Id2 , Idcpc1 , Idcpc2

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general particle data
      INCLUDE 'inc/popar2'

C  local variables
      INTEGER ii , jj , kk , i1 , i2

      Idcpc1 = 0
      Idcpc2 = 0

      IF ( Id1*Id2.LT.0 ) THEN
C  meson
         IF ( Id1.GT.0 ) THEN
            ii = Id1
            jj = -Id2
         ELSE
            ii = Id2
            jj = -Id1
         END IF
         Idcpc1 = ID_psm_list(ii,jj)
         Idcpc2 = ID_vem_list(ii,jj)

      ELSE
C  baryon
         i1 = ABS(Id1)
         i2 = ABS(Id2)
         IF ( i1.GT.6 ) THEN
            ii = i1/1000
            jj = (i1-ii*1000)/100
            kk = i2
         ELSE
            ii = i1
            jj = i2/1000
            kk = (i2-jj*1000)/100
         END IF
         Idcpc1 = SIGN(ID_b8_list(ii,jj,kk),Id1)
         Idcpc2 = SIGN(ID_b10_list(ii,jj,kk),Id1)

      END IF

      END SUBROUTINE


!
!***********************************************************************
!                                                                      *
      PROGRAM rlevelsname
!                                                                      *
!     Purpose:                                                         *
!     Extract energy levels from rscf/rci output files (.m, .cm file)  *
!     and from jj2lsj output file (*.lsj.lbl).                         *
!     And then:                                                        *
!         (1) sort                                                     *
!         (2) difference with the lowest                               *
!         (3) difference with the nearby lower                         *
!     Files names are provided by user.                                *
!     Usage:                                                           *
!           $ grlevels file1 file2 file3 ...                           *
!           or                                                         *
!           $ grlevels                                                 *
!           file1                                                      *
!           file2                                                      *
!           file3                                                      *
!           ... (return to terminate)                                  *
!                                                                      *
!     Calls: LDLBL, indexS.                                            *
!                                                                      *
!     Xinghong He  98-10-16                                            *
!                                                                      *
!     Rewritten by  G. Gaigalas                                        *
!     for LSJ calssification of levels                                 *
!     NIST                                                 May 2011    *
!     Adapted by Per Jonsson for producing latex tables November 2014  *
!                                                                      *
!***********************************************************************
      IMPLICIT NONE
      INTEGER, PARAMETER:: JMax = 22      ! max J value, see JFraction !
      INTEGER, PARAMETER:: ndim = 20000   ! max number of states
      INTEGER, PARAMETER:: maxFile = 1000 ! max number of files
      DOUBLE PRECISION, PARAMETER:: Rydberg = 109737.31568508D0
!
      CHARACTER(LEN=20) strInFile(maxFile), strFile, strFile2
      CHARACTER*1 iaspa(ndim), PlusMinus(-1:1)        ! Parity
      CHARACTER*1 Lev_par(ndim)                       ! Parity
      CHARACTER*4 iatjp(ndim), JFraction(1:2*Jmax+1)  ! J
      CHARACTER*4 Lev_J(ndim)                         ! J
      CHARACTER g92mix*6
      CHARACTER*63 string63(ndim)
      CHARACTER*64 string_CSF(ndim), string_PRN(ndim), latexstring ! String in LSJ
      CHARACTER*64 blankstring,inputstring
      CHARACTER*20 string_file(ndim)
      CHARACTER util_lbl_file*256
      CHARACTER*80 finallatex(ndim)
      CHARACTER*100 string
      character*2 labelchar(ndim)
!
      INTEGER i, j, iargc, ios, ncountState, nFile, mFile, nfound
      INTEGER nelec, ncftot, nw, nvectot, nvecsiz, nblock, jblock
      INTEGER nb, ncfblk, nevblk, iiatjp, iiaspa, ascii
      INTEGER K, Iprint, IMaxCount
      INTEGER ivec(ndim), indx(ndim), Lev_POS(ndim),nskip,nsame
!
      DOUBLE PRECISION eav, eval(ndim), evec, RLev_ENER(ndim),ZERO
!
      COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, &
                      IMaxCount
!
      DATA PlusMinus/'-', ' ', '+'/
      DATA JFraction/'  0 ', ' 1/2', '  1 ', ' 3/2', '  2 ', ' 5/2',  &
                     '  3 ', ' 7/2', '  4 ', ' 9/2', '  5 ', '11/2',  &
                     '  6 ', '13/2', '  7 ', '15/2', '  8 ', '17/2',  &
                     '  9 ', '19/2', ' 10 ',  &
                             '21/2', ' 11 ', '23/2', ' 12 ', '25/2',  &
                     ' 13 ', '27/2', ' 14 ', '29/2', ' 15 ', '31/2',  &
                     ' 16 ', '33/2', ' 17 ', '35/2', ' 18 ', '37/2',  &
                     ' 19 ', '39/2', ' 20 ', '41/2', ' 21 ', '43/2',  &
                     ' 22 '/
!

      WRITE(*,*) ' RTABTRANS1    '
      WRITE(*,*) ' This program creates a file energylabel that is'
      WRITE(*,*) ' used by RTABTRANS2 to produce LaTeX or ASCII   '
      WRITE(*,*) ' tables of transition data                      '
      WRITE(*,*) ' Input files: mixing coefficient files          '
      WRITE(*,*) '      name1.(c)m, name2.(c)m,.... for the wave- '
      WRITE(*,*) '      functions that are used to compute the    '
      WRITE(*,*) '      transition data                           '
      WRITE(*,*) ' Output file: energylabel.latex(ascii)          '
      WRITE(*,*)

      labelchar(:) = ' '

      DO I = 1,64
         blankstring(I:I) = ' '
      END DO

      mFile = iargc()
      string_PRN = ''
      Iprint = 0
      ZERO = 0.0D00
      IF (mFile .EQ. 0) THEN                 ! Get file names interactively
         WRITE (0,*)' Type the full input file name, one for each line',&
                    ' (NULL to terminate)'
         WRITE (0,*)
         i = 0
         DO  ! Don't know the exact number of files.
            WRITE (0,'(A12)', ADVANCE='NO') 'File name ? '
            READ (5, '(A20)') strFile
            strFile = ADJUSTL (strFile)
            IF (LEN_TRIM (strFile) .GT. 0) THEN ! a valid input
               i = i + 1
               IF (i .GT. maxFile) THEN      !  impose an upper limit
                  WRITE (0,*) 'Too many files opened. processing first '&
                             , i-1, ' files.'
                  EXIT
               ENDIF
               strInFile(i) = strFile
            ELSE
               EXIT
            ENDIF
         ENDDO
         mFile = i
      ELSEIF (mFile .GT. 0 .AND. mFile .LE. maxFile) THEN
         DO i = 1, mFile
            CALL getarg (i, strInFile(i))
         ENDDO
      ELSE
         WRITE (0,*) 'More than ', maxFile, ' files entered,',   &
                  ' modify parameter maxFile'
      ENDIF

      write(*,*) 'mFile',mFile

      write(*,*)
      write(*,*) ' Inspect the labels of the states and '
      write(*,*) ' determine how many positions should be skipped in '
      write(*,*) ' the string that determines the label. For example'
      write(*,*) ' if all the states have a common core 1s(2) in the '
      write(*,*) ' label then 6 positions should be skipped'
      write(*,*)
      write(*,*) ' How many positions should be skipped?'
      read(*,*) NSKIP
      write(*,*) ' Output labels in LaTeX or ASCII format (0/1)? '
      read(*,*) ascii

      IF (ASCII.EQ.1) THEN
         OPEN(UNIT=9,file='energylabel.ascii',status='unknown',  &
              form='formatted')
      ELSE
         OPEN(UNIT=9,file='energylabel.latex',status='unknown',  &
              form='formatted')
      END IF

!
!     Open files, read energies, concatenate to a single place
!     Open mix file, check header
!
      ncountState = 0
      IMaxCount = 0
      DO nFile = 1, mFile
         strFile = strInFile(nFile)
         OPEN (3, FILE = strFile, FORM = 'UNFORMATTED', STATUS = 'OLD'&
            , IOSTAT = IOS)
         IF (IOS .NE. 0) THEN
           WRITE (0,*) 'Failed to open file "',                       &
                strFile(1:LEN_TRIM (strFile)), '", skipping...'
            CLOSE (3)
            CYCLE
         ENDIF
         READ (3) g92mix
         IF (g92mix .NE. 'G92MIX') THEN
            WRITE (0,*) 'Not a mixing coefficient file, skipping "',  &
                      strFile(1:LEN_TRIM (strFile)), '"'
            CLOSE (3)
            CYCLE
         ENDIF

! Now trim the file string

         strFile2 = strFile
         nfound = 0
         DO i = 20,1,-1
            if (strFile2(i:i).eq.'/') then
               nfound = i
               exit
            end if
         END DO
         if (nfound.ne.0) then
            do i = 1,nfound
               strFile2(i:i) = ' '
            end do
         end if
         nfound = 0
         DO i = 20,3,-1
            if ((strFile2(i-2:i).eq.'.cm').OR.  &
               (strFile2(i-2:i).eq.'.m '))      &
               then
               nfound = i
               exit
            end if
         END DO
         if (nfound.ne.0) then
            do i = 1,3
               strFile2(i-3+nfound:i-3+nfound) = ' '
            end do
         end if

         strFile2 = adjustl(strFile2)

         READ (3) nelec, ncftot, nw, nvectot, nvecsiz, nblock
!
         WRITE(9,*) 'nblock = ', nblock, '  ncftot = ', ncftot, &
                      '  nw = ', nw, '  nelec = ', nelec

         DO jblock = 1, nblock
            READ (3) nb, ncfblk, nevblk, iiatjp, iiaspa
            IF (jblock .NE. nb) THEN
!
!     This error can occur anywhere and therefore cannot
!     be simply skipped - stop instead.
!
               WRITE (0,*) 'jblock .NE. nb, stopping...'
               CLOSE (3)
               STOP
            ENDIF
            IF (nevblk .LE. 0) CYCLE
            READ (3) (ivec(i+ncountState), i = 1, nevblk)
            READ (3) eav, (eval(i+ncountState), i = 1, nevblk)
            READ (3) (evec, i = 1, ncfblk*nevblk)
!
!     Assign J and parity to every individual state
!     Also add the average energy (back) to energy
!
            DO i = 1, nevblk
               iatjp(i+ncountState) = JFraction(iiatjp)
               iaspa(i+ncountState) = PlusMinus(iiaspa)
               eval(i+ncountState) = eval(i+ncountState) + eav
               string_file(i+ncountState) = strFile2
            END DO
!
!     Update ncountState
!
            ncountState = ncountState + nevblk
         END DO
         CLOSE (3)
!
!     Opens the file  *.lsj.lbl
!
         K = INDEX(strFile,' ')
         if(strFile(K-2:K-1) .EQ. '.m') then
            util_lbl_file = strFile(1:K-3)//'.lsj.lbl'
         else if(strFile(K-3:K-1) .EQ. '.cm') then
            util_lbl_file = strFile(1:K-4)//'.lsj.lbl'
         end if
         OPEN (31, FILE = util_lbl_file, FORM = 'FORMATTED',   &
            STATUS = 'OLD', IOSTAT = IOS)
         IF (IOS .NE. 0) THEN
!GG            WRITE (0,*) 'Failed to open file "',
!GG     &      util_lbl_file(1:LEN_TRIM (util_lbl_file)), '", skipping...'
            CLOSE (31)
            CYCLE
         END IF
         Iprint = 1
!
!     Defines the LSJ string for the levels
!
         CALL LDLBL
         CLOSE (31)
         do i = 1,ncountState
            do j = 1,IMaxCount
               if(DABS(DABS(eval(i))-DABS(RLev_ENER(j)))  &
                                 .LT. 0.00000001) then
                   string_PRN(i) =  string_CSF(j)
                   exit
               end if
            end do
         end do
      END DO
      CALL indexS (ncountState, eval, .FALSE., indx)
!
!     The output of the levels
!
      WRITE (9,*)
      WRITE (9,1)
      WRITE (9,2) Rydberg
      if(Iprint .eq. 1) then
         WRITE (9,5)
         WRITE (9,*) 'No - Serial number of the state; ',     &
                     'Pos - Position of the state within the '
         WRITE (9,*) 'J/P block;'
         WRITE (9,5)
         WRITE (9,*) 'No Pos  J Parity Energy Total    Levels', &
                     '   File          Configuration'
         WRITE (9,*) '                     (a.u.)      (cm^-1)'
         WRITE (9,5)
         j = 1
         i = indx(j)

         inputstring = blankstring
         inputstring(1:64-NSKIP) = string_PRN(i)(1 + NSKIP:64)
         if (ascii.eq.1) then
           latexstring = inputstring
         else
           call latexconvert(inputstring,latexstring)
           latexstring = '$'//trim(latexstring)//'_{'//iatjp(i)
           if (iaspa(i).eq.'-') then
              latexstring = trim(latexstring)//'}^o$'
           else
              latexstring = trim(latexstring)//'}$'
           end if
         end if

         WRITE (9,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),    &
            ZERO,                                            &
            string_file(i),Trim(latexstring)
         DO j = 2, ncountState
            i = indx(j)
            inputstring = blankstring
            inputstring(1:64-NSKIP) = string_PRN(i)(1 + NSKIP:64)
            if (ascii.eq.1) then
              latexstring = inputstring
            else
              call latexconvert(inputstring,latexstring)
              latexstring = '$'//trim(latexstring)//'_{'//iatjp(i)
              if (iaspa(i).eq.'-') then
                 latexstring = trim(latexstring)//'}^o$'
              else
                 latexstring = trim(latexstring)//'}$'
              end if
            end if
            WRITE (9,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),   &
            (eval(i)-eval(indx(1)))*Rydberg*2,                 &
            string_file(i),Trim(latexstring)
         END DO
!         WRITE (6,5)
      ELSE
         WRITE (9,*) 'No - Serial number of the state; ',     &
                     'Pos - Position of the state within the '
         WRITE (9,*) 'J/P block;'
         WRITE (9,5)
         WRITE (9,*) 'No Pos  J Parity Energy Total    Levels', &
                     '   File          Configuration'
         WRITE (9,*) '                     (a.u.)      (cm^-1)'
         WRITE (9,5)
         j = 1
         i = indx(j)
         write(latexstring,'(a1,i3,a3,a4,3a1)')  '$',j,'~J=', &
                  iatjp(i),'^',iaspa(i),'$'
         WRITE (9,3)
         WRITE (9,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),ZERO, &
                    string_file(i),trim(latexstring)
         DO j = 2, ncountState
            i = indx(j)
            write(latexstring,'(a1,i3,a3,a4,3a1)')  '$',j,'~J=',&
                 iatjp(i),'^',iaspa(i),'$'
            WRITE (9,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),   &
            (eval(i)-eval(indx(1)))*Rydberg*2,                 &
            string_file(i),trim(latexstring)
         END DO
!         WRITE (6,6)
      END IF

!     Check that there are no states with the same label. If so add
!     character at the end of the label

      REWIND(9)
      NFOUND = 0
      DO
         READ(9,'(A)') STRING
         IF (STRING(1:5).EQ.'-----') THEN
            NFOUND = NFOUND + 1
         END IF
         IF (NFOUND.EQ.3) EXIT
      END DO

      DO j = 1, ncountState
         read(9,'(2A)') string63(j),finallatex(j)
      END DO

!     Check for states with the same label

      do j = 1,ncountState
         nsame = 0
         do k = j+1,ncountState
!            if ((finallatex(j).eq.finallatex(k)).and.(labelchar(k)
!    :          .eq.'  ')) then
            if ((finallatex(j).eq.finallatex(k)).and.            &
             (string63(j)(7:15).eq.string63(k)(7:15)).and.       &
             (labelchar(k) .eq.'  ')) then
               nsame = nsame + 1
               if (nsame.eq.1) then
                  labelchar(k) = '~b'
               else if (nsame.eq.2) then
                  labelchar(k) = '~c'
               else if (nsame.eq.2) then
                  labelchar(k) = '~d'
               else
                  write(*,*) 'Too many states with the same label'
                  stop
               end if
            end if
         end do
         if (nsame.gt.0) labelchar(j) = '~a'
      end do

      REWIND(9)
      NFOUND = 0
      DO
         READ(9,'(A)') STRING
         IF (STRING(1:5).EQ.'-----') THEN
            NFOUND = NFOUND + 1
         END IF
         IF (NFOUND.EQ.3) EXIT
      END DO

      do j = 1, ncountState
         if (ascii.eq.1) then
           write(9,'(2A)') string63(j),trim(finallatex(j))//' '// &
                  labelchar(j)(2:2)
         else
           i = 1
           do
              if (finallatex(j)(i:i).eq.'}') exit
              i = i + 1
           end do
           write(9,'(2A)') string63(j),finallatex(j)(1:i-1)//     &
                         labelchar(j)//finallatex(j)(i:i+3)
         end if
      END DO

      CLOSE(9)

      write(*,*) ' Energy label data written to file'
      write(*,*) ' energylabel.latex(ascii)'

   1  FORMAT (' Energy levels for ...')
   2  FORMAT (' Rydberg constant is ',F14.5)
   3  FORMAT (2I3,1X,A4,1x,A1,2X,F14.7,F12.2,2X,A,A)
   5  FORMAT ('---------------------------------------------',  &
              '---------------------------------------------')
   6  FORMAT ('------------------------------------------',     &
              '-------------------------------')
      STOP
      CONTAINS
!
!***********************************************************************
!                                                                      *
      SUBROUTINE indexS(n,a,ldown,indx)
!                                                                      *
!     Sort out the order of array a and store the index in indx        *
!                                                        (a pointer)   *
!     The input array a is unchanged  written in the bases of UpDown   *
!                                                                      *
!     !$Id: rlevels.f,v 1.2 2003/10/02 07:56:22 per Exp $              *
!     $Log: rlevels.f,v $                                              *
!     Revision 1.2  2003/10/02 07:56:22  per                           *
!     *** empty log message ***                                        *
!                                                                      *
!     Revision 1.1.1.1  2003/01/04 21:45:39  georgio                   *
!                                                                      *
!***********************************************************************
      IMPLICIT NONE
      LOGICAL          ldown              ! .TRUE. then Big ---> Small
      INTEGER          n, indx(n)
      DOUBLE PRECISION a(n)
      INTEGER          i, j, ipos, jpos, jhere
      DOUBLE PRECISION aimx
!
!     Initialize the index array
      DO i = 1, n
         indx(i) = i
      ENDDO
      IF (ldown) THEN
         DO i = 1, n
            ipos = indx(i)
            aimx = a(ipos)
            jhere = i
            DO j = i+1, n
               jpos = indx(j)
               IF(a(jpos) .GT. aimx) THEN
                  aimx = a(jpos)
                  jhere = j
               ENDIF
            ENDDO
            indx(i) = indx(jhere)
            indx(jhere) = ipos
         ENDDO
      ELSE
         DO i = 1, n
            ipos = indx(i)
            aimx = a(ipos)
            jhere = i
            DO j = i+1, n
               jpos = indx(j)
               IF(a(jpos) .LT. aimx) THEN
                  aimx = a(jpos)
                  jhere = j
               ENDIF
            ENDDO
            indx(i) = indx(jhere)
            indx(jhere) = ipos
         ENDDO
      ENDIF
      RETURN
      END SUBROUTINE
!
!***********************************************************************
!                                                                      *
      SUBROUTINE LDLBL
!                                                                      *
!     Open, check and load data from the  .lsj.lbl   file of the       *
!     inital state.                                                    *
!                                                                      *
!     Calls:                                                           *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                                  May 2011   *
!                                                                      *
!***********************************************************************
!
      IMPLICIT DOUBLEPRECISION (A-H, O-Z)
      INTEGER, PARAMETER :: ndim = 20000          ! max number of states
!
      CHARACTER*1 Lev_par(ndim)
      CHARACTER*4 Lev_J(ndim)
      CHARACTER*15 RECORD
      CHARACTER*64 string_CSF(ndim)
!
      INTEGER IOS, ITEST, Lev_POS(ndim), ICount, IMaxCount
      REAL WEIGHTS
      DOUBLE PRECISION RLev_ENER(ndim)
!
      COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF,       &
                      IMaxCount
!
      READ (31,'(1A15)',IOSTAT = IOS) RECORD
      ICount = 0
      IF (IOS .NE. 0) GO TO 1
      ICount = 1
      READ (31,'(1X,I2,1X,A4,5X,A1,8X,F16.9)',IOSTAT = IOS)    &
        Lev_Pos(ICount),Lev_J(ICount),Lev_Par(ICount),         &
        RLev_ENER(ICount)
      IF (IOS .NE. 0) GO TO 1
!
      READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF(ICount)
!
    2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST
      IF (IOS .NE. 0) GO TO 1
      IF (ITEST .EQ. 0) GO TO 2
      BACKSPACE 31
      ICount = ICount + 1
      READ (31,'(1X,I2,1X,A4,5X,A1,8X,F16.9)',IOSTAT = IOS)   &
        Lev_Pos(ICount),Lev_J(ICount),Lev_Par(ICount),        &
        RLev_ENER(ICount)
      IF (IOS .NE. 0) GO TO 1
      READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF(ICount)
      GO TO 2
    1 CONTINUE
      IMaxCount = ICount + IMaxCount
      RETURN
      END SUBROUTINE

!*****************************************************************

      subroutine latexconvert(labelstring,latexstring)

! This subroutine converts a label string to latex
! It is basically the same routine as in renergytable.f90
! Per Jonssson, Malmo University, November 2014

      implicit none
      integer :: i,j,k,l,ncase
      character(len=64) :: labelstring, dummystring, latexstring
      character(len=1) :: char1, char2, char3

      do i = 1,61

!  Replace (n) with ^n

         if ((labelstring(i:i).eq.'(').and.     &
            (labelstring(i+2:i+2).eq.')')) then
            labelstring(i:i) = '^'
            labelstring(i+2:i+2) = ' '
         end if
      end do

      do i = 1,61

!  Replace . with \,

         if (labelstring(i:i).eq.'.') then
            dummystring = labelstring
            labelstring(1:i-1) = dummystring(1:i-1)
            labelstring(i:i) = '\'
            labelstring(i+1:i+1) = ','
            labelstring(i+2:64) = dummystring(i+1:62)
         end if
      end do

      do i = 1,61

!  Replace _ with ~

         if (labelstring(i:i).eq.'_') labelstring(i:i) = '~'
      end do

!  If integer1 and S, P, D, F, G, H, I, K, L, M, N and integer2 replace with (^integer1_integer2S), (^integer1_integer2P), etc

      do l = 1,15
         ncase = 0
         do i = 1,61
            do j = 48,57
               do k = 48,57
                  char1 = labelstring(i:i)
                  char2 = labelstring(i+1:i+1)
                  char3 = labelstring(i+2:i+2)
                  if ((ichar(char1).eq.j).and.(ichar(char3).eq.k).and.  &
                     ((char2.ne.'~').and.(char2.ne.' ').and.            &
                     (char2.ne.'_'))) then
                     dummystring = labelstring
                     labelstring(1:i-1) = dummystring(1:i-1)
                     labelstring(i:i+6) =                               &
                          '(^'//char1//'_'//char3//char2//')'
                     labelstring(i+7:64) = dummystring(i+3:60)
                     ncase = ncase + 1
                  end if
               end do
            end do
            if (ncase.eq.1) exit
         end do

      end do

!  If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc

      do i = 1,61
!
         if (labelstring(i:i).eq.'~') then
            dummystring = labelstring
            labelstring(1:i) = dummystring(1:i)
            labelstring(i+1:i+1) = '^'
            labelstring(i+2:64) = dummystring(i+1:62)
         end if
      end do

      latexstring = trim(labelstring)

      return
      end subroutine

      END  PROGRAM


      SUBROUTINE dmoex(buf,lbuf,ibuf,scr,lscr,iscr)
!-------------------------------------------------------------------------------
!       DMOEX is the execution phase of the sioseis process DMO. DMOEX is a single
!  trace process that applies the phase shift to produce the DMO ellipse. Input data
!  must be in the FK domain (i.e. must have been through process TX2FK).
!
!       DMOEX  is called once for each input k domain complex frequency trace.
!  The wavenumbers of the input traces are from 0 to +k Nyquist (The negative
!  wavenumbers are not needed since they can be inferred from the positive
!  ones). The frequencies (OMEGA) of the input trace are from -Nyq -> 0 -> +Nyq.
C
C      DMOEX calculates the frequency (OMEGA) and wavenumber phase shift for each trace
C  by applying the phase factor developed by Liner (SEE GEOPHYSICS, 1990). PROCESS uses
!  only rect coordinates for f-k.

!
! Inputs:
!    BUF - The complex frequency trace to be DMOed
!   IBUF - The integer*2 equivalent of buf. Used to pass trace header info
!   LBUF - The integer*4 equivalent of buf. Used to pass trace header info
!   SCR/ISCR/LSCR/ - Scratch array and its integer equivalents.
!
! Outputs:
!    BUF - contains the migrated trace.
!
! Called from : CONTRO
!
! Externals :
!  PODISC, RDDISC    : Disk i/o routines
!                               INCLUE FILES

!-------------------------------------------------------------------------------

!*GMK THESE ARE THE INCLUDE FILE WHICH HAVE BEEN PASTED INTO THE EXECUTABLE CODE
!*    MANY OF THESE VARIABLES ARE NOT USED FOR DMO BUT I WONT GO CRAZY AND CHOP
!     OUT THE UNNECESSARY ONES - JUST INCASE I NEED THEM LATER!
! INCLUDE FILES
!.. Include file defining constants of use globally throughout SIOSEIS
!
! Modified 11/11/88     added DATINAP
! 8 Apr 09 - Use common numdat rather than segy header word ISAMPPTR
! Define the sizes of some Large common blocks

      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512x512
! parameter definitions for the stop signal istop
      integer STOPNOTR, STOPTR, NOSTOP
      parameter (STOPNOTR  = -1)                                        ! last call but no trace passed
      parameter (STOPTR    =  1)                                        ! last call and a trace passed
      parameter (NOSTOP    =  0)                                        ! normal call to the routine
!
! parameter for AP
      integer CLEARAP, USEAP, NOAP
      integer DATINAP
      parameter (USEAP    = 1)                                          ! There is an AP available
      parameter (NOAP     = 0)                                          ! No AP available
      parameter (CLEARAP  = 0)                                          ! Get data out of AP simulator
      parameter (DATINAP   = 1)                                         ! Data is in the AP
! This include file include all (?) of the parameters needed to define SIOSEIS
! I/O routines. In particular it defines positions of objects in the SEGY
! headers & constants for these values
!
! EBCDIC HEADER
! Declare Header lengths. These are the length of the EXTERNAL disk image in
! host words.
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
!
! BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
!
!  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
!
!..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
!
!.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
!
! TRACE HEADER
!.. Declare header length on external disk files. Internal length is given by
! Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
!
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
!
!.. Define Constants for Trace Header
!
!.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
!
!.. Define constants for use with the DISKIO subroutines getfil, frefil,
! podisc
! GETFIL constants
      integer    CREATTMP, CREATNEW
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
! FREFIL constants
      integer    RLDLCLS
      parameter (RLDLCLS = 3)
! PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
! Include file TXFK.INC
! include file for the sioseis 2D FFT and fk migration routines
!
!
! Parameters for coord type
      integer CDRECT, CDPOLAR, CDPOLARU
      parameter ( CDRECT   = 1)
      parameter ( CDPOLAR  = 2)
      parameter ( CDPOLARU = 3)
!
! parameters for Windows
      integer BoxCar
      parameter (BoxCar = 5)
! PROGRAM
      Parameter (NSCLRS = 7)
      Parameter (PI = 3.141592654)

C
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap,
     *               idecim
      common /READT/ilun,numhdr,numdat,iunhdr,ireelm,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc
      COMMON /dmocom/ idmounit, ndmolists, ndmowrds
      common /TXFKE/ txinit, fkinit, txed, fked, txunit,
     $               ltxunt1, ltxunt2, lfkunt1, lfkunt2,
     $               ohdrtxfk, tmptxhdr, txprestk, ntx2fk, nfk2tx, range
      common /APMEM/ a(SZAPMEM)
C
      dimension lbuf(1),buf(1), scr(1),lscr(1)
      integer*2 ibuf(1),iscr(1)
      integer   txsius
      integer   LocCoord
      logical   first
      save
C
      dimension params1(5), lparams1(5)
      equivalence (params1(1),lparams1(1))

      data first /.true./, hold /-1.0/, zerotol /0.00001/

!**************************************************************************************
!                                  PROCESS DMOEX
!**************************************************************************************
C
!*GMK Hopefully resets wavenumk when new offset panel is processed

      if (first) then                                                   ! DMO Initialization
        first = .false.

!*GMK Checks logstretch and reads appropriate disk file
        CALL podisc( idmounit, 1, 0 )
        CALL rddisc( idmounit, params1, ndmowrds, istat )
          ifiltype  = lparams1(1)
          dx        = params1(2)
          lprint    = lparams1(3)
          rdtl      = params1(4)
          roffset   = params1(5)
!       write(*,*) 'ifiltype;', ifiltype,'dx:', dx,'lprint:', lprint,
!     &'rtdl:', rdtl, 'ndmowrds:', ndmowrds, 'idmounit:', idmounit,
!     &'offset: ', roffset
!
!*GMK Checks to see if coordinates are rect. polar or non-FK
        if (idtype.eq.IDFKRCT) then
           LocCoord = CDRECT
        else if ((idtype.eq.IDFKPLR).OR.(idtype.eq.IDFKPLRU)) then
           LocCoord = CDPOLAR
               print *, ' *** DMO Error *** ',
     *           ' PROCESS DMO dose not accept data
     *in  POLAR COORINATES.'
               STOP
             else
               print *, ' *** DMO Error *** ',
     *           ' The input data is not in the FK domain.'
               STOP
        endif

!..                       Read the time delay/sample interval from READT common
!*GMK   Imtialize various f-k parametrs
        if (roffset .ne. 999999.0) then
           hosr = roffset/2.0
        else
           hosr = range / 2.0
        endif
        txsius = itxsi                                                  ! t-x sample interval in us
        delay  = itxdel/1000.                                           ! & time delay in secs.
        nx     = 2* (nfktrc-1)                                          ! Calcalate no. of output traces
        dt     = FLOAT(txsius)/1.0E6                                    ! Delta t
        dk     = 2.*pi/(float(nx)*dx)                                   ! Delta k (distance between wavenumbers)
!        nw     = ibuf(ISAMPPTR)/2                                       ! The number of frequencies
        nw = numdat / 2
        dw     = 2.*pi/(float(nw)*dt)                                   ! Delta w (distance between frequencies)
!        nwrds  = ibuf(ISAMPPTR)                                         ! No. of 32 bit words in the complex trace
        nwrds = numdat
        nt     = nwrds / 2                                              ! No. of time samples
        realk  = 0.                                                     ! Wavenumber of the initial input trace

        wnyqneg = (-2.0*pi) * ( 1.0/(2.0*dt) )
        wavenumk = realk
        numleft = nfktrc

        if ( IAND(lprint,1).ne.0) then
          print *,'EXECUTE DMO'
          print *,'Number of fk traces:', nfktrc, 'Output traces:', nx
          print *,'Delta T:', dt,' delta k:', dk,'Delta w:', dw
          print *,'No of w (nw):', nw,' No of time samps (nt):', nt
          print *,'Number wrds:', nwrds, 'tx samp int:', txsius
          print *,'half-offset:', hosr, 'Delay: ', delay
          print *,'in ap', in
        endif

      endif

!*GMK What type of filter do you want ?
       if (ifiltype .eq. 0 .or. ifiltype .eq. 999) then
          goto 30
       else
           print*, 'ifiltype: ', ifiltype, ' not supported yet'
          goto 40
       endif

!***********************                                ***********************
*                     Loop over Wavenumer for each FK Trace
!***********************                                ***********************
!*GMK Start at k=0, and w = -nyquist to +nyquist-dw (padded to power of 2**n (even) whereas -nqy to nyq (odd)
!*    thus +nyquist sample is omitted
!
30     continue

C*GMK If half-offset equal to zero, skip phase shift...already at zero-offset
       if (hosr .eq. 0.0) then
          if (first) print*, 'Zero-offset data, no phase shift applied'
          goto 40
       endif

!*GMK  loop over complex trace samples
          Do 20 j = 1, nwrds,  2
             wfreq = wnyqneg + float( (j+1)/2 - 1)*dw
!*GMK  Break phase shift into real and imaginary parts (preal pimag)

!*     Stationary point ys --> 0 as ky --> 0 expand (1+e)**.5 for small e
             if (wavenumk .eq. 0.) then
               ys = 0.
             else
               if (abs(wfreq).lt.zerotol) then
                  ys = -1.0*hosr
               else
                 subys = wfreq/(2.0*wavenumk)
                 ys =  subys * (1.0  - (1.0 + (hosr**2/subys**2) )**0.5)
               endif
             endif
             betas = ys/hosr

!*GMK  If wfreq is equal to zero, don't take log (0), expand later
             if ( abs(wfreq).gt.zerotol) then
                 deltas = 0.5*log(1.0-betas**2)
             endif

             denom = (1.0+betas**2)**0.5

!*GMK  If wfreq is equal to zero, the phase term goes to zero, although it asymptotes
!      to +/- wavenumk*ys in the positive or negative limit (THANKS AJH)

             if (abs(wfreq).gt.zerotol) then
                aphase = wfreq*deltas-wavenumk*ys
             else
                aphase = 0.0
             endif

!*GMK Take the real and imaginary parts of the phase term (complex conjugate
!* due to fk sign convention e(-iwt) --> forward e(+iwt) --> inverse in sioseis
             preal = cos(aphase)/denom
             pimag = -1.0*sin(aphase)/denom

!*GMK     Is data in AP
!*        Either way, multiply the complex phase term * complex trace and not screw
!*        up like I did (GMK)
          if (in.eq.0) then
            tempbj = buf(j+numhdr)*preal -  pimag*buf(j+numhdr+1)
            tempbj1 = buf(j+1+numhdr)*preal + buf(j+numhdr)*pimag
            buf(j+numhdr) = tempbj
            buf(j+numhdr+1) = tempbj1
          else
            tempaj  = a(j)*preal-pimag*a(j+1)
            tempaj1 = a(j+1)*preal+a(j)*pimag
            a(j) = tempaj
            a(j+1) = tempaj1
          endif
20        continue

!*GMK     SAVE saves wavenumk and it is advanced to next wavenumber trace if it exists
          wavenumk  = wavenumk + dk
40    continue

!*GMK Count number of traces for a given offset panel until done
!*    Reset first to .true. which allows new offset to be read correctly
      numleft = numleft - 1
      if (numleft.eq.0) then
         first = .true.
      endif

      return
      end


	INTEGER FUNCTION NVXSAE  ( xlin, xele, xdum, xlat, ylon, zdum  )
C************************************************************************
C* NVXSAE								*
C*									*
C* This subroutine calls the routine which converts image coordinates	*
C* (line, element) to earth coordinates (lat, lon) for MCIDAS		*
C* projections								*
C*									*
C* INTEGER NVXSAE  ( XLIN, XELE, XDUM, XLAT, YLON, ZDUM  )		*
C*									*
C* Input parameters:							*
C*	XLIN		REAL		Image line			*
C*	XELE		REAL		Image element			*
C*	XDUM		REAL		Dummy arg			*
C*									*
C* Output Parameters:							*
C*	XLAT		REAL		Returned lat			*
C*	YLON		REAL		Returned lon			*
C*	ZDUM		REAL		Returned dummy			*
C*									*
C* Return value:							*
C*			 0		OK				*
C*			-1		Unable to navigate point	*
C**									*
C* Log:									*
C* J. Cowie/COMET	 1/95	Added to allow GVAR nav			*
C* J. Cowie/COMET	12/00	Added RADR projection type		*
C* S. Chiswell/Unidata	 2/02	Added MSAT, MOLL, GMSX projection type	*
C* S. Chiswell/Unidata	 8/06	Added MSG				*
C* M. James/Unidata	10/14	Added RECT				*
C* M. James/Unidata	02/18	Added ABIN				*
C* S. Guan/NCEP          2/18   Added GOE4                              *
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'SATDEF.CMN'
C
	INTEGER		GOSSAE, GVRSAE, RDRSAE, MSATSAE, GMSXSAE,
     +			MOLLSAE, MSGSAE, GOSSAE4, RECTSAE, ABINSAE
C------------------------------------------------------------------------
C
C*	Call appropriate routine
C
        IF ( nvtypa .eq. 'MCGOE4' ) THEN
           iret = GOSSAE4 ( xlin, xele, xdum, xlat, ylon, zdum  )
	ELSE IF ( nvtypa .eq. 'MCGOES' ) THEN
	   iret = GOSSAE ( xlin, xele, xdum, xlat, ylon, zdum  )
	ELSE IF ( nvtypa .eq. 'MCGVAR' ) THEN
	   iret = GVRSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCRADR' ) THEN
	   iret = RDRSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCMSAT' ) THEN
	   iret = MSATSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCMSG' ) THEN
	   iret = MSGSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCGMSX' ) THEN
	   iret = GMSXSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCMOLL' ) THEN
	   iret = MOLLSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCRECT' ) THEN
	   iret = RECTSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE IF ( nvtypa .eq. 'MCABIN' ) THEN
	   iret = ABINSAE ( xlin, xele, xdum, xlat, ylon, zdum )
	ELSE
	   iret = -1
	END IF
C
	NVXSAE = iret
C
	RETURN
	END


      program  main
      implicit none

! **********************************************************************
! **********************************************************************
! ****                                                              ****
! ****        Program to create bkg_eta and bkg_sfc files for       ****
! ****             Analysis from GCM HISTORY output                 ****
! ****                                                              ****
! ****  HISTORY:                                                    ****
! ****  16Dec2004  Takacs   Changed thv to th for GEOS-5 GCM        ****
! ****  10Nov2004  Todling  Added handle for existing hdf files     ****
! ****  20Apr2005  Takacs   Read hdf files from GCM HISTORY         ****
! ****  29Apr2005  Todling  Using set_eta from hermes; this sets ks ****
! ****                        and pint properly.                    ****
! ****  23Jun2005  Todling  Added freq/changed timinc def(asyn-omf) ****
! **********************************************************************
! **********************************************************************

      character*80  tmpsfc, tmpeta
      character*80  bkgsfc, bkgeta
      character*80  expid
      character*10  str

      integer nymd,nhms
      integer im,jm,lm
      integer iprec,precision
      real    undef,rgas,rvap,eps,ptop,kappa

! hdf variables
! -------------
      character*256  title
      character*256  source
      character*256  contact
      character*256  levunits
      character*256, allocatable ::  vname(:)
      character*256, allocatable :: vtitle(:)
      character*256, allocatable :: vunits(:)

      real,    allocatable ::   vars(:,:,:)
      real,    allocatable ::    lat(:)
      real,    allocatable ::    lon(:)
      real,    allocatable ::    lev(:)
      real,    allocatable :: vrange(:,:)
      real,    allocatable :: prange(:,:)
      integer, allocatable :: yymmdd(:)
      integer, allocatable :: hhmmss(:)
      integer, allocatable ::  kmvar(:)
      integer, allocatable ::    loc(:)

      character*120, allocatable :: arg(:)
      character*8    date
      character*2    hour
      integer n,nargs,iargc,i,j,L
      integer id,rc,timinc,nmax,kbeg,kend,freq
      integer ntime,nvars,ngatts

! **********************************************************************
! ****                      Initialize Filenames                    ****
! **********************************************************************

       expid = 'geos5'
      bkgeta = 'NONE'
      bkgsfc = 'NONE'
   precision = 1  ! default: 64-bit output
      freq   = 6  ! default: frequency of bkg is 6-hrs

         nargs = iargc()
      if(nargs==0) call usage()
      allocate ( arg(nargs) )
      do n=1,nargs
      call getarg(n,arg(n))
      enddo
      do n=1,nargs
             if( trim(arg(n)).eq.'-h'        ) call usage()
             if( trim(arg(n)).eq.'-help'     ) call usage()
             if( trim(arg(n)).eq.'-H'        ) call usage()
             if( trim(arg(n)).eq.'-Help'     ) call usage()
             if( trim(arg(n)).eq.'-expid'    ) then
                                   expid   = trim(arg(n+1))
             endif
             if( trim(arg(n)).eq.'-tmpeta'   ) then
                                   tmpeta  = trim(arg(n+1))
             endif
             if( trim(arg(n)).eq.'-tmpsfc'   ) then
                                   tmpsfc  = trim(arg(n+1))
             endif
             if( trim(arg(n)).eq.'-bkgeta'   ) then
                                   bkgeta  = trim(arg(n+1))
             endif
             if( trim(arg(n)).eq.'-bkgsfc'   ) then
                                   bkgsfc  = trim(arg(n+1))
             endif
             if( trim(arg(n)).eq.'-prec'    ) then
                                   str     = trim(arg(n+1))
                                   read(str,*) iprec
                                   if(iprec==32)precision=0
                                   if(iprec==64)precision=1
             endif
             if( trim(arg(n)).eq.'-freq'    ) then
                                   str     = trim(arg(n+1))
                                   read(str,*) freq
             endif
      enddo
                                  print *
                                  print *, '                    expid: ',trim(expid)
                                  print *, 'INPUT    bkg.eta filename: ',trim(tmpeta)
                                  print *, 'INPUT    bkg.sfc filename: ',trim(tmpsfc)
      if( trim(bkgeta) /= 'NONE') print *, 'OUTPUT   bkg.eta filename: ',trim(bkgeta)
      if( trim(bkgsfc) /= 'NONE') print *, 'OUTPUT   bkg.sfc filename: ',trim(bkgsfc)
                                  print *

! **********************************************************************
! ****                       Read bkg eta file                      ****
! **********************************************************************

      call gfio_open       ( trim(tmpeta),1,id,rc )
      call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc )

      allocate ( lon(im) )
      allocate ( lat(jm) )
      allocate ( lev(lm) )
      allocate ( yymmdd(ntime) )
      allocate ( hhmmss(ntime) )
      allocate (  vname(nvars) )
      allocate ( vtitle(nvars) )
      allocate ( vunits(nvars) )
      allocate (  kmvar(nvars) )
      allocate ( vrange(2,nvars) )
      allocate ( prange(2,nvars) )

      timinc = 0
      call gfio_inquire ( id,im,jm,lm,ntime,nvars,      &
                          title,source,contact,undef,   &
                          lon,lat,lev,levunits,         &
                          yymmdd,hhmmss,timinc,         &
                          vname,vtitle,vunits,kmvar,    &
                          vrange,prange,rc )

      if( timinc == 0 ) timinc = freq * 10000
      if( timinc == 0 ) timinc = 06   * 10000

      allocate ( loc(nvars) )
      loc(1) = 1
      do n=2,nvars
      loc(n) = loc(n-1)+max(1,kmvar(n-1))
      enddo
      nmax = loc(nvars)+max(1,kmvar(nvars))-1

      allocate( vars(im,jm,nmax) )

      print *
      print *, '             Reading File: ',trim(tmpeta)
      print *, '   Number of Time Periods: ',ntime,'  TimeInc: ',timinc

      nymd = yymmdd(ntime)
      nhms = hhmmss(ntime)

      print *, '               resolution: ',im,jm,lm
      print *, '                     date: ',nymd,nhms
      print *

      do n=1,nvars
         if( kmvar(n).eq.0 ) then
             kbeg = 0
             kend = 1
         else
             kbeg = 1
             kend = kmvar(n)
         endif
         call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,kbeg,kend,vars(1,1,loc(n)),rc )
         if( rc.eq.0 ) then
             print *, '         Reading Variable: ',trim(vname(n))
         else
             print *, '  Failed Reading Variable: ',trim(vname(n))
             stop
         endif
         call hflip ( vars(1,1,loc(n)),im,jm,kend )
      enddo

      call gfio_close ( id,rc )

! **********************************************************************
! ****                 Write bkg.eta File for Analysis              ****
! **********************************************************************

      write(date,'(i8.8)') nymd
      write(hour,'(i2.2)') nhms/10000

      if( trim(bkgeta) == 'NONE') bkgeta = trim(expid) // '.bkg.eta.' // date // '_' // hour // 'z.nc4'
      print *

      call write_hdf ( bkgeta,nymd,nhms,im,jm,lm,loc,nmax,undef,timinc,     &
                       nvars,vname,vtitle,vunits,kmvar,vrange,prange, vars, &
                       precision )

      deallocate ( lon )
      deallocate ( lat )
      deallocate ( lev )
      deallocate ( yymmdd )
      deallocate ( hhmmss )
      deallocate (  vname )
      deallocate ( vtitle )
      deallocate ( vunits )
      deallocate (  kmvar )
      deallocate ( vrange )
      deallocate ( prange )

      deallocate ( loc  )
      deallocate ( vars )

! **********************************************************************
! ****                       Read bkg sfc file                      ****
! **********************************************************************

      call gfio_open       ( trim(tmpsfc),1,id,rc )
      call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc )

      allocate ( lon(im) )
      allocate ( lat(jm) )
      allocate ( lev(lm) )
      allocate ( yymmdd(ntime) )
      allocate ( hhmmss(ntime) )
      allocate (  vname(nvars) )
      allocate ( vtitle(nvars) )
      allocate ( vunits(nvars) )
      allocate (  kmvar(nvars) )
      allocate ( vrange(2,nvars) )
      allocate ( prange(2,nvars) )

      timinc = 0
      call gfio_inquire ( id,im,jm,lm,ntime,nvars,      &
                          title,source,contact,undef,   &
                          lon,lat,lev,levunits,         &
                          yymmdd,hhmmss,timinc,         &
                          vname,vtitle,vunits,kmvar,    &
                          vrange,prange,rc )

      if( timinc == 0 ) timinc = 060000

      allocate ( loc(nvars) )
      loc(1) = 1
      do n=2,nvars
      loc(n) = loc(n-1)+max(1,kmvar(n-1))
      enddo
      nmax = loc(nvars)+max(1,kmvar(nvars))-1

      allocate( vars(im,jm,nmax) )

      print *
      print *, '             Reading File: ',trim(tmpsfc)
      print *, '   Number of Time Periods: ',ntime,'  TimeInc: ',timinc

      nymd = yymmdd(ntime)
      nhms = hhmmss(ntime)

      print *, '               resolution: ',im,jm,lm
      print *, '                     date: ',nymd,nhms
      print *

      do n=1,nvars
         if( kmvar(n).eq.0 ) then
             kbeg = 0
             kend = 1
         else
             kbeg = 1
             kend = kmvar(n)
         endif
         call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,kbeg,kend,vars(1,1,loc(n)),rc )
         if( rc.eq.0 ) then
             print *, '         Reading Variable: ',trim(vname(n))
         else
             print *, '  Failed Reading Variable: ',trim(vname(n))
             stop
         endif
         call hflip ( vars(1,1,loc(n)),im,jm,kend )
      enddo

      call gfio_close ( id,rc )

! **********************************************************************
! ****                 Write bkg.sfc File for Analysis              ****
! **********************************************************************

      write(date,'(i8.8)') nymd
      write(hour,'(i2.2)') nhms/10000

      if( trim(bkgsfc) == 'NONE') bkgsfc = trim(expid) // '.bkg.sfc.' // date // '_' // hour // 'z.nc4'
      print *

      call write_hdf ( bkgsfc,nymd,nhms,im,jm,lm,loc,nmax,undef,timinc,    &
                       nvars,vname,vtitle,vunits,kmvar,vrange,prange, vars,&
                       precision )

      stop
      end

      subroutine write_hdf ( filename,nymd,nhms,im,jm,lm,loc,nmax,undef,timinc,   &
                             nvars,vname,vtitle,vunits,kmvar,vrange,prange, vars, &
                             precision )
      use m_set_eta
      implicit  none
      integer   im,jm,lm,nymd,nhms,nvars,nmax
      real     vars(im,jm,nmax)

      integer    loc(nvars)
      integer  kmvar(nvars)
      real  vrange(2,nvars)
      real  prange(2,nvars)

      character*256  levunits
      character*256  title
      character*256  source
      character*256  contact
      character*256   vname(nvars)
      character*256  vtitle(nvars)
      character*256  vunits(nvars)

      real lats(jm)
      real lons(im)

      real  ptop,dlon,dlat,pref,undef,pint
      integer i,j,L,n,timinc,rc,ks,kbeg,kend
      character*80 filename
      character*3  ch3
      integer  fid,precision,err
      logical  file_exists
      integer, parameter :: READ_WRITE = 0

      real, allocatable ::   ak(:)
      real, allocatable ::   bk(:)
      real, allocatable :: levs(:)
      real  dpref
            dpref(L) = ( ak(L+1)-ak(L) ) +  ( bk(L+1)-bk(L) ) * 98400.0

! String and vars settings
! ------------------------
      title    = 'GEOS5 Dynamics State Vector (Hybrid Coordinates)'
      source   = 'Goddard Modeling and Assimilation Office, NASA/GSFC'
      contact  = 'data@gmao.gsfc.nasa.gov'
      levunits = 'hPa'

! Compute grid
! ------------
      dlon = 360.0/ im
      dlat = 180.0/(jm-1)

      do j=1,jm
      lats(j) = -90.0 + (j-1)*dlat
      enddo
      do i=1,im
      lons(i) =   0.0 + (i-1)*dlon
      enddo

      if( lm.ne.0 ) then
          allocate ( levs(lm) )
          allocate ( ak(lm+1) )
          allocate ( bk(lm+1) )
          call set_eta ( lm,ks,ptop,pint,ak,bk )
          levs(1) = ptop + 0.5 * dpref(1)
          do L = 2, lm
          levs(L) = levs(L-1) + 0.5 * ( dpref(L-1) + dpref(L) )
          enddo
          levs(1:lm) = levs(1:lm) / 100.0
      else
          allocate ( levs(1) )
                     levs(1) = 1
      endif

! Check whether file exists
! -------------------------
      inquire ( file=trim(filename), exist=file_exists )

! Create/Open GFIO file
! ---------------------
      if ( file_exists ) then
           print *, 'Open existing ',trim(filename)
           call GFIO_Open ( filename, READ_WRITE, fid, err )
      else
           print *, 'Creating ',trim(filename)
           call GFIO_Create ( filename, title, source, contact, undef, &
                              im, jm, lm, lons, lats, levs, levunits,  &
                              nymd, nhms, timinc,                      &
                              nvars, vname, vtitle, vunits, kmvar,     &
                              vrange, prange, precision,               &
                              fid, rc )
      endif

! Write GFIO data
! ---------------
      do n=1,nvars
         if( kmvar(n).eq.0 ) then
             kbeg = 0
             kend = 1
         else
             kbeg = 1
             kend = kmvar(n)
         endif
         call gfio_putvar ( fid,vname(n),nymd,nhms,im,jm,kbeg,kend,vars(1,1,loc(n)),rc )
         if( rc.eq.0 ) then
             print *, '         Writing Variable: ',trim(vname(n))
         else
             print *, '  Failed Writing Variable: ',trim(vname(n))
             stop
         endif
      enddo

! Write GFIO global attributes
! ----------------------------
      if( lm.ne.0 ) then
          call GFIO_PutIntAtt  ( fid,'nstep',  1,ks   ,0        ,rc )
          call GFIO_PutRealAtt ( fid,'ptop',   1,ptop ,precision,rc )
          call GFIO_PutRealAtt ( fid,'pint',   1,pint ,precision,rc )
          call GFIO_PutIntAtt  ( fid,'ks',     1,ks   ,0        ,rc )
          call GFIO_PutRealAtt ( fid,'ak',  lm+1,ak   ,precision,rc )
          call GFIO_PutRealAtt ( fid,'bk',  lm+1,bk   ,precision,rc )
      endif

      call gfio_close ( fid,rc )
      return
      end

      subroutine hflip ( q,im,jm,lm )
      implicit none
      integer  im,jm,lm,i,j,L
      real   q(im,jm,lm),dum(im)
      do L=1,lm
      do j=1,jm
      do i=1,im/2
         dum(i) = q(i+im/2,j,L)
         dum(i+im/2) = q(i,j,L)
      enddo
         q(:,j,L) = dum(:)
      enddo
      enddo
      return
      end

      subroutine usage()
      print *, "Usage:  "
      print *
      print *, " dyn52dyn.x   -expid    expid"
      print *, "             -tmpeta   tmpeta_fname "
      print *, "             -tmpsfc   tmpsfc_fname "
      print *, "            [-bkgeta   bkgeta_fname]"
      print *, "            [-bkgsfc   bkgsfc_fname]"
      print *, "            [-prec     precision   ]"
      print *
      print *, "where:"
      print *, "-----"
      print *, "  -expid          expid:  Experiment  ID"
      print *, "  -tmpeta  tmpeta_fname:  Filename of Temporary GCM bkg.eta file"
      print *, "  -tmpsfc  tmpsfc_fname:  Filename of Temporary GCM bkg.sfc file"
      print *
      print *, "  -bkgeta  bkgeta_fname:  Filename of Final GCM bkg.eta file (optional)"
      print *, "  -bkgsfc  bkgsfc_fname:  Filename of Final GCM bkg.sfc file (optional)"
      print *
      print *, "  -prec    PREC           where PREC=32 or 64 for 32 or 64 bits output"
      print *, "  -freq    FREQ           specify frequency of background; default: 6 (hr)"
      print *
      call exit(7)
      end