c **********************************************************************
c This SOFTWARE  has been authored  by an employee   or employees of the
c University  of  California, operator    of the  Los   Alamos  National
c Laboratory  under Contract No. W-7405-ENG-36  with the U.S. Department
c of  Energy.   The U.S. Government  has  rights to use,  reproduce, and
c distribute this SOFTWARE.   The  public may copy,  prepare  derivative
c works and publicly display this SOFTWARE without charge, provided that
c this  Notice  and any statement  of  authorship are  reproduced on all
c copies.  Neither the Government nor the University makes any warranty,
c express or implied, or assumes any liability or responsibility for the
c use  of this SOFTWARE.  If SOFTWARE  is modified to produce derivative
c works, such  modified SOFTWARE should be clearly  marked, so as not to
c confuse it with the version available from LANL.
c
c It is expressly forbidden to distribute this code, in whole or in part,
c either as is or modified.
c **********************************************************************

c HISTORY:
c     v1: this does regular dimer search, always randomizing dimer direction
c     v2: allows initial dimer direction to be passed in, also returns it
c     v3: returns new basin in x1
c**********************************************************************
c meaning of imode variable:
c imode=1: do regular dimer search, redoing dimers that fail criteria
c imode=2: do not redo dimers that fail criteria, return instead, but do
c full dimer search
c imode=3: only minimize direction, returning with eig, do not move
c dimer
c**********************************************************************

      subroutine dimer_search(natom,nmove,idimerbail,emin,eminbar
     +    ,idimerdof,ndimerdof,rdimerdist,ndimercoord,idimeroverunder
     +    ,rdimerdisp,x1,x,xmin,xyzprev,energy,rdimer,ityp,taxes,ietype
     +    ,maxtyp,rcut,hyperratio,barrevev,ereverse,gfac,irotalign
     +    ,itermax,ierr,iranx,irandir,transcrit,itranscrit,gcritin
     +    ,dvcritin,drcritin,ipr,imode,ifundc,eig)

      use mod_mpi
      implicit real*8(a-h,o-z)
c      parameter(mxatom=10000,nneighmax=1500)
      include 'parameters.h'
      dimension ityp(natom)
      dimension rcut(maxtyp,maxtyp)
      dimension x1(3*natom),x(3*natom),xmin(3*natom),xyzprev(3*natom)
      dimension barrevev(nneighmax)

c x1 is original minimum, x is working saddle array, xmin is minimum
c again (maybe redundant?), xyzprev is previous minimum

      dimension grad(3*mxatom),rdimer(3*natom),xwork(3*mxatom),
     +    xwork2(3*mxatom)
      dimension F(3*natom),Fold(3*natom),F2(3*natom)
      dimension G(3*natom),Gold(3*natom),Gu(3*natom)
      dimension R(3*natom),Rold(3*natom),R2(3*natom)
      dimension dF(3*natom)
!      dimension dF(3*natom),Fp1(3*natom),Fp2(3*natom)
      dimension taxes(3)
      dimension icoord(mxatom)
      character*10 chri
      character*80 filnam ! uuuu unused

      common/callcom/ngradcall

      data itag/0/

      save

      nitermaxfail = 0
      nitermaxfailmax = 1

      ierr=0
      nredocount=0

      ev=27.21d0
c----------------------------------------------------------------------
c dimer parameters that may be passed later
      drdimer=0.0001d0
      drdimer=0.001d0
c      rcoordcrit=2.3d0      ! cutoff for coordination and neighbors of atoms
c      rranx=0.6d0           ! distance to displace atoms (+/- this number)
      rmaxmove=0.2d0         ! maximum distance allowed to move
      dR=0.001d0            ! finite difference translation step size
c----------------------------------------------------------------------
      rcoordcrit=rdimerdist
      rranx=rdimerdisp
      factdimer=10.0d0
      factdimer=1.0d0

      gcrit=gcritin*factdimer
      dvcrit=dvcritin*factdimer
      drcrit=drcritin*factdimer

      if(rank_f.eq.0)then
       if(ipr.ge.4) write(6,*) 'dimer_report: drdimer,rmaxmove,dR: ',
     x                         drdimer,rmaxmove,dR
      endif

 111  continue

      e100=0.0d0

      call flushtad(6)
      if (iranx.eq.1) then
         if (idimerdof.eq.2) then
            transcrittemp=rcoordcrit
            itranscrittemp=1
            call coordination(natom,x1,icoord,transcrittemp,taxes,rcut
     +          ,ityp,itranscrittemp,maxtyp)
         endif
         call dimer_ranx(natom,nmove,x1,x,ipr,idimerdof
     +       ,ndimerdof,ndimercoord,idimeroverunder,taxes,icoord
     +       ,rcoordcrit,rranx)
         if(rank_f.eq.0)then
           if (ipr.ge.4) write(6,*) 'dimer_search: randomized x'
         endif
      endif

      if (iranx.eq.2) then
         call dimer_ranx_hole(natom,nmove,x,xmin,xyzprev,ipr,idimerdof
     +       ,ndimerdof,ndimercoord,idimeroverunder,taxes,rranx
     +       ,transcrit,rcoordcrit)
         if((ipr.ge.4).and.(rank_f.eq.0))
     +       write(6,*) 'dimer_search: randomized x near hole'
         rdimermag=vecdot(rdimer,rdimer,3*natom)
         if((ipr.ge.4).and.(rank_f.eq.0))
     +       write(6,*) 'dimer_search: rdimermag: ',rdimermag
      endif

      if (iranx.eq.3) then
         do i=1,natom
            icoord(i)=0
         enddo
         iunit=25
         if(rank_f.eq.0)
     +       open(unit=iunit,file='dimer.activeatoms',status='old')
         if(rank_f.eq.0) read(iunit,*) nactive
         call MPI_BCAST(nactive,1,MPI_INTEGER,0,force_comm,ier)
         do i=1,nactive
            if(rank_f.eq.0) read(iunit,*) iactiveatom
            call MPI_BCAST(iactiveatom,1,MPI_INTEGER,0,force_comm,ier)
            icoord(iactiveatom)=1
         enddo
         if(rank_f.eq.0) close(unit=iunit)
         if(rank_f.eq.0)
     +       write(6,*) 'iranx.eq.3: read ',nactive,' active atoms'
         idimerdoftemp=2 ! based on atom number, not dof number
         idimeroverundertemp=0  ! over coordinated atoms
         ndimercoordtemp=0 ! coordination of 0 (use as flag rather than coordination)
         call dimer_ranx(natom,nmove,x1,x,ipr,idimerdoftemp
     +       ,ndimerdof,ndimercoordtemp,idimeroverundertemp,taxes,icoord
     +       ,rcoordcrit,rranx)
      endif

      itag=itag+1
      filnam='dimerinit.'//chri(itag)//'.dat'
      if (ipr.ge.10.or.(ipr.ge.10.and.iranx.eq.2))then
        call storefile(natom,x,x,ityp,taxes,filnam)
      endif
      if (irandir.eq.1) then
         call dimer_initialize(natom,nmove,x1,x,idimerdof,ndimerdof
     +       ,rdimer)
         if(rank_f.eq.0)then
          if (ipr.ge.4) write(6,*) 'dimer_search: randomized dimer'
         endif
      else
c     make sure that last elements are zero
         do i=3*nmove+1,3*natom
            rdimer(i)=0.0d0
         enddo
         call vecrenorm(rdimer,3*natom)
         if(rank_f.eq.0)then
          if(ipr.ge.4) write(6,*) 'dimer_search: using passed direction'
         endif
      endif

! Dimer convergence loop
      eprev=0.0d0
      ngradcallprev=ngradcall
      ngradcallorig=ngradcall
      icginit=1
      ngraddimer=0
      ngraddimerprev=ngradcall
      do i=1,itermax

! Dimer rotation
         call gcalc(natom,nmove,x,ityp,taxes,
     x       ietype,maxtyp,rcut,energy,grad,hyperratio)

!       Steepest descent rotation
c         call dimer_min_torque(natom,nmove,x,rdimer,drdimer,eig,ityp
c     +       ,taxes,ietype,maxtyp,rcut,energy,grad,hyperratio)
!       Quasi-Newton rotation
         call dimer_min_torque_2(imode,natom,nmove,x,rdimer,drdimer,eig
     +       ,ityp,taxes,ietype,maxtyp,rcut,energy,grad,hyperratio)

         if (imode.eq.3) return

! Steepest descent dimer translation
!         gdotdr=-vecdot(grad,rdimer,3*nmove)
!         call vecypax(grad,gdotdr,rdimer,3*nmove) ! zero grad along rdimer
!         gfactor=gdotdr/(gfac*(abs(eig)+0.05d0)) ! uphill move, tempered newt-raph-style along neg. curv
!         call vecypax(grad,gfactor,rdimer,3*nmove)
!         gmag=sqrt(vecdot(grad,grad,3*nmove))
!         dxmax=0.0d0
!         do j=1,nmove
!            dx=0.0d0
!            do k=1,3
!               xx=x((j-1)*3+k)
!               x((j-1)*3+k)=xx-gfac*grad((j-1)*3+k)
!               dx=dx+(x((j-1)*3+k)-xx)**2
!            enddo
!            dxmax=max(dxmax,sqrt(dx))
!         enddo

! Conjugate gradient dimer translation
         do j=nmove*3+1,natom*3
           rdimer(j)=0.0d0
         enddo
         call vecrenorm(rdimer,3*nmove)
         gmag=sqrt(vecdot(grad,grad,3*nmove))
         gdotdr=-vecdot(grad,rdimer,3*nmove)
         do j=1,3*natom
           R(j)=x(j)
           F(j)=-grad(j)
         enddo
         do j=nmove*3+1,natom*3
           F(j)=0.0d0
         enddo
         fdotdr=vecdot(F,rdimer,3*nmove)
         if(eig.lt.0) then
           do j=1,3*nmove
             F(j)=F(j)-rdimer(j)*fdotdr*2.0d0
           enddo
         else
            do j=1,3*natom
             F(j)=-rdimer(j)*fdotdr
           enddo
         endif
         if(icginit.eq.1) then
           icginit=0
!           write(6,*) 'dimer_search: CG Init'
           Gam=0
           do j=1,3*natom
             G(j)=F(j)
             Gold(j)=F(j)
             Fold(j)=F(j)
           enddo
         endif
         do j=nmove*3+1,natom*3
           G(j)=0.0d0
           Gu(j)=0.0d0
           Gold(j)=0.0d0
           Fold(j)=0.0d0
         enddo
         a1=abs(vecdot(F,Fold,3*nmove))
         a2=vecdot(Fold,Fold,3*nmove)
         if(a1.le.(0.5d0*a2)) then
           do j=1,3*nmove
             dF(j)=F(j)-Fold(j)
           enddo
           Gam=vecdot(F,dF,3*nmove)/a2
         else
!           write(6,*) 'dimer_search: Resetting CG in translation'
           Gam=0
         endif
!         write(6,*) 'dimer_search: a1 ',a1,' a2 ',a2,' Gam ',Gam
         do j=1,3*nmove
           G(j)=F(j)+Gold(j)*Gam
           Gu(j)=G(j)
         enddo
         call vecrenorm(Gu,3*nmove)
         do j=1,3*natom
           Fold(j)=F(j)
           Gold(j)=G(j)
           Rold(j)=R(j)
           R2(j)=R(j)+Gu(j)*dR
         enddo
         call gcalc(natom,nmove,R2,ityp,taxes,
     x       ietype,maxtyp,rcut,energy2,grad,hyperratio)
         do j=1,3*natom
           F2(j)=-grad(j)
         enddo
         do j=nmove*3+1,natom*3
           F2(j)=0.0d0
         enddo
         fdotdr=vecdot(F2,rdimer,3*nmove)
         if(eig.lt.0) then
           do j=1,3*nmove
             F2(j)=F2(j)-rdimer(j)*fdotdr*2.0d0
           enddo
         else
            do j=1,3*nmove
             F2(j)=-rdimer(j)*fdotdr
           enddo
         endif
         Frp1=vecdot(F,Gu,3*nmove)
         Frp2=vecdot(F2,Gu,3*nmove)
!         do j=1,3*nmove
!           Fp1(j)=Gu(j)*Frp1
!           Fp2(j)=Gu(j)*Frp2
!         enddo
         Frp=(Frp1+Frp2)/2d0
         CR=(Frp1-Frp2)/dR
!         write(6,*) 'dimer_search: CR ',CR,' Frp1 ',Frp1,' Frp2 ',Frp2
         if(CR.lt.0d0) then
           RdR=rMaxMove
!           write(6,*) 'dimer_search: CR<0, RdR = ',RdR
         else
           RdR=Frp/CR
!           write(6,*) 'dimer_search: CR>0, RdR = ',RdR
           if(abs(RdR).ge.rMaxMove) then
             RdR=sign(rMaxMove,RdR)
           else
             RdR=RdR+dR/2d0
           endif
         endif
!         write(6,*) 'dimer_search: Finally RdR = ',RdR
         do j=1,3*natom
           R(j)=R(j)+Gu(j)*RdR
           x(j)=R(j)
         enddo
         dxmax=0
         do j=1,nmove
            dx=0.0d0
            do k=1,3
               dx=dx+(R((j-1)*3+k)-Rold((j-1)*3+k))**2
            enddo
            dxmax=max(dxmax,sqrt(dx))
         enddo
!         write(6,*) 'dimer_search: dxmax ',dxmax,' CR ',CR,' RdR ',RdR
! Done dimer translation

         ngraddimer=ngraddimer+ngradcall-ngraddimerprev
         ngraddimerprev=ngradcall

         dv=abs(energy-eprev)
         eprev=energy

         if (i.eq.100) e100=energy

         if (mod(i-1,10).eq.0.and.ipr.ge.4) then
            ndelgrad=ngradcall-ngradcallprev
            ngradcallprev=ngradcall
            eratio=(energy-emin)*27.21d0/eminbar
            if(rank_f.eq.0) then
             write(6,62) i,energy*27.21d0,dv,dxmax,gmag,gdotdr,eig
     $          ,ndelgrad,ngraddimer,eratio,e100
            endif
c            write(6,*) 'dimer_debug: ',energy,emin,eminbar,energy-emin
c     +          ,(energy-emin)*27.21d0/eminbar
         endif

 62      format('dimer_search: ',i5,f12.5,1p3d12.4,0p2f12.5,i12,i12,
     +       0pf12.5,f12.5)
         if (dv.lt.dvcrit.and.dxmax.lt.drcrit.and.gmag.lt.gcrit) goto
     +       100

         if (abs(eig).lt.0.0001d0) then
            nzero=nzero+1
            if (nzero.gt.0) then
               if(rank_f.eq.0) then
                write(6,*) 'dimer_search: seem to be on zero-mode: ',eig
               endif
               if (imode.eq.2) then
                  ierr=10
                  if(rank_f.eq.0) then
                   write(6,*)'dimer_search: going to next reused saddle'
                  endif
                  return
               endif
               if(rank_f.eq.0) then
                write(6,*) 'dimer_search: redoing dimer'
               endif
               nzero=0
               nredocount=nredocount+1
               if (nredocount.gt.100) then
                  if(rank_f.eq.0) then
                   write(6,*) 'STOP: nredocount.gt.100 in dimer!'
                  endif
                  stop 'nredocount.gt.100 in dimer!'
               endif
               goto 111
            endif
         else
            nzero=0
         endif

         if (ngraddimer.gt.itermax) then
            nitermaxfail = nitermaxfail + 1
            if(rank_f.eq.0) then
             write(6,*) 'SpawnID ',spawnID
     +          ,' - dimer_search: ngraddimer.gt.itermax: '
     +          ,ngraddimer,itermax
            endif
            if (imode.eq.2) then
               ierr=10
               if(rank_f.eq.0) then
                 write(6,*) 'dimer_search: going to next reused saddle'
               endif
               return
            endif
            if (ipr.ge.2) then
               if(rank_f.eq.0) then
                write(6,61)'dimer_search: Search Did Not Converge: ',dv
     +             ,dxmax,gmag
               endif
               if (imode.eq.2) then
                  ierr=10
                  if(rank_f.eq.0) then
                   write(6,*)'dimer_search: going to next reused saddle'
                  endif
                  return
               endif
               if(nitermaxfail.lt.nitermaxfailmax)then
                if(rank_f.eq.0) write(6,*) 'dimer_search: redoing dimer'
               endif
            endif
            if(nitermaxfail.lt.nitermaxfailmax) goto 111
            ierr=10
            return
         endif

         if (idimerbail.eq.1) then ! stop dimer search if certain criteria are met
            if (i.gt.100.and.eig.gt.0.0d0) then
               if(rank_f.eq.0) write(6,*)
     +             'dimer_search: did 100 steps, eig still positive'
     +             ,' bailing on this search'
               if (imode.eq.2) then
                  ierr=10
                  if(rank_f.eq.0) write(6,*) 'dimer_search: returning'
                  return
               endif
               if(rank_f.eq.0) write(6,*) 'dimer_search: redoing dimer'
               goto 111
            endif
            ebar=(energy-emin)*27.21d0
            eratio=(energy-emin)*27.21d0/eminbar
            ebardif=ebar-eminbar
c            if (eig.lt.0.0d0.and.eratio.gt.2.0d0.and.gmag.lt.0.01d0)
            if (eig.lt.0.0d0.and.ebar.gt.0.5d0.and.ebardif.gt.5.0d0.and
     +          .gmag.lt.0.01d0)then
               if(rank_f.eq.0) write(6,*)
     +             'dimer_search: hit bailing condition, '
     +             ,'bailing on this dimer: ',ebar,ebardif
               if (imode.eq.2) then
                  if(rank_f.eq.0) write(6,*) 'dimer_search: returning'
                  ierr=10
                  return
               endif
               if(rank_f.eq.0) write(6,*) 'dimer_search: redoing dimer'
               goto 111
            endif
         endif
      enddo

 100  continue
      if (i.lt.itermax) then
         if(rank_f.eq.0) then
          if (ipr.ge.4) write(6,*) 'dimer_search: Search Converged'
         endif
         if (ipr.ge.4) then
           eratio=(energy-emin)*27.21d0/eminbar
           if(rank_f.eq.0) then
            write(6,62) i,energy*27.21d0,dv,dxmax,gmag,gdotdr,eig
     $          ,ndelgrad,ngraddimer,eratio,e100
           endif
         endif
      else
         ierr=1
         if (ipr.ge.2) then
            if(rank_f.eq.0) then
             write(6,61) 'dimer_search: Search Did Not Converge: ',dv
     +          ,dxmax,gmag
            endif
            if (imode.eq.2) then
              ierr=10
              if(rank_f.eq.0) then
               write(6,*) 'dimer_search: going to next reused saddle'
              endif
              return
            endif
            if(rank_f.eq.0) write(6,*) 'dimer_search: redoing dimer'
         endif

 61      format(a35,3d12.5)
         goto 111
      endif

      if(rank_f.eq.0) write(6,*) 'dimer_search: Total Force Calls '
     &            ,ngradcall-ngradcallorig
! Dimer search done

      filnam='dimerfinal.'//chri(itag)//'.dat'
      if (ipr.ge.10) call storefile(natom,x,x,ityp,taxes,filnam)

c if doing from NEB, don't want to do roll check, as NEB will do that
      if (imode.eq.1) return

c if nmove=natom, shift saddle to remove any translation
      if (nmove.eq.natom) then
         call shiftalign(x1,x,natom)
      endif

c do roll check to make sure dimer connects original minimum
      ngradrchold=ngradcall
      do j=1,3*natom
         xwork(j)=x(j)-x1(j)
      enddo
      xdotdimer=vecdot(xwork,rdimer,3*natom)
      isignd=-1
      if (xdotdimer.lt.0) isignd=1
      do j=1,3*natom
         xwork(j)=x(j)+0.1d0*rdimer(j)*isignd
      enddo
      imodedc=2
      ifundcuse=ifundc
      if (ifundcuse.eq.5) ifundcuse=0
      ereverseuse=0.0d0         ! not comparing to known neighbors, so don't use reverse barrier stuff
      if (imode.eq.0) then
         call descent_check(natom,nmove,1,xwork,x1,ityp,taxes,ietype
     +       ,maxtyp,rcut,hyperratio,barrevev,ereverseuse,isame1
     +       ,irotalign,itermax,gfac,transcrit,itranscrit,gcrit,dvcrit
     +       ,drcrit,ipr,imodedc,ifundcuse)
      else if (imode.eq.2) then
         call descent_check(natom,nmove,1,xwork,xmin,ityp,taxes,ietype
     +       ,maxtyp,rcut,hyperratio,barrevev,ereverseuse,isame1
     +       ,irotalign,itermax,gfac,transcrit,itranscrit,gcrit,dvcrit
     +       ,drcrit,ipr,imodedc,ifundcuse)
      endif

      filnam='dimerrc1.'//chri(itag)//'.dat'
      if(ipr.ge.10) call storefile(natom,xwork,xwork,ityp,taxes,filnam)

      if (isame1.eq.0) then
         call vecmov(xwork,xwork2,3*natom)
      endif
      do j=1,3*natom
         xwork(j)=x(j)-0.1d0*rdimer(j)*isignd
      enddo
      imodedc=2
      ifundcuse=ifundc
      if (ifundcuse.eq.5) ifundcuse=0
      if (imode.eq.0) then
         call descent_check(natom,nmove,1,xwork,x1,ityp,taxes,ietype
     +       ,maxtyp,rcut,hyperratio,barrevev,ereverseuse,isame2
     +       ,irotalign,itermax,gfac,transcrit,itranscrit,gcrit,dvcrit
     +       ,drcrit,ipr,imodedc,ifundcuse)
      else if (imode.eq.2) then
         call descent_check(natom,nmove,1,xwork,xmin,ityp,taxes,ietype
     +       ,maxtyp,rcut,hyperratio,barrevev,ereverseuse,isame2
     +       ,irotalign,itermax,gfac,transcrit,itranscrit,gcrit,dvcrit
     +       ,drcrit,ipr,imodedc,ifundcuse)
      endif

      ngradrc=ngradcall-ngradrchold

      filnam='dimerrc2.'//chri(itag)//'.dat'
      if(ipr.ge.10) call storefile(natom,xwork,xwork,ityp,taxes,filnam)

      if (isame2.eq.0) then
         call vecmov(xwork,xwork2,3*natom)
      endif

      if(rank_f.eq.0) write(6,666) isame1,isame2,ngradrc
 666  format ('dimersearch: after rollcheck: isame1=',i5,', isame2=',i5,
     +    ',ngrads=',i10)

      if (isame1.eq.0.and.isame2.eq.0.and.imode.eq.2) then
         if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +       'dimer_search: this reused saddle does not connect min'
         ierr=10
         return
      endif

      if (isame1.eq.0.and.isame2.eq.0) then
         if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +       'dimer_search: roll check does not connect to min;'
         if (imode.eq.2) then
            ierr=10
            if(rank_f.eq.0)
     +       write(6,*) 'dimer_search: going to next reused saddle'
            return
         endif
         if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +       'dimer_search: redoing this dimer from scratch'
         goto 111
      else if (isame1.eq.1.and.isame2.eq.1) then
         if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +       'dimer_search: both roll checks connect min 1;'
         if (imode.eq.2) then
            ierr=10
            if(rank_f.eq.0)
     +       write(6,*) 'dimer_search: going to next reused saddle'
            return
         endif
         if ((ipr.ge.4).and.(rank_f.eq.0)) write(6,*)
     +       'dimer_search: redoing this dimer from scratch'
         goto 111
      else
         call vecmov(xwork2,x1,3*natom)
      endif

      return
      end

c**********************************************************************
      subroutine dimer_min_torque(natom,nmove,x,rdimer,drdimer,eig,ityp
     +    ,taxes,ietype,maxtyp,rcut,ecenter,gradcenter,hyperratio)

      implicit real*8(a-h,o-z)
c      parameter(mxatom=10000)
      include 'parameters.h'

      dimension ityp(natom)
      dimension rcut(maxtyp,maxtyp)

      dimension x(3*natom),rdimer(3*natom)
      dimension gplus(3*mxatom),gminus(3*mxatom)
      dimension xtemp(3*mxatom),grad(3*mxatom)
      dimension taxes(3),gradcenter(3*mxatom)

c parameters that might need to be passed later
      gcrit=1.0d-4
      itermin=2
      dimergfac=1.0d0

      dimergfacorig=dimergfac

      iconverge=0
      eigprev=0.0d0
      i=0
 100  continue
      call vecrenorm(rdimer,3*natom)

      do j=1,3*natom
         xtemp(j)=x(j)
      enddo

      do j=1,3*nmove
         xtemp(j)=x(j)+drdimer*rdimer(j)
      enddo
      call gcalc(natom,nmove,xtemp,ityp, taxes,
     x    ietype, maxtyp,rcut, eplus,gplus, hyperratio)

      do j=1,3*nmove
         xtemp(j)=x(j)-drdimer*rdimer(j)
      enddo
      call gcalc(natom,nmove,xtemp,ityp, taxes,
     x    ietype, maxtyp,rcut, eminus,gminus, hyperratio)

      eig=(eplus+eminus-2.0d0*ecenter)/drdimer**2.0d0

      do j=1,3*nmove
         grad(j)=drdimer*(gplus(j)-gminus(j))/drdimer**2.0d0
      enddo

      if (i.gt.1.and.(eig-eigprev).gt.1.d-6) then ! eigenvalue increasing
         dimergfac=dimergfac/2.0d0
c         write(6,62) 'dimer_min_torque: eig increasing:',i,eig,eigprev
c 62      format(a35,i6,2d30.20)
         if (dimergfac/dimergfacorig.lt.1.d-3) then
            iconverge=-1
         endif
      endif

      gdotdr=vecdot(grad,rdimer,3*nmove)
      call vecypax(grad,-gdotdr,rdimer,3*nmove) ! get purely rotational grad
      call vecypax(rdimer,-dimergfac,grad,3*nmove) ! rotate rdimer
      gradmag=sqrt(vecdot(grad,grad,3*nmove))

c      write(6,63) eplus,eminus,eig,gradmag
c 63   format('eplus,eminus,eig,gradmag=',2p3d27.17,0p1d12.5)
c      if (mod(i-1,1).eq.0) write(6,61) i,gdotdr,gradmag
c 61   format('dimer_min_torque: i,gdotdr,gradmag=',i5,1pd10.2,1pd10.2)

      eigprev=eig
      i=i+1
      if ((gradmag.gt.gcrit.or.i.lt.itermin).and.iconverge.ge.0) goto
     +    100
c      write(6,*) 'dimer_min_torque: returning, iter,iconverge=',i,iconverge

      return
      end
c**********************************************************************
      subroutine dimer_initialize(natom,nmove,x1,x,idimerdof,ndimerdof,
     +    rdimer)

      use mod_mpi
      implicit real*8(a-h,o-z)
      dimension rdimer(3*natom),x1(3*natom),x(3*natom)

      if (ndimerdof.gt.nmove*3) then
         if (ipr.ge.4) then
            if(rank_f.eq.0) write(6,*)
     +          'dimer_init: ndimerdof gt nmove*3, setting to nmove*3',
     +          ndimerdof,nmove*3
            ndimerdof=nmove*3
         endif
      endif

      if (idimerdof.eq.1) then
         do j=1,ndimerdof
           if(rank_f.eq.0) rdimer(j)=prngen(0)-0.5d0
         enddo
         call MPI_BCAST(rdimer,ndimerdof,MPI_REAL8,0,force_comm,ier)
         do j=ndimerdof+1,3*natom
            rdimer(j)=0.0d0
         enddo
         call vecrenorm(rdimer,3*natom)
      else if (idimerdof.eq.2) then
         do j=1,nmove
            ii=(j-1)*3+1
            if (x1(ii).ne.x(ii)) then
               do k=1,3
                 if(rank_f.eq.0) rdimer(ii-1+k)=prngen(0)-0.5d0
               enddo
            endif
         enddo
         call MPI_BCAST(rdimer,3*natom,MPI_REAL8,0,force_comm,ier)
         call vecrenorm(rdimer,3*natom)
      else if (idimerdof.eq.3) then
         do j=1,3*nmove
           if(rank_f.eq.0) rdimer(j)=prngen(0)-0.5d0
         enddo
         call MPI_BCAST(rdimer,3*natom,MPI_REAL8,0,force_comm,ier)
         call vecrenorm(rdimer,3*natom)
      else
        if(rank_f.eq.0)
     +   write(6,*) 'dimer_init: idimerdof not recognized'
        stop 'dimer_init: idimerdof not recognized'
      endif

      return
      end
c**********************************************************************
      subroutine dimer_ranx(natom,nmove,x1,x,ipr,idimerdof
     +    ,ndimerdof,ndimercoord,idimeroverunder,taxes,icoord,rcoordcrit
     +    ,rranx)

      use mod_mpi
      implicit real*8(a-h,o-z)
      dimension x(3*natom),x1(3*natom)
c      parameter(mxatom=10000)
      include 'parameters.h'
      dimension icoord(nmove)
      dimension taxes(3)

      if (ndimerdof.gt.nmove*3) then
         if (ipr.ge.4) then
            if(rank_f.eq.0) write(6,*)
     +          'dimer_ranx: ndimerdof gt nmove*3, setting to nmove*3'
            ndimerdof=nmove*3
         endif
      endif

      if (ipr.ge.6.and.idimerdof.eq.1)then
        if(rank_f.eq.0)
     +    write(6,*)'dimer_ranx: randomizing along ',ndimerdof
     +    ,' degrees of freedom'
      endif

      if (idimerdof.eq.1) then
         xdist=0.0d0
         do j=1,ndimerdof
          if(rank_f.eq.0)then
            x(j)=x1(j)+(prngen(0)-0.5d0)*0.75d0
            xdist=xdist+(x(j)-x1(j))**2
          endif
         enddo
         call MPI_BCAST(xdist,ndimerdof,MPI_REAL8,0,force_comm,ier)
         do j=ndimerdof+1,3*natom
            x(j)=x1(j)
         enddo
         xdist=sqrt(xdist)
         if(rank_f.eq.0)then
          if(ipr.ge.6) write(6,*)'dimer_ranx: starting point is ',xdist
     +       ,' from minimum'
         endif
      else if (idimerdof.eq.2) then
         if(rank_f.eq.0) write(6,*) 'dimer_ranx: idimerdof=',idimerdof
         call vecmov(x1,x,3*natom)
         nmaxcoord=ndimercoord
         iunder=idimeroverunder
         nunder=0
         do i=1,nmove
c            write(6,*) 'atom: ',i,', coord: ',icoord(i)
            if (icoord(i).gt.nmaxcoord.and.iunder.eq.0) nunder=nunder+1
            if (icoord(i).lt.nmaxcoord.and.iunder.eq.1) nunder=nunder+1
            if (iunder.eq.2.and.(icoord(i).gt.nmaxcoord.or.
     +          icoord(i).lt.nmaxcoord)) nunder=nunder+1
         enddo
         if(rank_f.eq.0)then
           if(ipr.ge.6) write(6,*)'dimer_ranx: nunder=',nunder
         endif
c         nrand=int(prngen(0)*(float(nunder)-1)+1)
         if(rank_f.eq.0) nrand=prngen(0)*float(nunder)+1.0d0
         call MPI_BCAST(nrand,1,MPI_REAL8,0,force_comm,ier)
         if(rank_f.eq.0)then
           if(ipr.ge.6) write(6,*) 'nrand, nunder: ',nrand,nunder
         endif
         nunder=0
         iselect=0
         do i=1,nmove
            if (icoord(i).gt.nmaxcoord.and.iunder.eq.0) nunder=nunder+1
            if (icoord(i).lt.nmaxcoord.and.iunder.eq.1) nunder=nunder+1
            if (iunder.eq.2.and.(icoord(i).gt.nmaxcoord.or.
     +          icoord(i).lt.nmaxcoord)) nunder=nunder+1
            if (nunder.eq.nrand.and.iselect.eq.0) iselect=i
         enddo
         if(rank_f.eq.0)then
           if(ipr.ge.6) write(6,*) 'dimer_ranx: iselect=',iselect
         endif
         if (iselect.eq.0) then
           if(rank_f.eq.0) write(6,*)
     +          'STOP: no atom met dimer displacement criterion'
           stop 'no atom met dimer displacement criterion'
         endif
         do i=1,nmove
            rij=0.0d0
            do j=1,3
               rr=x1((iselect-1)*3+j)-x1((i-1)*3+j)
               if (abs(rr).gt.taxes(j)/2.0d0) rr=rr-sign(taxes(j),rr)
               rij=rij+rr**2
            enddo
            if (sqrt(rij).lt.rcoordcrit) then
               do j=1,3
                  ii=(i-1)*3+j
c                  x(ii)=x1(ii)+(prngen(0)-0.5d0)*rranx*2.0d0
                  if(rank_f.eq.0) x(ii)=x1(ii)+rranx*gasdev(0)
               enddo
               if((ipr.ge.6).and.(rank_f.eq.0))
     +             write(6,*) 'dimer_ranx: atom ',
     +             i,' displaced'
            endif
         enddo
         call MPI_BCAST(x,nmove*3,MPI_REAL8,0,force_comm,ier)

      else
        if(rank_f.eq.0) write(6,*)'dimer_ranx: idimerdof not recognized'
        stop 'dimer_ranx: idimerdof not recognized'
      endif

      return
      end

c**********************************************************************
      subroutine dimer_min_torque_2(imode,natom,nmove,x,rdimer,drdimer
     +    ,eig,ityp,taxes,ietype,maxtyp,rcut,ecenter,gradcenter
     +    ,hyperratio)

c uses modified newton method described by Henkelman and Jonsson
c instead of steepest descent of dimer_min_torque
      use mod_mpi
c      implicit real*8(a-h,o-z)
      implicit none
c      save
c      integer mxatom,
      integer imode
c      parameter(mxatom=10000)
      include 'parameters.h'

      integer natom,nmove,maxtyp,ityp,ietype
      real*8 eig,ecenter,hyperratio,drdimer
      real*8 x(3*natom),rdimer(3*natom)
      real*8 taxes(3),rcut(maxtyp,maxtyp)
      real*8 vecdot,gradcenter(3*natom)
      dimension ityp(natom)

      integer i,j
      real*8 gcrit,itermin,itermax,PI
      real*8 dimergfac,dimergfacorig,gradmag
      real*8 NdR,FD1,FD2,GamN,U0,U1,U2,Cth,CN
      real*8 dTh,Th,FNr,FNrp1,FNrp2,FNrp,FNp
      real*8 R(3*mxatom),N(3*mxatom),dF(3*mxatom)
      real*8 F0(3*mxatom),FN(3*mxatom)
      real*8 R1(3*mxatom),R2(3*mxatom)
      real*8 F1(3*mxatom),F2(3*mxatom)
      real*8 FN1(3*mxatom),FN2(3*mxatom)
      real*8 FNp1(3*mxatom),FNp2(3*mxatom)
      real*8 GN(3*mxatom),GNu(3*mxatom)

c parameters that might need to be passed later
      gcrit=1.0d-2
      if (imode.eq.3) gcrit=1.0d-3
      itermin=1
      itermax=50
      dimergfac=1.0d0
      dimergfacorig=dimergfac
      U0=ecenter
      PI=3.1415926535d0

      NdR=drdimer
      GamN=0
      dTh=1.0d-3
      i=0

      do j=1,3*natom
         R(j)=x(j)
         N(j)=rdimer(j)
         F0(j)=-gradcenter(j)
      enddo

 100  continue
c      write(*,*) 'Iteration: ',i+1
      do j=nmove*3+1,natom*3
        N(j)=0.0d0
      enddo
      call vecrenorm(N,3*nmove)

      do j=1,3*natom
         R1(j)=R(j)+NdR*N(j) ! R1
         R2(j)=R(j)-NdR*N(j) ! R2
      enddo

      call gcalc(natom,nmove,R1,ityp, taxes,
     x    ietype, maxtyp,rcut, U1,F1, hyperratio)

      do j=1,3*nmove
        F1(j)=-F1(j)
      enddo
      do j=nmove*3+1,natom*3
        F1(j)=0.0d0
      enddo

! Central Difference
!      call gcalc(natom,nmove,R2,ityp, taxes,
!     x    ietype, maxtyp,rcut, U2,F2, hyperratio)
!      do j=1,3*nmove
!        F2(j)=-F2(j)
!      enddo
c      write(*,*) 'U2 (from gcalc): ',U2
! Forward Difference
      do j=1,3*nmove
        dF(j)=F1(j)-F0(j)
      enddo
      U2=U0-2.0d0*U1+NdR*vecdot(dF,N,3*nmove)
      do j=1,3*nmove
        F2(j)=F0(j)*2.0d0-F1(j)
      enddo
c      write(*,*) 'U2 (from frdif): ',U2

      do j=nmove*3+1,natom*3
        F2(j)=0.0d0
      enddo

      FD1=vecdot(F1,N,3*nmove) ! F1.N
      FD2=vecdot(F2,N,3*nmove) ! F2.N
      do j=1,3*nmove
         FN1(j)=F1(j)-FD1*N(j)
         FN2(j)=F2(j)-FD2*N(j)
         FN(j)=(FN1(j)-FN2(j))/NdR
      enddo

      FNr=sqrt(vecdot(FN,FN,3*nmove))
      U0=(U1+U2)/2.0d0+(FD1-FD2)*(NdR/4.0d0)
      CN=(FD2-FD1)/(2.0d0*NdR)

      ! This is a steepest descent using the modified Newton's rotation
      do j=1,3*nmove
        GN(j)=FN(j)
        GNu(j)=GN(j)
      enddo
      do j=nmove*3+1,natom*3
        GN(j)=0.0d0
        GNu(j)=0.0d0
      enddo
      call vecrenorm(GNu,3*nmove)

      FNp=vecdot(FN,GNu,3*nmove)
      do j=1,3*nmove
        FNp1(j)=GNu(j)*FNp
      enddo
      FNrp1=vecdot(FNp1,GNu,3*nmove)

c      write(*,*) 'FNrp1',FNrp1,' FNr',FNr,' U0',U0,' CN',CN

      call Rotate(N,GNu,dTh,3*nmove)
      call vecrenorm(N,3*nmove)
      call vecrenorm(GNu,3*nmove)

      do j=1,3*natom
         R1(j)=R(j)+NdR*N(j) ! R1
         R2(j)=R(j)-NdR*N(j) ! R2
      enddo

      call gcalc(natom,nmove,R1,ityp, taxes,
     x    ietype, maxtyp,rcut, U1,F1, hyperratio)

      do j=1,3*nmove
        F1(j)=-F1(j)
      enddo

      do j=nmove*3+1,natom*3
        F1(j)=0.0d0
      enddo
! Central Difference
!      call gcalc(natom,nmove,R2,ityp, taxes,
!     x    ietype, maxtyp,rcut, U2,F2, hyperratio)
!      do j=1,3*nmove
!        F2(j)=-F2(j)
!      enddo

! Forward Difference
      do j=1,3*nmove
        dF(j)=F1(j)-F0(j)
      enddo

      U2=U0-2.0d0*U1+NdR*vecdot(dF,N,3*nmove)
      do j=1,3*nmove
        F2(j)=F0(j)*2.0d0-F1(j)
      enddo

      do j=nmove*3+1,natom*3
        F2(j)=0.0d0
      enddo

      FD1=vecdot(F1,N,3*nmove) ! F1.N
      FD2=vecdot(F2,N,3*nmove) ! F2.N
      do j=1,3*nmove
         FN1(j)=F1(j)-FD1*N(j)
         FN2(j)=F2(j)-FD2*N(j)
         FN(j)=(FN1(j)-FN2(j))/NdR
      enddo

      FNr=sqrt(vecdot(FN,FN,3*nmove))
      U0=(U1+U2)/2.0d0+(FD1-FD2)*(NdR/4.0d0)
      CN=(FD2-FD1)/(2.0d0*NdR)

      FNp=vecdot(FN,GNu,3*nmove)
      do j=1,3*nmove
        FNp2(j)=GNu(j)*FNp
      enddo
      FNrp2=vecdot(FNp2,GNu,3*nmove)
      Cth=(FNrp1-FNrp2)/dTh
      FNrP=(FNrp1+FNrp2)/2.0d0
      Th=atan((FNrp/Cth)*2.0d0)/2.0d0-dTh/2.0d0
      if(Cth.lt.0) Th=Th+PI/2.0d0

c      write(*,*) 'FNrp2',FNrp2,' FNr',FNr,' U0',U0,' CN',CN
c      write(*,*) 'Cth',Cth,' FNrP',FNrP,' Th',Th
c      write(*,*) 'Itr ',i+1,' Cth',Cth,' FNrP',FNrP,' Th',Th

      call Rotate(N,GNu,Th,3*nmove)
      call vecrenorm(N,3*nmove)
      call vecrenorm(GNu,3*nmove)

c      do j=1,3*natom
c         R1(j)=R(j)+NdR*N(j) ! R1
c         R2(j)=R(j)-NdR*N(j) ! R2
c      enddo

      i=i+1
c      write(*,*) 'gradmag',gradmag
      gradmag=FNrp1
c      if ((gradmag.gt.gcrit.or.i.lt.itermin).and.iconverge.ge.0) goto
      if ((gradmag.gt.gcrit.or.i.lt.itermin).and.(i.lt.itermax)) goto
     +    100

c return values
      eig=CN
!      ecenter=U0
      do j=1,3*natom
        rdimer(j)=N(j)
      enddo

      return
      end

!**********************************************************************
      subroutine Rotate(V1,V2,Th,num)
! Rotate the vectors V1 and V2
      integer num
      real*8 V1(num),V2(num),Th
      real*8 V1tmp(num),cth,sth
      cth=cos(Th)
      sth=sin(Th)
      do j=1,num
        V1tmp(j)=V1(j)
        V1(j)=V1(j)*cth+V2(j)*sth
        V2(j)=V2(j)*cth-V1tmp(j)*sth
      enddo
      end !subroutine Rotate

c**********************************************************************
      subroutine shiftsaddle(natom,nmove,rdimer,xyzsad,xyzmin1,xyzmin2
     +    ,transcrit,ierr)

      implicit real*8(a-h,o-z)

      dimension xyzsad(3*natom),xyzmin1(3*natom),xyzmin2(3*natom)
     +    ,rdimer(3*natom)

      ierr=0

      do i=1,nmove
         rij=0.0d0
         rik=0.0d0
         do j=1,3
            rij=rij+(xyzmin2((i-1)*3+j)-xyzmin1((i-1)*3+j))**2
            rik=rik+(xyzsad((i-1)*3+j)-xyzmin1((i-1)*3+j))**2
         enddo
         rij=sqrt(rij)
         rik=sqrt(rik)
         if (rij.ge.transcrit) then
            do j=1,3
               xyzsad((i-1)*3+j)=xyzmin2((i-1)*3+j)
               rdimer((i-1)*3+j)=0.0d0
            enddo
         endif
      enddo

      do i=1,nmove
         do k=1,nmove
            rik=0.0d0
            if (k.ne.i) then
               do j=1,3
                  rik=rik+(xyzsad((i-1)*3+j)-xyzsad((k-1)*3+j))**2 ! xxxx no pbcs here, need to add
               enddo
               if (sqrt(rik).le.1.05d0) then
                  ierr=1
                  write(6,*) 'shiftsaddle: ierr=1, atoms ',i,k,sqrt(rik)
                  return
               endif
            endif
         enddo
      enddo

      return
      end

c**********************************************************************
      subroutine dimer_ranx_hole(natom,nmove,x,xmin,xyzprev,ipr
     +    ,idimerdof,ndimerdof,ndimercoord,idimeroverunder,taxes
     +    ,rranx,transcrit,rcoordcrit)

      use mod_mpi
      implicit real*8(a-h,o-z)
      dimension xmin(3*natom),x(3*natom),xyzprev(3*natom)
c      parameter(mxatom=10000)
      include 'parameters.h'
      dimension iindex(100)
      dimension taxes(3)

      inumber=0
      call vecmov(xmin,x,3*natom)
      do i=1,nmove
         rij=0.0d0
         do j=1,3
            rij=rij+(xmin((i-1)*3+j)-xyzprev((i-1)*3+j))**2
         enddo
         rij=sqrt(rij)
         if (rij.ge.transcrit) then
            inumber=inumber+1
            if (inumber.gt.100) then
               write(6,*) 'STOP: inumber too big'
               stop 'inumber too big'
            endif
            iindex(inumber)=i
         endif
      enddo

      if(rank_f.eq.0) irand=prngen(0)*float(inumber)+1.0d0
      call MPI_BCAST(irand,1,MPI_REAL8,0,force_comm,ier)
      iselect=iindex(irand)
      if (ipr.ge.4) write(6,*) 'dimer_ranx_hole: iselect=',iselect,
     +      rcoordcrit,inumber,irand

      if (iselect.eq.0) then
         write(6,*) 'STOP: no atom met dimer displacement criterion'
         stop 'no atom met dimer displacement criterion'
      endif
      do i=1,nmove
         rij=0.0d0
         do j=1,3
            rr=xmin((iselect-1)*3+j)-xmin((i-1)*3+j)
            if (abs(rr).gt.taxes(j)/2.0d0) rr=rr-sign(taxes(j),rr)
            rij=rij+rr**2
         enddo
         if (sqrt(rij).lt.rcoordcrit) then
            do j=1,3
               ii=(i-1)*3+j
               if(rank_f.eq.0) x(ii)=xmin(ii)+rranx*gasdev(0)
            enddo
            if (ipr.ge.4) write(6,*) 'dimer_ranx_hole: atom ',
     +          i,' displaced'
         endif
      enddo
      call MPI_BCAST(x,nmove*3,MPI_REAL8,0,force_comm,ier)

      return
      end


      SUBROUTINE LINMIN(XPARAM,ALPHA,PVECT,NVAR,FUNCT,OKF,IC, DOTT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XPARAM(NVAR),PVECT(NVAR)
      COMMON /GRAVEC/ COSINE
      COMMON /NUMCAL/ NUMCAL
C*********************************************************************
C
C  LINMIN DOES A LINE MINIMISATION.
C
C  ON INPUT:  XPARAM = STARTING COORDINATE OF SEARCH.
C             ALPHA  = STEP SIZE FOR INITIATING SEARCH.
C             PVECT  = DIRECTION OF SEARCH.
C             NVAR   = NUMBER OF VARIABLES IN XPARAM.
C             FUNCT  = INITIAL VALUE OF THE FUNCTION TO BE MINIMIZED.
C             ISOK   = NOT IMPORTANT.
C             COSINE = COSINE OF ANGLE OF CURRENT AND PREVIOUS GRADIENT.
C
C  ON OUTPUT: XPARAM = COORDINATE OF MINIMUM OF FUNCTI0N.
C             ALPHA  = NEW STEP SIZE, USED IN NEXT CALL OF LINMIN.
C             FUNCT  = FINAL, MINIMUM VALUE OF THE FUNCTION.
C             OKF    = TRUE IF LINMIN IMPROVED FUNCT, FALSE OTHERWISE.
C
C**********************************************************************
      COMMON /KEYWRD/ KEYWRD
C
C  THE FOLLOWING COMMON IS USED TO FIND OUT IF A NON-VARIATIONALLY
C  OPTIMIZED WAVE-FUNCTION IS BEING USED.
C
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      CHARACTER KEYWRD*241
      DIMENSION PHI(3), VT(4)
      DIMENSION XSTOR(MAXPAR), XPAREF(MAXPAR)
      INTEGER LEFT,RIGHT,CENTER
      LOGICAL PRINT,OKF, HALFE, DIIS
      SAVE ICALCN, PRINT, HALFE, XMAXM, I
      SAVE MAXLIN,  YMAXST
      DATA ICALCN /0/
      IF (ICALCN.NE.NUMCAL) THEN
         HALFE =(INDEX(KEYWRD,'C.I.') .NE. 0 .OR. NCLOSE.NE.NOPEN)
         IF(INDEX(KEYWRD,'GNORM') .NE. 0)
     1DROP=DROP*MIN(READA(KEYWRD,INDEX(KEYWRD,'GNORM')),1.D0)
         XMAXM  = 0.4D0
         DELTA2 = 0.001D0
         IF(INDEX(KEYWRD,'NOTH') .EQ. 0) THEN
            DELTA1 = 0.5D0
         ELSE
            DELTA1 = 0.1D0
         ENDIF
         ALPHA  = 1.D0
         MAXLIN = 15
         IF(NVAR.EQ.1)THEN
            PVECT(1)=0.01D0
            DROP=0.01D0
            ALPHA=1.D0
            DELTA1 = 0.00005D0
            DELTA2 = 0.00001D0
            IF(INDEX(KEYWRD,'PREC') .NE. 0) DELTA1=0.0000005
            MAXLIN=30
         ENDIF
         COSINE=99.99D0
C
         YMAXST  = 0.4D0
         PRINT=(INDEX(KEYWRD,'LINMIN') .NE. 0)
         ICALCN=NUMCAL
      ENDIF
      DO 10 I=1,NVAR
         XPAREF(I)=XPARAM(I)
   10 CONTINUE
      XMAXM=0.D0
      DO 20 I=1,NVAR
         PABS=ABS(PVECT(I))
   20 XMAXM=MAX(XMAXM,PABS)
      XMAXM=YMAXST/XMAXM
      IF(NVAR.EQ.1)
     1CALL COMPFG(XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
      FIN=FUNCT
      SSQLST=FUNCT
      DIIS=IC.EQ.1.AND.NVAR.GT.1
      PHI(1)=FUNCT
      ALPHA=1.D0
      VT(1)=0.0D00
      VT(2)=ALPHA
      IF (VT(2).GT.XMAXM) VT(2)=XMAXM
      FMAX=FUNCT
      FMIN=FUNCT
      ALPHA=VT(2)
      DO 30 I=1,NVAR
   30 XPARAM(I)=XPAREF(I)+ALPHA*PVECT(I)
      CALL COMPFG(XPARAM, .TRUE., PHI(2),.TRUE.,GRAD,.FALSE.)
      IF(PHI(2).GT.FMAX) FMAX=PHI(2)
      IF(PHI(2).LT.FMIN) FMIN=PHI(2)
      CALL EXCHNG (PHI(2),SQSTOR,ENERGY,ESTOR,XPARAM,XSTOR,
     1ALPHA,ALFS,NVAR)
      IF(DIIS)GOTO 190
      IF(NVAR.GT.1)THEN
C
C   CALCULATE A NEW ALPHA BASED ON THIEL'S FORMULA
C
         ALPHA=-ALPHA**2*DOTT/(2.D0*(PHI(2)-SSQLST-ALPHA*DOTT))
         IF(ALPHA.GT.2.D0)ALPHA=2.D0
      ELSE
         IF(PHI(2).LT.PHI(1))THEN
            ALPHA=2*ALPHA
         ELSE
            ALPHA=-ALPHA
         ENDIF
      ENDIF
C#      IF(PRINT)WRITE(6,'(3(A,F12.6))')' ESTIMATED DROP:',DOTT*0.5D0,
C#     1'  ACTUAL: ',PHI(2)-SSQLST, '  PREDICTED ALPHA',ALPHA
      OKF=OKF.OR.PHI(2).LT.SSQLST
      IF(DELTA1.GT.0.3D0)THEN
C
C  THIEL'S TESTS # 18 AND 19
C
         IF(OKF.AND.ALPHA.LT.2.D0)GOTO 190
      ENDIF
      VT(3)=ALPHA
      IF (VT(3).LE.1.D0) THEN
         LEFT=3
         CENTER=1
         RIGHT=2
      ELSE
         LEFT=1
         CENTER=2
         RIGHT=3
      ENDIF
      DO 40 I=1,NVAR
   40 XPARAM(I)=XPAREF(I)+ALPHA*PVECT(I)
      CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
      IF(FUNCT.GT.FMAX) FMAX=FUNCT
      IF(FUNCT.LT.FMIN) FMIN=FUNCT
      IF (FUNCT.LT.SQSTOR) CALL EXCHNG (FUNCT,SQSTOR,ENERGY,
     1ESTOR,XPARAM,XSTOR,ALPHA,ALFS,NVAR)
      OKF=(OKF.OR.FUNCT.LT.FIN)
      PHI(3)=FUNCT
      IF (PRINT)WRITE (6,50) VT(1),PHI(1),PHI(1)-FIN,
     1                        VT(2),PHI(2),PHI(2)-FIN,
     2                        VT(3),PHI(3),PHI(3)-FIN
   50 FORMAT ( ' ---QLINMN ',/5X, 'LEFT   ...',F17.8,2F17.11/5X,
     1 'CENTER ...',F17.8,2F17.11,/5X, 'RIGHT  ...',F17.8,2F17.11,/)
      DO 180 ICTR=3,MAXLIN
         ALPHA=VT(2)-VT(3)
         BETA=VT(3)-VT(1)
         GAMMA=VT(1)-VT(2)
         IF(ABS(ALPHA*BETA*GAMMA) .GT. 1.D-4)THEN
            ALPHA=-(PHI(1)*ALPHA+PHI(2)*BETA+PHI(3)*GAMMA)/(ALPHA*BETA*G
     1AMM   A)
         ELSE
C
C   FINISH BECAUSE TWO POINTS CALCULATED ARE VERY CLOSE TOGETHER
C
            GOTO 190
         ENDIF
         BETA=((PHI(1)-PHI(2))/GAMMA)-ALPHA*(VT(1)+VT(2))
         IF (ALPHA) 60,60,90
   60    IF (PHI(RIGHT).GT.PHI(LEFT)) GO TO 70
         ALPHA=3.0D00*VT(RIGHT)-2.0D00*VT(CENTER)
         GO TO 80
   70    ALPHA=3.0D00*VT(LEFT)-2.0D00*VT(CENTER)
   80    S=ALPHA-ALPOLD
         IF (ABS(S).GT.XMAXM) S=SIGN(XMAXM,S)*(1+0.01*(XMAXM/S))
         ALPHA=S+ALPOLD
         GO TO 100
   90    ALPHA=-BETA/(2.0D00*ALPHA)
         S=ALPHA-ALPOLD
         XXM=2.0D00*XMAXM
         IF (ABS(S).GT.XXM) S=SIGN(XXM,S)*(1+0.01*(XXM/S))
         ALPHA=S+ALPOLD
  100    CONTINUE
C
C   FINISH IF CALCULATED POINT IS NEAR TO POINT ALREADY CALCULATED
C
         DO 110 I=1,3
  110    IF (ABS(ALPHA-VT(I)).LT.DELTA1*(1.D0+VT(I)).AND.OKF) GOTO 190
         DO 120 I=1,NVAR
  120    XPARAM(I)=XPAREF(I)+ALPHA*PVECT(I)
         FUNOLD=FUNCT
         CALL COMPFG (XPARAM, .TRUE., FUNCT,.TRUE.,GRAD,.FALSE.)
         IF(FUNCT.GT.FMAX) FMAX=FUNCT
         IF(FUNCT.LT.FMIN) FMIN=FUNCT
         IF (FUNCT.LT.SQSTOR) CALL EXCHNG (FUNCT,SQSTOR,ENERGY,ESTOR,
     1   XPARAM,XSTOR,ALPHA,ALFS,NVAR)
         OKF=OKF .OR. (FUNCT.LT.FIN)
         IF (PRINT) WRITE(6,130) VT(LEFT),PHI(LEFT), PHI(LEFT)-FIN,
     1                           VT(CENTER),PHI(CENTER),PHI(CENTER)-FIN,
     2                           VT(RIGHT),PHI(RIGHT),PHI(RIGHT)-FIN,
     3                           ALPHA,FUNCT,FUNCT-FIN
  130    FORMAT (5X,'LEFT    ...',F17.8,2F17.11,/5X,'CENTER  ...',
     1F17.8,2F17.11,/5X,'RIGHT   ...',F17.8,2F17.11,/5X,
     2 'NEW     ...',F17.8,2F17.11,/)
C
C TEST TO EXIT FROM LINMIN IF NOT DROPPING IN VALUE OF FUNCTION FAST.
C
         IF(ABS(FUNOLD-FUNCT) .LT. DELTA2 .AND. OKF) GOTO 190
         ALPOLD=ALPHA
         IF ((ALPHA.GT.VT(RIGHT)).OR.(ALPHA.GT.VT(CENTER)
     1        .AND.FUNCT.LT.PHI(CENTER)).OR.(ALPHA.GT.VT(LEFT)
     2        .AND.ALPHA.LT.VT(CENTER).AND.FUNCT.GT.PHI(CENTER)))
     3         GOTO 140
         VT(RIGHT)=ALPHA
         PHI(RIGHT)=FUNCT
         GO TO 150
  140    VT(LEFT)=ALPHA
         PHI(LEFT)=FUNCT
  150    IF (VT(CENTER).LT.VT(RIGHT)) GO TO 160
         I=CENTER
         CENTER=RIGHT
         RIGHT=I
  160    IF (VT(LEFT).LT.VT(CENTER)) GO TO 170
         I=LEFT
         LEFT=CENTER
         CENTER=I
  170    IF (VT(CENTER).LT.VT(RIGHT)) GO TO 180
         I=CENTER
         CENTER=RIGHT
         RIGHT=I
  180 CONTINUE
  190 CONTINUE
C
C  IC=1 IF THE LAST POINT CALCULATED WAS THE BEST POINT, IC=2 OTHERWISE
C
      IC=2
      IF(ABS(ESTOR-ENERGY).LT.1.D-12)IC=1
      CALL EXCHNG (SQSTOR,FUNCT,ESTOR,ENERGY,XSTOR,XPARAM,
     1             ALFS,ALPHA,NVAR)
      OKF = (FUNCT.LT.SSQLST.OR.DIIS)
      IF (FUNCT.GE.SSQLST) RETURN
      IF (ALPHA) 200,220,220
  200 ALPHA=-ALPHA
      DO 210 I=1,NVAR
  210 PVECT(I)=-PVECT(I)
  220 CONTINUE
      RETURN
C
C
      END


C File VAPMN_CRAY
C  This file contains the mid-level routines for the Finite Difference Migration
C They are responsible for the calculating the next time slice at the current
C Tau step.
C
C  This is the CRAY version of the routines which have been rewritten so that
C they vectorize on the CRAY. Also the order of calculation has been modified
C to reduce the Number of floating point operations per time slice. This
C is at the expense of greater memory use through APSCR
C
C  VSFDMCAL - Entry routine from FDMLIN. Responsible for calling routines to
C             calculate RHS & LHS of difference equation. Also shift time
C             slices in memory in preparation for next calculation.
C  VSFDMCAP - Responsible for calculating g on LHS of Recurrence relation.
C             Calls routines to calculate P at this time slice and Tau Step
C  VSFDMCAR - Calculates the RHS of the Difference equation.
C
C  VSFDMRUV - A glue routine that calls VSRUVAPS
C  VSRUVAPS - AP Simulator routine to recusively calculate U & V. This is an
C             intermediate stage to calculating the new Pressure
C
C  VSFDMPN1 - A glue routine that calls VSPN1APS
C  VSPN1APS - AP Simulator routine that calculate the new P given U and V
C
C===============================================================================

        subroutine VSFDMCAL (ac, apn, apnj1, apnj2, apn1, apn1j1,
     +          apn1j2, as3, mx)
        INTEGER ac, apn, apnj1, apnj2, apn1, apn1j1, apn1j2, as3, mx
C-------------------------------------------------------------------------------
C FDM: Calculate the cR" terms and the next time slice, etc. (simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: April, 1985
C
C ENTRY NAMES:  APSFDMCAL
C
c FUNCTION:     1- Calculates the three "R" terms. (See FDMCAR)
c               2- Recursively calculates the next Tau sample P(n+1).
c                  (See FDMCAP)
c               3- Moves the calculated sample back in place and "rotates" the
c                  samples for calculating the next Tau sample.
c
c PARAMETERS:   All parameters beginning with the letter "A" refer to main data
c               (MD) memory locations. (Further notes in FDMCAR and FDMCAP.)
c               AC      = C'
c               APN     = P(n,j)
c               APNJ1   = P(n,j+1)
c               APNJ2   = P(n,j+2)
c               APN1    = P(n+1,j)
c               APN1J1  = P(n+1,j+1)
c               APN1J2  = P(n+1,j+2)
c               AS3     = scratch
c               MX      = Number of traces in each time slice.
c
C CALLED BY:    FDMCAL (which is called by FDMLIN)
C
C EXTERNALS:    FDMCAR, FDMCAP, VMOV
C
C ERRORS & LIMITATIONS: none
C
C REFERENCES:   1- H.Brysk, GEOPHYSICS, volume 48, no.5 (May 1983), p(532-542).
C               2- FDMCAR and FDMCAP notes and FDM design notes.
C REVISIONS:
C
C AUTHOR:   a.j.h                           DATE:  4/11/89
C DESCRIPTION:   Added Call to blkmov to shift the Time slices in APSCR
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        INTEGER ar, ag, au, av, as1
C
C....   Assign scratch arrays and do it.
C
        ar = apn1                                                       ! Setup AP memory location equivalences
        ag = as3
        au = apn1j2
        av = apnj2
        as1= apn1j2
C..                                        Calculate RHS of Recursion relation
        CALL VSFDMCAR (ac, apn, apnj1, apnj2, ar, apn1j1, apn1j2, as3,
     +   mx)
C..                                        Calculate updated P at this time step
        CALL VSFDMCAP (apn, apn1, ag, au, av, ac, ar, as1, mx)
C
        CALL apsVMOV (apnj1,1,  apnj2,1,  mx)                           ! Shift time slices in AP memory
        CALL apsVMOV (apn,1,    apnj1,1,  mx)
        CALL apsVMOV (apn1j1,1, apn1j2,1, mx)
        CALL apsVMOV (apn1,1,   apn1j1,1, mx)
        CALL apsVMOV (apn1,1,   apn,1,    mx)
        CALL blkmov  (auxscr3, auxscr5, mx)                             ! Move   (P(n+1,j+1) - P(n,j+1))
        CALL blkmov  (auxscr4, auxscr6, mx)                             ! Move T*(P(n+1,j+1) - P(n,j+1))
        RETURN
        END                                                             ! of routine VSFDMCAL

C===============================================================================

        SUBROUTINE vsfdmcap (apn, apn1, ag, au, av, ac, ar, as1, mx)
        INTEGER apn, apn1, ag, au, av, ac, ar, as1, mx
C-------------------------------------------------------------------------------
C$R     FDM: Calculate the next time slice for the current Tau step. (simulator)
C
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMCAP
C
c FUNCTION:     For the current sample we require the following recursions:
c
c               (1) P'(m) = v(m) - u(m)P'(m+1)
c
c                   P(n+1,j,m) = P(n,j,m) + P'(m), for m = MX to 1.
c
c               (2)                g(m)
c                   u(m) = ----------------------,
c                          1 - 2g(m) - g(m)u(m-1)
c
c                                (         R(m) )
c                   v(m) = -u(m) (v(m-1) - ---- ), m = 1, MX.
c                                (         g(m) )
c
c               Where:  g(m)    = gamma - a*theta - b
c                       a       = delta-tau * C'
c                       b       = delta-t / 4 * C'
c                       C'      = (C**2 * delta-t) / (4 * delta-x**2)
c                       C       = 1/2 of the RMS velocity for the Tau step.
c                       P(n+1,j,m) = samples calculated at the current Tau step.
c                       P(n,j,m)= samples at the previous Tau step.
c                       P'(m)   = intermediate result (not saved - see FDMPN1)
c                       u(m)    = intermediate result (not saved - see FDMRUV)
c                       v(m)    = intermediate result (not saved - see FDMRUV)
c                       R(m)    = sum of 3 terms (see FDMCAR)
c
c               The processing order is
c                       1 - Calculate g.
c                       2 - Calculate u and v using equation (2) (see FDMRUV).
c                       3 - Calculate P(n+1,j) using equation (1) (see FDMPN1).
c
c PARAMETERS:   All parameters beginning with the letter "A" refer to main data
c               (MD) memory arrays.
c               All arrays are input except for APN1 (output) and AS1 (scratch).
c
c               APN     = P(n,j) - Sample j from previous Tau step n for all m.
c               APN1    = P(n+1,j) - Output sample j for Tau step n+1 for all m.
c               AG      = g.
c               AU      = u.
c               AV      = v.
c               AC      = C'.
c               AR      = R.
c               AS1     = Scratch.
c               MX      = X dimension of time slice (number of traces).
c
c               The following constants are assumed to be in lower main data
c               memory locations when this routine is called:
c               parameter       location        reference name
c               gamma            3              AGAMMA
c               theta            7              ATHETA
c               delta-tau        8              ADTAU
c               delta-t / 4     10              ADT4
c
C CALLED BY:    FDMCAP (which is called by FDMLIN)
C
C EXTERNALS:    VCLR, VMUL, VSUB, FDMRUV and FDMPN1.
C
C ERRORS & LIMITATIONS: Refer to FDMCAP.VFC
C
C REFERENCES:   Refer to FDMCAP.VFC
C
C REVISIONS:
C AUTHOR:  a.j.h                                     DATE:  4/11/89
C DESCRIPTION:  Changed calculation of g(m) so that it is calculated in a
C               single vector loop. CDIR$ IVDEP forces CRAY to ignore possible
C               vector dependencies.
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        INTEGER agamma, atheta, adtau, adt4
C
        agamma =  3                                                     ! Set up AP low memory locations
        atheta =  7
        adtau  =  8
        adt4   = 10
C
C....   1 - Calculate g.
          tpscal = apdata(adtau) * apdata(atheta) + apdata(adt4)
          tpgam  = apdata(agamma)
c
c.. Ignore vector dependency
CDIR$ IVDEP
          do 10 i = 0, mx-1
           apdata(ag + i) = tpgam - tpscal * apdata(ac+i)
c	 if( apdata(ag + i) .EQ. 0 ) THEN
c	 print *,' i=',i,' ag=',ag,apdata(ag + i),tpgam,tpscal,apdata(ac+i)
c  i=  0 ag=  4999950  0.   0.125000    5.06000E-02    2.47036
c         ac = C'
c                       C'      = (C**2 * delta-t) / (4 * delta-x**2)
c                       C       = 1/2 of the RMS velocity for the Tau step.
c	 stop
c	 endif
  10      continue
C
C....   2- Calculate u and v.
        CALL vsfdmruv (ag, ar, au, av, mx)
C
C....   3- Calculate P(n+1,j).
        CALL vsfdmpn1 (apn, au, av, apn1, mx)
        return
        END                                                             ! of routine vsfdmcap

C===============================================================================

        SUBROUTINE vsfdmcar (ac, apn, apnj1, apnj2, ar, apn1j1,
     +          apn1j2, as3, mx)
        INTEGER ac, apn, apnj1, apnj2, ar, apn1j1, apn1j2, as3, mx
C------------------------------------------------------------------------------
C$R     FDM: Calculate the 3 cR" terms. (Simulator)
C
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMCAR
C
c FUNCTION:     This routine evaluates the terms on the right-hand side of the
c               following equation:
c               R(m) = [1 - (gamma - a*theta - b) * T] (P(n+1,j,m) - P(n,j,m)
c                =   2*rho [1 - (gamma+b) * T]
c                               (P(n+1,j+1,m) - P(n,j+1,m)              (term 1)
c                  - rho**2 [1 - (gamma + a*theta -b) * T]
c                               (P(n+1,j+2,m) - P(n,j+2,m))             (term 2)
c                  + a*T (rho**2 * P(n,j+2,m) - P(n,j,m)),              (term 3)
c               where
c                       m       = 1 to MX.
c                       a       = delta tau * C'
c                       b       = delta t/4 * C'
c                       C'      = (C**2 * delta t) / (4 * delta x**2)
c                       C       = 1/2 of the RMS velocity for the Tau interval.
c                       P(n,j..j+2) = Samples from the previous Tau step, n.
c                       P(n+1,j..j+2) = Samples of the current Tau step, n+1.
c                                 (P(n+1,j) is the desired time slice.)
c                       T       = 3 point convolutional operator = (-1, 2, -1).
c                       R       = The calculated value of the three terms.
c
c PARAMETERS:   All parameters begining with the letter "A" refer to main data
c               (MD) memory locations and arrays. All arrays are input except
c               AR and AS3. (NOTE: All arrays are assumed to have 0-elements at
c               at either end so that the convolution with the 3 point "T"
c               operator will work. Ie. APN(-1)=0 and APN(MX)=0.)
c               AC      = C'.
c               APN     = P(n,j)
c               APNJ1   = P(n,j+1)
c               APNJ2   = P(n,j+2) (will be scratched)
c               AR      = R. (output)
c               APN1J1  = P(n+1,j+1)
c               APN1J2  = P(n+1,j+2) (will be scratched)
c               AS3     = scratch.
c               MX      = X-dimension of each time slice (number of traces).
c
c               The following constants are expected in lower MD memory:
c               parameter       location        referenced as
c               T               0..2            AT
c               gamma            3              AGAMMA
c               rho              4              ARHO
c               rho**2           5              ARHOSQ
c               2 * rho          6              A2RHO
c               theta            7              ATHETA
c               delta tau        8              ADTAU
c               delta t          9              ADT
c               delta t / 4     10              ADT4
c
C
C CALLED BY:    FDMCAR (which is called by FDMLIN).
C
C EXTERNALS:    TCONV
C
C ERRORS & LIMITATIONS: None.
C
C REFERENCES:   Refer to FDMCAR.VFC
C
C REVISIONS:
C AUTHOR:  a.j.h.                                   DATE: 11/4/89
C DESCRIPTION:
C    This routine was almost completely rewritten although it is functinally
C equivalent to the previous AP simulator code.
C    This version calculates most of R in a single vector do loop. However, it
C does calculate the majority of term 3 separately
C    It uses (P(n+1,j+2) - P(n,j+2)) and T*(P(n+1,j+2) - P(n,j+2)) stored in
C APSCR from the previous time step
C   The final do loop is somewhat ungainly and even on the Cray it may be better
C to split into smaller vector loops
C-------------------------------------------------------------------------------
C
        INTEGER agamma, arhosq, a2rho, atheta, adtau, adt4
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
C....   Define some other array names and constants.
C
        agamma  = 3                                                     ! gamma
        arhosq  = 5                                                     ! rho ** 2
        a2rho   = 6                                                     ! 2 * rho
        atheta  = 7                                                     ! theta
        adtau   = 8                                                     ! delta tau
        adt4    =10                                                     ! delta t / 4
C
C
      sc2rho  = apdata(a2rho)
      sc2     = sc2rho * apdata(agamma)
      sc3     = sc2rho * apdata(adt4)
      scrhosq = apdata(arhosq)
      scdtau  = apdata(adtau)
      sc6     = scrhosq * apdata(agamma)
      sc7     = scrhosq * (scdtau * apdata(atheta) - apdata(adt4))
C
C....   Calculate term 3 T* (rho**2 * P(n,j+2) - P(n,j)):
      do 10 ii = -1, mx+1                                               ! Must ensure end traces are 0. for T*
        apscr(auxscr1+ii) = scrhosq * apdata(apnj2+ii)
     $                                      - apdata(apn+ii)
   10 continue
C
      call TCONV(apscr(auxscr1-1),apscr(auxscr2),mx)
C
C.. The next two terms are reused at the next time step (see VSFDMCAL)
C
C...  Calculate term P(n+1,j+1) - P(n,j+1)
      do 20 ii = -1, mx+1                                               ! Must ensure end traces are 0. for T*
        apscr(auxscr3 + ii) = apdata(apn1j1 + ii) - apdata(apnj1 + ii)
   20 continue
C
C.... Calculate term T* (P(n+1,j+1) - P(n,j+1))
      call TCONV(apscr(auxscr3-1),apscr(auxscr4),mx)
C
C                                      Calculate R
C Ignore apparent Vector dependencies
CDIR$ IVDEP
      do 30 ii = 0, mx-1
        apdata(ar+ii) =
     $                           sc2rho * apscr(auxscr3+ii)
     $    - (sc2 + sc3 * apdata(ac+ii)) * apscr(auxscr4+ii)
     $    -                     scrhosq * apscr(auxscr5+ii)
     $    + (sc6 + sc7 * apdata(ac+ii)) * apscr(auxscr6+ii)
     $    +     scdtau * apdata(ac+ii)  * apscr(auxscr2+ii)
   30 continue
      RETURN
      END                                                               ! of routine VSFDMCAR

C===============================================================================

        SUBROUTINE vsfdmpn1 (pn, u, v, pn1, mx)
        INTEGER pn, u, v, pn1, mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate the next time slice, P(n+1,j). (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMPN1
C
C COMMON:       /AP120B_MD/ - Main Data (MD) memory simulator buffer.
C
C CALLED BY:    FDMPN1.APL (which is called by FDMCAP.VFC)
C
C EXTERNALS:    FDMPN1APS.FOR
C
C ERRORS & LIMITATIONS: Efficiency of this code may be improved by writing in
C               Macro.
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

        CALL vspn1aps (apdata(pn), apdata(u), apdata(v),
     +     apdata(pn1), mx)
        RETURN
        END                                                             ! of routine VSFDMPN1

C===============================================================================

        SUBROUTINE vsfdmruv (g, r, u, v, mx)
        INTEGER g, r, u, v, mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate u and v. (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  APSFDMRUV
C
C FUNCTION:     Refer to FDMRUV.APL
C
C PARAMETERS:   Refer to FDMRUV.APL
C
C COMMON:       /AP120B_MD/ - Main Data (MD) memory buffer for simulator.
C
C CALLED BY:    FDMRUV.APL from APSFDMCAP.FOR from FDMCAP.FOR.
C
C EXTERNALS:    FDMRUVAPS.FOR
C
C ERRORS & LIMITATIONS: Efficiency may be improved by writing in Macro.
C
C REFERENCES:   Refer to FDMRUV.APL
C
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
        CALL vsruvaps (apdata(g), apdata(r), apdata(u), apdata(v),
     +       mx)
        RETURN
        END                                                             ! of routine VSRUVAPS

C===============================================================================

        SUBROUTINE vsruvaps (g, r, u, v, mx)
        REAL    g(mx), r(mx), u(mx), v(mx)
        INTEGER mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate u and v. (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  VSRUVAPS
C
C FUNCTION:     Refer to FDMRUV.APL
C
C PARAMETERS:   Refer to FDMRUV.APL
C
C CALLED BY:    (Subroutine call tree:)
C               - FDM.FOR
C                - FDMLIN.FOR
C                 - FDMCAR.VFC
C                  - APSFDMCAR.FOR
C                   - FDMRUV.APL
C                    - APSFDMRUV.FOR
C                     - FDMRUVAPS.FOR
C
C EXTERNALS:    None
C
C       REVISIONS:
C AUTHOR:  a.j.h.                                     DATE:  4/11/89
C DESCRIPTION:
C    The single vector loop was split into 4 loop for the CRAY. This split
C the vector dependent part of the calculations from the vectorizable parts
C-------------------------------------------------------------------------------
c Mod: PCH, 8 June 2004, Check for divide by zero.  Gamma can become zero!
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

        INTEGER m
        REAL    um1, vm1
C
c****   If you get a divide by zero fault, it probably here.  g = gamma,
c****   which can become zero if the velocity doesn't increase.  I hate
c****   to put this check in, but I can't tell you how much time it took
c****   me to find this quirk.
        DO 50  m = 1,mx
           apscr(m) = 1./g(m) - 2.
           IF( g(m) .EQ. 0. ) THEN
               PRINT *,' FDMIGR fault - divide by zero.'
               PRINT *,' Some velocity is not increasing.'
               STOP
           ENDIF
   50   CONTINUE
C
        um1 = 0.
        DO 100 m = 1, mx
          u(m) = 1. / (apscr(m) - um1)
          um1  = u(m)
  100   CONTINUE
C
        DO 150 m = 1, mx
           apscr(m) = u(m) * r(m)/g(m)
  150   continue
c
        vm1 = 0.
        DO 200 m = 1, mx
          v(m) = -u(m) * vm1 + apscr(m)
          vm1  = v(m)
  200   CONTINUE
c       call dbgap(1)
        RETURN
        END                                                             ! of VSRUVAPS
C
C==============================================================================
C
        SUBROUTINE vspn1aps (pn, u, v, pn1, mx)
        REAL    pn(mx), u(mx), v(mx), pn1(mx)
        INTEGER mx
C-------------------------------------------------------------------------------
C$R     FDM: Recursively calculate the next time slice, P(n+1,j). (Simulator)
C       VERITAS SOFTWARE LTD.                   CALGARY, ALBERTA, CANADA
C
C AUTHOR:       N.M.M.                          DATE: March, 1985
C
C ENTRY NAMES:  FDMPN1APS
C
C FUNCTION:     Refer to FDMPN1.VFC
C
C PARAMETERS:   Refer to FDMPN1.VFC
C
C CALLED BY:    (Tree of calls to this routine:)
C               - FDMIEX
C                - FDMLIN
C                 - FDMCAR.VFC
C                  - APSFDMCAR.FOR
C                   - FDMPN1.APL
C                    - APSFDMPN1.FOR
C                     - FDMPN1APS.FOR
C
C EXTERNALS:    None
C
C ERRORS & LIMITATIONS: None
C
C REVISIONS:
C AUTHOR: a.j.h.                                     DATE:  4/11/89
C DESCRIPTION:  The single do loop was split into two to allow vectorization
C on the CRAY
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

C
      INTEGER m
C
      apscr(mx+1) = 0.
c
      DO 100 m = mx, 1, -1
          apscr(m) = v(m) - u(m)*apscr(m+1)
  100 CONTINUE
c
      DO 200 m = mx, 1, -1
          pn1(m) = pn(m) + apscr(m)
  200 CONTINUE
c     call dbgap(2)
      RETURN
      END                                                               ! of routine VSPN1APS
C
C==============================================================================
C
      subroutine setaux(lslice)
      integer lslice
C-------------------------------------------------------------------------------
C   Setaux is responsible for setting up the auxilary AP scratch array APSCR.
C This array holds intermediate results between time slices as well as scratch
C results during calculation.
C   This routine must be called once a Tau step so as to initialize the j+2 time
C slicesat auxscr5/6 to zero.
C
C In
C   lslice : The length of a time slice
C
C  Located at:
C  auxscr1 - Scratch time slice
C  auxscr2 - Scratch time slice
C  auxscr3 - Holds    P(n+1,j+1) - P(n,j+1)
C  auxscr4 - Holds T*(P(n+1,j+1) - P(n,j+1))
C  auxscr5 - Holds    P(n+1,j+2) - P(n,j+2)
C  auxscr6 - Holds T*(P(n+1,j+2) - P(n,j+2))
C-------------------------------------------------------------------------------
C
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

      logical first
      save    first
      data    first /.TRUE./
C
      if (first) then
        first = .FALSE.
        if (lslice.gt.MAXNX) then
          print *,' Size of time slice: ',lslice,
     $            ' exceeds Maximum allowed ', MAXNX
          STOP
        endif
C
        auxscr1 = 1                                                     ! offset to allow for zero pads
        auxscr2 = auxscr1 + lslice
        auxscr3 = auxscr2 + lslice
        auxscr4 = auxscr3 + lslice
        auxscr5 = auxscr4 + lslice
        auxscr6 = auxscr5 + lslice
      endif
C
      do 10 i = auxscr5, auxscr6 + lslice - 1
        apscr(i) = 0.
  10  continue
      return
      end
C
C==============================================================================
C
      subroutine TCONV(a,c,n)
      real    a(0:n-1), c(0:n-1)
      integer n
c-------------------------------------------------------------------------------
c This routines does the 3 pt convolution horizontal convolution (-1,2,-1) for
c FDM. This is the CRAY version which computes it as a single vector loop.
c
c IN:
c   n   : length of data to be convolved
c   a() : array to be convolved.
c OUT
c   c() : output array
c-------------------------------------------------------------------------------
c
      DO 100 ii = 0, n-1
        c(ii) = -a(ii) + 2. * a(ii+1) - a(ii+2)
  100 CONTINUE
      return
      end
C
C==============================================================================
C
      subroutine blkmov(a,c,n)
      integer a,c,n
c-------------------------------------------------------------------------------
c This routine moves data within the AP scratch array.
c   IN
c    a  : location of start of data to shift
c    n  : Number of data to shift
c  OUT
c   c   : Location to shift to
c
c   The CRAY is told to ignore vector dependencies. There should OK for a
c straight shift of the data.
c
c-------------------------------------------------------------------------------
C Include file VapCry.inc
C Used to by Low Level AP simulator routines
C Define a common block which is used to simulates the AP120-B data memory
C which has the size of 32K 32-bit floating point words.
C
      integer SZAPMEM, MAXNX, NAUX, SZAPSCR
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (MAXNX   =  16384)                                       ! Max. no of traces as given in FDMIEX
      parameter (NAUX    =     6)                                       ! No. of time slices in APSCR
      parameter (SZAPSCR = NAUX*MAXNX)                                  ! Scratch array size

      real         apdata(0:SZAPMEM-1)
      integer     iapdata(0:SZAPMEM-1)
      common /APMEM/ apdata                                             ! Veritas called this ap120bmd
      equivalence (APDATA,IAPDATA)
c
      real     apscr(0:SZAPSCR)
      integer iapscr(0:SZAPSCR)
      common/SCRAP/apscr
      equivalence (apscr,iapscr)
c
c Define some offsets into the scratch array. These are set by SETAUX
      integer
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
      common/AUXCM/
     $   auxscr1, auxscr2, auxscr3, auxscr4, auxscr5, auxscr6
C
C Define another common block which simulates the 16 S_PAD in the AP120-B
C
        integer apsp(0:15)
        common/AP120BSP/apsp

CDIR$ IVDEP
      do 100 ii = 0,n-1
        apscr(c+ii) = apscr(a+ii)
  100 continue
      return
      end


! AeroBulk / 2016 / L. Brodeau (brodeau@gmail.com)
! https://sourceforge.net/p/aerobulk
!
!   When using AeroBulk to produce scientific work, please acknowledge with the following citation:
!
!   Brodeau, L., B. Barnier, S. Gulev, and C. Woods, 2016: Climatologically
!   significant effects of some approximations in the bulk parameterizations of
!   turbulent air-sea fluxes. J. Phys. Oceanogr., doi:10.1175/JPO-D-16-0169.1.
!
!
MODULE mod_aerobulk

   USE mod_const
   USE mod_aerobulk_compute

   IMPLICIT NONE

   PRIVATE

   PUBLIC :: AEROBULK_MODEL

CONTAINS

   SUBROUTINE aerobulk_init(psst, pt, pq, pU, pV, pslp)

      !! 1. Check on correct size for array
      !! 2. Set the official 2D shape of the problem jpi,jpj (saved and shared via mod_const)
      !! 3. Check the values in the array make sense
      !! 4. Give some info

      REAL(wp), DIMENSION(:,:), INTENT(in)  :: psst, pt, pq, pU, pV, pslp

      INTEGER :: ni, nj

      PRINT *, ''
      PRINT *, 'aerobulk_init'

      ! 1.
      jpi = size(psst,1) ; jpj = size(psst,2)

      ! 2.
      ni = size(pt,1)  ; nj = size(pt,2)
      IF ( (ni /= jpi).OR.(ni /= jpi) ) THEN
         PRINT *, 'ERROR: aerobulk_init => SST and t_air arrays do not agree in shape!' ; STOP
      END IF

      ! 3.
      ni = SIZE(pq,1)  ; nj = SIZE(pq,2)
      IF ( (ni /= jpi).OR.(ni /= jpi) ) THEN
         PRINT *, 'ERROR: aerobulk_init => SST and q_air arrays do not agree in shape!' ; STOP
      END IF

      ni = SIZE(pU,1)  ; nj = SIZE(pU,2)
      IF ( (ni /= jpi).OR.(ni /= jpi) ) THEN
         PRINT *, 'ERROR: aerobulk_init => SST and U arrays do not agree in shape!' ; STOP
      END IF

      ni = SIZE(pV,1)  ; nj = SIZE(pV,2)
      IF ( (ni /= jpi).OR.(ni /= jpi) ) THEN
         PRINT *, 'ERROR: aerobulk_init => SST and V arrays do not agree in shape!' ; STOP
      END IF

      ni = SIZE(pslp,1)  ; nj = SIZE(pslp,2)
      IF ( (ni /= jpi).OR.(ni /= jpi) ) THEN
         PRINT *, 'ERROR: aerobulk_init => SST and SLP arrays do not agree in shape!' ; STOP
      END IF

      PRINT *, '    *** jpi and jpj set to ', jpi, jpj ; PRINT *, ''
      PRINT *, '    *** nb_itt is set to ', nb_itt

      l_first_call = .false.

      PRINT *, ''

   END SUBROUTINE aerobulk_init

   SUBROUTINE aerobulk_bye()
      PRINT *, ''
      PRINT *, 'aerobulk_bye'
      PRINT *, ''
   END SUBROUTINE aerobulk_bye

   SUBROUTINE AEROBULK_MODEL( calgo, zt, zu, sst, t_zt, &
      &                       q_zt, U_zu, V_zu, slp,    &
      &                       QL, QH, Tau_x, Tau_y,     &
      &                       Niter, rad_sw, rad_lw )
      !!======================================================================================
      !!
      !! INPUT :
      !! -------
      !!    *  calgo: what bulk algorithm to use => 'coare'/'ncar'/'ecmwf'
      !!    *  zt   : height for temp. & spec. hum. of air (usually 2 or 10) [m]
      !!    *  zu   : height for wind (usually 10)                           [m]
      !!    *  sst  : SST                                                    [K]
      !!    *  t_zt : potential air temperature at zt                        [K]
      !!    *  q_zt : specific humidity of air at zt                         [kg/kg]
      !!    *  U_zu : zonal wind speed at zu                                 [m/s]
      !!    *  V_zu : meridional wind speed at zu                            [m/s]
      !!    *  slp  : mean sea-level pressure                                [Pa] ~101000 Pa
      !!
      !! OUTPUT :
      !! --------
      !!    *  QL     : Latent heat flux                                     [W/m^2]
      !!    *  QH     : Sensible heat flux                                   [W/m^2]
      !!    *  Tau_x  : zonal wind stress                                    [N/m^2]
      !!    *  Tau_y  : zonal wind stress                                    [N/m^2]
      !!
      !! OPTIONAL :
      !! ----------
      !!    * Niter  : number of itterattions in the bulk algorithm (default is 4)
      !!    *  rad_sw : downwelling shortwave radiation at the surface (>0)   [W/m^2]
      !!    *  rad_lw : downwelling longwave radiation at the surface  (>0)   [W/m^2]
      !!
      !!============================================================================
      CHARACTER(len=*),         INTENT(in)  :: calgo
      REAL(wp),                 INTENT(in)  :: zt, zu
      REAL(wp), DIMENSION(:,:), INTENT(in)  :: sst, t_zt, q_zt, U_zu, V_zu, slp
      REAL(wp), DIMENSION(:,:), INTENT(out) :: QL, QH, Tau_x, Tau_y
      REAL(wp), DIMENSION(:,:), INTENT(in), OPTIONAL :: rad_sw, rad_lw

      INTEGER, INTENT(in), OPTIONAL :: Niter

      IF ( PRESENT(Niter) ) nb_itt = Niter  ! Updating number of itterations (define in mod_const)

      IF ( l_first_call ) CALL aerobulk_init(sst, t_zt, q_zt, U_zu, V_zu, slp)

      IF( PRESENT(rad_sw) .AND. PRESENT(rad_lw) ) THEN

         CALL aerobulk_compute(calgo, zt, zu, sst, t_zt, &
            &                  q_zt, U_zu, V_zu, slp,    &
            &                  QL, QH, Tau_x, Tau_y ,    &
            &                  rad_sw=rad_sw, rad_lw=rad_lw )

      ELSE

         CALL aerobulk_compute(calgo, zt, zu, sst, t_zt, &
            &                  q_zt, U_zu, V_zu, slp,    &
            &                  QL, QH, Tau_x, Tau_y)

      END IF

      IF ( l_last_call ) CALL aerobulk_bye()

   END SUBROUTINE aerobulk_model

END MODULE mod_aerobulk


!> @file
!!  Fake routine when gemmsy_double is not activated
!! @author
!!    Copyright (C) 2010-2011 BigDFT group
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS

!>  Fake routine when gemmsy_double is not activated
subroutine gemmsy_double(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,y,ldy)
  use wrapper_linalg
  implicit none
  character(len=1), intent (in) :: transa, transb
  integer, intent(in) :: m, n, k, lda, ldb, ldy
  real(kind=8), intent(in) :: alpha,beta
  real(kind=8), intent(in) :: a
  real(kind=8), intent(in) :: b
  real(kind=8), intent(inout) :: y
  call gemm_double(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,y,ldy)

END SUBROUTINE gemmsy_double