c
c     only works with full 3N parameters
c
c
      SUBROUTINE ef(optinp, ind, n, ierr)
C
**********************************************************************
*
*   EF IS A QUASI NEWTON RAPHSON OPTIMIZATION ROUTINE BASED ON
*      Jacs Simons P-RFO algorithm as implemented by Jon Baker
*      (J.COMP.CHEM. 7, 385). Step scaling to keep length within
*      trust radius is taken from Culot et al. (Theo. Chim. Acta 82, 189)
*      The trust radius can be updated dynamically according to Fletcher.
*      Safeguards on valid step for TS searches based on actual/predicted
*      function change and change in TS mode are own modifications
*
c     Created:  Feb. 2002 by Yan Zhao
c               Adapted from the NEWT routines in multilevel and EF routine 
c                 in mopac5.09mn and POLYRATE.
c     Revised:
c     Purpose:  To perform EF optimization in Multilevel
c        For each iteration the gradient is recalculated and the hessian
c        may or may not be depending on HREC as specified in the input
c     
c     Called by:  mlohook
c     Calls:  optghk, opthhk,eformd,efovlp 
c
c     Variables defined here:  none.
c
*
*  Current version implementing combined NR, P-RFO and QA algorithm
*      together with thrust radius update and step rejection was
*      made october 1992 by F.Jensen, Odense, DK
*
**********************************************************************
C
c
      use files, only : outfile
      use input, only : mlopt, mlinp
      use optimize, only : ener, grad, hess
      
      implicit double precision (A-H,O-Z) 
c
      integer            ierr
      type (mlopt)    :: optinp
      logical         :: check
      DATA ANGSAU  /1.8897265D0/
c
      integer  idorec, nrecal, n3tm, n, ind(n)
      integer  jrank, its,  fail, i, j, status, k
      double precision EIGVAL(n)
      double precision, dimension(:,:), allocatable :: hessin,oldhss
      double precision, dimension(:,:), allocatable ::oldu
      double precision, dimension(:), allocatable ::TVEC,SVEC,
     * FX,HESSC,oldfx,oldeig,ooldf 
       double precision	 it75, tmsix, zero, angsau, one, tmtwo 
       double precision tmone, two, oldf, olde, oolde, odmaxion
       double precision odd, u, d, dd, skal, xlamd0, xlamd 
       integer icalcn,mode, nvar, iprnt, negreq  
      double precision   oldgn, rmx, ddot, ddtd, gnfina, lamda,lamda0
      double precision  temp, ratio, deact, gntest
      double precision  ss, xtmp, funct, dds, odmax,ddl
      double precision  gmin,  ldump, demin1, four, three
      double precision  pt5, pt25, ntime, tol1, dmax,ttmp
      double precision  osmin, tol2, dmin, depre, frodo
      integer ij, neg, imode, iflepo, last
      integer igthes, iloop, mxstep, ireclc

c
      double precision, dimension(:), allocatable ::  grado,xparam,
     * dxsav,scr,SCR2,UC,DDx                                               030Z
       DATA  ICALCN,ZERO,ONE,TWO    /0,0.D0,1.D0,2.D0/
       DATA tmone /1.0d-1/, TMTWO/1.0D-2/, TMSIX/1.0D-06/
       data three/3.0d0/, four/4.0d0/, tmfour/0.5D-03/ 
     * pt25/0.25d0/, pt5/0.50d0/, pt75/0.75d0/
       data demin1/2.0d-2/, gmin/5.0d0/, EPS1/1.0d-12/
       DATA  HALF/0.5D0/,  TOLL/1.0D-8/         
       DATA STEP/5.0D-02/, TEN/1.0D+1/, BIG/1.0D+3/,sfix/1.0d+01/
 

      double precision  gtol, h2, gcomp, sum,abgc
C
      COMMON/OPTEF/OLDF(150),D(150),VMODE(150),
     $U(150,150),DD,xlamd,xlamd0,skal,
     $MODE,its,NEGREQ,IPRNT

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.52918d0
      double precision, parameter :: maxstep = 1.0d0
      double precision, parameter :: CKCAL= 627.5 
C
      LOGICAL RESTRT,SCF1,LIMSCF,ts,rscal,frodo1,frodo2
      LOGICAL LUPD,lts,lrjk,lorjk,rrscal,donr,gnmin                      IR0794
      n3tm = 3*mlinp%geom%natoms
C
      allocate (hessin(n,n) )
C	
C
      allocate (TVEC(n3tm),SVEC(n3tm),
     * FX(n3tm),HESSC(n3tm*(n3tm+1)/2),
     * oldfx(n3tm),oldeig(n3tm),DDx(n3tm),
     * oldhss(n3tm,n3tm),oldu(n3tm,n3tm),ooldf(n3tm))
C
c      DIMENSION BB(n3tm,n3tm)
c
      allocate (grado(n3tm),xparam(n3tm), 
     * dxsav(n3tm),scr(n3tm),SCR2(n3tm),UC(n3tm*n3tm))                   03ZY02
c
      fail = 0
      idorec = optinp%hrec
      nrecal = 0
      status = 0
      iprnt=1
c
c  Set up the default convergent values for the energy and derivative
c
      if (optinp%gcomp .le. eps) then
         gtol = 1.0d-7
      else
         gtol = optinp%gcomp
      endif
      if (optinp%niter .lt. 0) goto 300
      h2 = 2.0d0*optinp%dlx2
c
c  Get initial gradient
c
      call optghk
      olde=ener
      gcomp = abs( grad(1) )
      do  i=2, n3tm
         abgc = abs( grad(i) )
         if (gcomp.lt.abgc)  gcomp = abgc
      enddo
c
c  Make initial display of info
c
         do i=1, n3tm
           DDx(i)=0.0000d0 
            D(i) = 0.0000d0
         enddo
         call optdisp(0, mlinp%geom, ener, grad(:n3tm), DDx(:n3tm),
     *           gcomp, gtol)
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.gtol) then
         status = 3
         goto 300
      endif
c
c  Set initial hessian (by hhook if INITHESS is on; I otherwise)
c
       if (optinp%ihunit.eq.1) then 
          call opthhk
        elseif (optinp%ihunit.eq.0) then
         do  i=1, n3tm
            do  j=1, n3tm
               hess(i,j) = 0.0d0
            enddo
            hess(i,i) = optinp%hscale
         enddo
      endif
c
c  Get the small hessian
c
      do i=1, n
         do j=1, n
            hessin(i,j) = hess(ind(i),ind(j))
         enddo
      enddo
      
C
      NVAR = n
C
C Get the parameters which will be optimized
C
      DO i = 1, NVAR
        xparam(i)=mlinp%geom%aucoord(ind(i))
        grado(i)=grad(ind(i))
      ENDDO
C
       write (outfile,*) 
       WRITE (outfile,*) '================ EF =================='
C
C      Zero out some variables
C
       do i=1, n3tm
        EIGVAL(I)=0.0d0
         FX(I)=0.0d0
       enddo
       n3tm = 3*mlinp%geom%natoms 

C     
      ODD=0.0d0
      ODMAX=0.0d0
      OOLDE=0.0d0
C
C     GET ALL INITIALIZATION DATA
C
      LDUMP=0
      its=0
      nrecal=0
      LAST=0
      NTIME=0
      ILOOP=1
C
C     FOR minimum search
C
      IF(optinp%iop.lt.4) THEN
         MODE=0
         IGTHES=0
         NEGREQ=0
         optinp%ddmax=optinp%ddmax/angtoau
C
C     FOR TS search
C
      ELSE
         MODE=1
         IGTHES=1
         NEGREQ=1
        optinp%ddmax = optinp%ddmaxts/angtoau
      ENDIF
c  
c Initialize the rest of options
c
      ireclc=idorec
       rrscal=.false.
      donr=.true.
      gnmin=.false.
      MXSTEP=optinp%niter
      DMIN=1.0D-3
      DMAX=0.2D0
       TOL1=gtol
       TOL2=gtol
c     
      LTS = .false.
      IF (NEGREQ.EQ.1) LTS = .true.
      LORJK = .false.
c
c     osmin is smallest step for which a ts-mode overlap less than omin
c     will be rejected. for updated hessians there is little hope of
c     better overlap by reducing the step below 0.005. for exact hessian
c     the overlap should go toward one as the step become smaller, but
c     don't allow very small steps 
      osmin=0.005d0
      if(ireclc.eq.1) osmin=0.001d0
C
C     START OF MAIN LOOP
C     WE NOW HAVE GRADIENTS AND A HESSIAN. IF THIS IS THE FIRST
C     TIME THROUGH DON'T UPDATE THE HESSIAN. FOR LATER LOOPS ALSO
C     CHECK IF WE NEED TO RECALCULATE THE HESSIAN
   10 CONTINUE
c     store various things for possibly omin rejection
      do i=1,nvar
         oldfx(i)=fx(i)
         ooldf(i)=oldf(i)
         oldeig(i)=eigval(i)
         do  j=1,nvar
           oldhss(i,j)=hessin(i,j)
           oldu(i,j)=u(i,j)
         enddo
      enddo
C
C recalculate hessian
C
       if (nrecal.eq.optinp%hrec .and. its.ne.optinp%niter) then
            nrecal = 0
            write (outfile, 1400)
1400        format(/,'Hessian recalculated.')
            call opthhk
C
c  Get  the small hessian
c
          do  i=1, n   
            do j=1, n
                 hessin(i,j) = hess(ind(i),ind(j))
            enddo
          enddo 
       endif
C
C     update the hessian
c
      IF (nrecal.ne.0) then
        IF (optinp%iupd.EQ.0)WRITE(outfile,2090)
        IF (optinp%iupd.EQ.1)WRITE(outfile,2080)
        IF (optinp%iupd.EQ.2)WRITE(outfile,2120)
       DO I=1,NVAR
         TVEC(I)=ZERO
       ENDDO
       DO J=1,NVAR
         DO I=1,NVAR
            TVEC(I)=TVEC(I) + HESSIN(I,J)*D(J)
         ENDDO
      ENDDO
C
      IF(optinp%iupd .EQ. 1) THEN
C
C   (I) POWELL UPDATE
C
         DO I=1,NVAR
            TVEC(I)=GRADO(I)-OLDF(I)-TVEC(I)
            SVEC(I)=GRADO(I)-OLDF(I)
         ENDDO
         DDS=DD*DD
         DDTD=DDOT(NVAR,TVEC,1,D,1)                                       IR0494
         DDTD=DDTD/DDS
C
         DO  I=2,NVAR
            DO J=1,I-1
               TEMP=TVEC(I)*D(J) + D(I)*TVEC(J) - D(I)*DDTD*D(J)
               HESSIN(I,J)=HESSIN(I,J)+TEMP/DDS
               HESSIN(J,I)=HESSIN(I,J)
            ENDDO
         ENDDO
         DO I=1,NVAR
            TEMP=D(I)*(2.0D0*TVEC(I) - D(I)*DDTD)
            HESSIN(I,I)=HESSIN(I,I)+TEMP/DDS
         ENDDO
C
       ENDIF
       IF (optinp%iupd.EQ.2) THEN
C
C  (II) BFGS UPDATE
C
         DO I=1,NVAR
            SVEC(I)=GRADO(I)-OLDF(I)
         ENDDO
         DDS=DDOT(NVAR,SVEC,1,D,1)                                       IR0494
C
         DDTD=DDOT(NVAR,D,1,TVEC,1)                                      IR0494
C
         DO I=2,NVAR
            DO  J=1,I-1
               TEMP= (SVEC(I)*SVEC(J))/DDS - (TVEC(I)*TVEC(J))/DDTD
               HESSIN(I,J)=HESSIN(I,J)+TEMP
               HESSIN(J,I)=HESSIN(I,J)
            ENDDO
         ENDDO
         DO I=1,NVAR
            TEMP= (SVEC(I)*SVEC(I))/DDS - (TVEC(I)*TVEC(I))/DDTD
            HESSIN(I,I)=HESSIN(I,I)+TEMP
         ENDDO
       ENDIF

 2080  FORMAT(/,5X,'HESSIAN IS BEING UPDATED USING THE POWELL UPDATE',/)
 2090  FORMAT(/,5X,'HESSIAN IS NOT BEING UPDATED',/)
c 100 FORMAT(5X,'WARNING! HEREDITARY POSITIVE DEFINITENESS ENDANGERED')
c 110 FORMAT(5X,'UPDATE SKIPPED THIS CYCLE')
 2120  FORMAT(/,5X,'HESSIAN IS BEING UPDATED USING THE BFGS UPDATE',/)
      ENDIF
      WRITE(outfile,91) 
      WRITE(outfile,98) (XPARAM(I),I=1,NVAR) 
91    format (/5x,'XPARAM to be optimized: ')
98    format(t20,d15.8,t40,d15.8,t60,d15.8) 
C
C        PRINT RESULTS IN CYCLE
C
      GNFINA= GRAD(1)
      DO i = 2, n3tm
        IF (ABS(GRAD(i)).GE.GNFINA) GNFINA = ABS(GRAD(i))
      ENDDO
C
C        TEST FOR CONVERGENCE
C
      RMX = GRAD(1)
      DO I = 2,NVAR
        IF (ABS(GRAD(I)).GE.RMX) RMX = ABS(GRAD(I))
      ENDDO
c      RMX=SQRT(DDOT(NVAR,GRAD,1,GRAD,1))                                 IR0494
      IF (GNFINA.LT.TOL2) then
      status=1
      GOTO 250
      endif
c
c count steps
c
      nrecal=nrecal+1
      its=its+1
      OLDE  = ener
      oldgn = rmx
      DO I=1,NVAR
         OLDF(I)=GRADO(I)
      enddo
C
C     Diagonalize Hessian
C
      IJ=0
      DO I=1,NVAR
         DO J=1,I
            IJ=IJ+1
            HESSC(IJ)=HESSIN(J,I)
         ENDDO
      ENDDO  
      CALL RSP(HESSC,NVAR,NVAR,EIGVAL,UC)
      IJ=0
      DO I=1,NVAR
         IF (ABS(EIGVAL(I)).LT.TMSIX) EIGVAL(I)=ZERO
         DO J=1,NVAR
            IJ=IJ+1
            U(J,I)=UC(IJ)
         ENDDO
      ENDDO
c      WRITE(outfile,*)'eigenvectors'
c       WRITE(outfile,910)(U(I,1),I=1,NVAR)
c      do j=2, NVAR
c       WRITE(outfile,910)(U(I,j),I=1,NVAR)
c      enddo

c
      IF (MXSTEP.EQ.0) its=0
      IF (MXSTEP.EQ.0) GOTO 280                                                 
c
      NEG=0                                                                     
      DO I=1,NVAR                                                           
         IF (EIGVAL(I) .LT. ZERO) NEG=NEG+1                                     
      ENDDO                                                                  
  110 FORMAT(/,10X,'HESSIAN HAS',I3,' NEGATIVE EIGENVALUE(S)',6f7.1,/)
c     
       
       DO I=1,NVAR
                                 
         FX(I)=DDOT(NVAR,U(1,I),1,GRADO,1)                                IR0494
          if (abs(eigval(i)).le.zero) fx(i)=zero
       enddo 
c
c     form geometry step d by either pure NR,P-RFO or QA algorithm
c     
130   MAXIT=999  
      NUMIT=0    
      SKAL=ONE
      ts=lts
      rscal=rrscal
      it=0
      jt=1
      if (its .eq. 1) then
        do i=1, nvar
          vmode(i) = u(i,1)
         enddo
       endif
      if (ts) then
       IF(MODE.NE.0) THEN
       CALL EFOVLP(dmax,osmin,NEWMOD,NVAR,lorjk)
       endif
      if (lorjk) go to 2002 
C
C  ON RETURN FROM EFOVLP, NEWMOD IS THE TS MODE
C
      IF(NEWMOD.NE.MODE .and. iprnt.ge.1)then
       WRITE(outfile,1000) MODE,NEWMOD
1000  FORMAT(5X,'WARNING! MODE SWITCHING. WAS FOLLOWING MODE ',I3,
     $       ' NOW FOLLOWING MODE ',I3)
       MODE=NEWMOD
       IT=MODE
      ELSE
       IT=1
      endif
      write (outfile,*) '    Eigenvalue of Hessian'

      write (outfile,98) (eigval(i),i=1,n)
       eigit=eigval(it)
       WRITE(outfile,900)IT,EIGIT
       write(outfile,910)
      WRITE(outfile,98)(U(I,IT),I=1,NVAR)
900    FORMAT(/,5X,'TS Mode is Number',I3,' With Eigenvalue ',8F9.6)
910    format( 5X,'And Component of Eigenvector are ')

      endif
      if (it.eq.1) jt=2
      eone=eigval(jt)
      ssmin=max(abs(eone)*eps1,(ten*eps1))
      ssmax=max(big,abs(eone))
      ssmax=ssmax*big
      sstoll=toll
      d2max=dmax*dmax
C  SOLVE ITERATIVELY FOR LAMDA
C  INITIAL GUESS FOR LAMDA IS ZERO EXCEPT NOTE THAT
C  LAMDA SHOULD BE LESS THAN EIGVAL(1)
C  START BY BRACKETING ROOT, THEN HUNT IT DOWN WITH BRUTE FORCE BISECT.
C
         frodo1=.false.
         frodo2=.false.
         LAMDA=ZERO
         lamda0=zero
      if (ts .and. eigit.lt.zero .and. eone.ge.zero .and. donr) then
         write(outfile,*)
         write(outfile,*)'    TS Search, Correct Hessian, try NR'
         goto 776
      endif
      if (.not.ts .and. eone.ge.zero .and. donr) then
         write(outfile,*)'     Min Search, Correct Hessian, try NR'
         goto 776
      endif
5     if (ts) then
         lamda0=eigval(it)+sqrt(eigval(it)**2+four*fx(it)**2)
         lamda0=lamda0*half
         WRITE(outfile,1030) LAMDA0
      endif
         SSTEP = STEP
         IF(EONE.LE.ZERO) LAMDA=EONE-SSTEP
         IF(EONE.GT.ZERO) SSTEP=EONE
         BL = LAMDA - SSTEP
         BU = LAMDA + SSTEP*HALF
20       FL = ZERO
         FU = ZERO
         DO 30 I = 1,NVAR
            if (i.eq.it) goto 30
            FL   = FL + (FX(I)*FX(I))/(BL-EIGVAL(I))
            FU   = FU + (FX(I)*FX(I))/(BU-EIGVAL(I))
30       continue 
         FL = FL - BL
         FU = FU - BU
         IF (FL*FU .LT. ZERO) GOTO 40
         BL = BL - (EONE-BL)
         BU = BU + HALF*(EONE-BU)
         IF (BL.LE.-SSMAX) then
            BL = -SSMAX
            frodo1=.true.
         endif
         IF (abs(eone-bu).le.ssmin) then
            BU = EONE-SSMIN
            frodo2=.true.
         endif
         IF (frodo1.and.frodo2) THEN
            WRITE(outfile,*)'NUMERICAL PROBLEMS IN BRACKETING LAMDA',
     $                    EONE,BL,BU,FL,FU
            write(outfile,*)' going for fixed step size.'
            goto 450
         ENDIF
         GOTO 20

40       CONTINUE
         NCNT = 0
         XLAMDA = ZERO
50       CONTINUE
         FL = ZERO
         FU = ZERO
         FM = ZERO
         LAMDA = HALF*(BL+BU)
         DO 60 I = 1,NVAR
            if (i.eq.it) goto 60
            FL   = FL + (FX(I)*FX(I))/(BL-EIGVAL(I))
            FU   = FU + (FX(I)*FX(I))/(BU-EIGVAL(I))
            FM   = FM + (FX(I)*FX(I))/(LAMDA-EIGVAL(I))
60       CONTINUE
         FL = FL - BL
         FU = FU - BU
         FM = FM - LAMDA
         IF (ABS(XLAMDA-LAMDA).LT.sstoll) GOTO 776
         NCNT = NCNT + 1
         IF (NCNT.GT.1000) THEN
            WRITE(outfile,*)'TOO MANY ITERATIONS IN LAMDA BISECT',
     $                    BL,BU,LAMDA,FL,FU
            STOP
         ENDIF
         XLAMDA = LAMDA
         IF (FM*FU.LT.ZERO) BL = LAMDA
         IF (FM*FL.LT.ZERO) BU = LAMDA
         GOTO 50
C
 776   if (iprnt.ge.1) WRITE(outfile,1031) LAMDA
C   
C  CALCULATE THE STEP
C   
      DO  I=1,NVAR
      D(I)=ZERO
      enddo
      DO I=1,NVAR
      if (lamda.eq.zero .and. abs(eigval(i)).lt.tmtwo) then
      temp=zero
      else
      TEMP=FX(I)/(LAMDA-EIGVAL(I))
      endif
      if (i.eq.it) then
      TEMP=FX(IT)/(LAMDA0-EIGVAL(IT))
      endif
      if (iprnt.ge.5) write(outfile,*)'formd, delta step',i,temp
       DO J=1,NVAR
       D(J)=D(J)+TEMP*U(J,I)
       enddo
      enddo
      DD=SQRT(DDOT(NVAR,D,1,D,1))                                         IR0494
      if(lamda.eq.zero .and. lamda0.eq.zero .and.iprnt.ge.1)
     1 write(outfile,777)dd
      write (outfile,98) (d(ii),ii=1,nvar) 
777   format(5x,'Pure NR-step Has Length',f10.5,' and Step Vector is:')
      if(lamda.ne.zero .and. lamda0.ne.-lamda .and.iprnt.ge.1)
     1write(outfile,778)dd
778   format(5x,'P-RFO-step   has length',f10.5)
      if (dd.lt.(dmax+tmsix)) then
         xlamd=lamda
         xlamd0=lamda0
         go to 2002 
      endif
      if (lamda.eq.zero .and. lamda0.eq.zero) goto 5
      if (rscal) then
         SKAL=DMAX/DD
         DO I=1,NVAR
            D(I)=D(I)*SKAL
         enddo
         DD=SQRT(DDOT(NVAR,D,1,D,1))                                      IR0494
         IF(IPRNT.GE.1)WRITE(outfile,1777)SKAL
1777      FORMAT(5X,'CALCULATED STEP SIZE TOO LARGE, SCALED WITH',F9.5)
         xlamd=lamda
         xlamd0=lamda0
         go to 2002 
      endif
450      LAMDA=ZERO
         frodo1=.false.
         frodo2=.false.
         SSTEP = STEP
         IF(EONE.LE.ZERO) LAMDA=EONE-SSTEP
         if (ts .and. -eigit.lt.eone) lamda=-eigit-sstep
         IF(EONE.GT.ZERO) SSTEP=EONE
         BL = LAMDA - SSTEP
         BU = LAMDA + SSTEP*HALF
520      FL = ZERO
         FU = ZERO
         DO 530 I = 1,NVAR
            if (i.eq.it) goto 530
            FL   = FL + (FX(I)/(BL-EIGVAL(I)))**2
            FU   = FU + (FX(I)/(BU-EIGVAL(I)))**2
530      CONTINUE
         if (ts) then
            FL   = FL + (FX(IT)/(BL+EIGVAL(IT)))**2
            FU   = FU + (FX(IT)/(BU+EIGVAL(IT)))**2
         endif
         FL = FL - d2max
         FU = FU - d2max
         IF (FL*FU .LT. ZERO) GOTO 540
         BL = BL - (EONE-BL)
         BU = BU + HALF*(EONE-BU)
         IF (BL.LE.-SSMAX) then
            BL = -SSMAX
            frodo1=.true.
         endif
         IF (abs(eone-bu).le.ssmin) then
            BU = EONE-SSMIN
            frodo2=.true.
         endif
         IF (frodo1.and.frodo2) THEN
            WRITE(outfile,*)'NUMERICAL PROBLEMS IN BRACKETING LAMDA',
     $                    EONE,BL,BU,FL,FU
            write(outfile,*)' going for fixed level shifted NR step...'
c           both lamda searches failed, go for fixed level shifted nr
c           this is unlikely to produce anything useful, but maybe we're lucky
            lamda=eone-sfix
            lamda0=eigit+sfix
            rscal=.true.
            goto 776
         ENDIF
         GOTO 520

540      CONTINUE
         NCNT = 0
         XLAMDA = ZERO
550      CONTINUE
         FL = ZERO
         FU = ZERO
         FM = ZERO
         LAMDA = HALF*(BL+BU)
         DO 560 I = 1,NVAR
            if (i.eq.it) goto 560
            FL   = FL + (FX(I)/(BL-EIGVAL(I)))**2
            FU   = FU + (FX(I)/(BU-EIGVAL(I)))**2
            FM   = FM + (FX(I)/(LAMDA-EIGVAL(I)))**2
560      CONTINUE
         if (ts) then
            FL   = FL + (FX(IT)/(BL+EIGVAL(IT)))**2
            FU   = FU + (FX(IT)/(BU+EIGVAL(IT)))**2
            FM   = FM + (FX(IT)/(LAMDA+EIGVAL(IT)))**2
         endif
         FL = FL - d2max
         FU = FU - d2max
         FM = FM - d2max
         IF (ABS(XLAMDA-LAMDA).LT.sstoll) GOTO 570
         NCNT = NCNT + 1
         IF (NCNT.GT.1000) THEN
            WRITE(outfile,*)'TOO MANY ITERATIONS IN LAMDA BISECT',
     $                    BL,BU,LAMDA,FL,FU
            STOP
         ENDIF
         XLAMDA = LAMDA
         IF (FM*FU.LT.ZERO) BL = LAMDA
         IF (FM*FL.LT.ZERO) BU = LAMDA
         GOTO 550
C   
570      CONTINUE
         lamda0=-lamda
         rscal=.true.
         goto 776
C   
1030  FORMAT(5X,'Lamda that maximizes along ts modes =   ',F15.5)
1031  FORMAT(5X,'Lamda that minimizes along all  modes =  ',F15.5/)
c
c     if lorjk is true, then ts mode overlap is less than omin, reject prev step
c
2002     if (lorjk) then
         if (iprnt.ge.1)write(outfile,*)'     Now undoing previous step'
         dmax=odmax
         dd=odd
         olde=oolde
         do i=1,nvar
            fx(i)=oldfx(i)
            oldf(i)=ooldf(i)
            eigval(i)=oldeig(i)
            do j=1,nvar
               hessin(i,j)=oldhss(i,j)
               u(i,j)=oldu(i,j)
            enddo
         enddo
         DO I=1,NVAR
            XPARAM(I)=XPARAM(I)-D(I)
         ENDDO
         dmax=min(dmax,dd)/two
         odmax=dmax
         odd=dd
         its=its-1
         if (dmax.lt.dmin) goto 230
      if (iprnt.ge.1)write(outfile,*)
     1'      Finish undoing, now going for new step'
         goto 130
      endif
C
C  FORM NEW TRIAL XPARAM AND GEO
C
      ddl=0.0
      do i=1, nvar
       ddl=d(i)*d(i)+ddl
      enddo
      ddl=sqrt(ddl)
      write  (outfile,*)
      if (ddl .lt. tmfour) then
       scale=tmfour/ddl
       dd=tmfour
      do i=1, nvar
       d(i)=d(i)*scale
      enddo
      endif
      DO I=1,NVAR
         XPARAM(I)=XPARAM(I)+D(I)
      ENDDO
C
C     COMPARE PREDICTED E-CHANGE WITH ACTUAL
C
      depre=zero
      imode=1
      if (mode.ne.0)imode=mode
      do i=1,nvar
         xtmp=xlamd
         if (lts .and. i.eq.imode) xtmp=xlamd0
         if (abs(xtmp-eigval(i)).lt.tmtwo) then
         ss=zero
         else
         ss=skal*fx(i)/(xtmp-eigval(i))
         endif
         frodo=ss*fx(i) + pt5*ss*ss*eigval(i)
         depre=depre+frodo
      enddo
c88   format(i3,f10.3,f10.6,f10.3,4f10.6)
C
C     GET GRADIENT FOR NEW GEOMETRY 
C
      do i = 1, nvar
        mlinp%geom%aucoord(ind(i))=XPARAM(i)
      enddo
        mlinp%geom%angcoord=mlinp%geom%aucoord*angtoau
      call optghk
       DO i = 1, NVAR
        grado(i)=grad(ind(i))
      ENDDO
C
      FUNCT = ener
c      write (outfile,*) 'New energy = ', Funct,'old = ',olde
c
      IF(GNMIN) GNTEST=SQRT(DDOT(NVAR,GRADO,1,GRADO,1))                   IR0494
      DEACT = FUNCT-OLDE
      RATIO = DEACT/DEPRE
c      if(iprnt.ge.1)WRITE(outfile,170)DEACT,DEPRE,RATIO       
 170   FORMAT(5X,'ACTUAL, PREDICTED ENERGY CHANGE, RATIO',2F10.3,F10.5)
      lrjk=.false.
C     if this is a minimum search, don't allow the energy to raise
      if (.not.lts .and. funct.gt.olde) then
         if (iprnt.ge.1)write(outfile,180)funct,min(dmax,dd)/two
180      format(5x,'Energy raises ',f10.4,' rejecting step, ',
     $             'reducing dmax to',f7.4)
         lrjk=.true.
      endif
      if (gnmin .and. gntest.gt.oldgn) then
         if (iprnt.ge.1)write(outfile,181)gntest,min(dmax,dd)/two
181      format(5x,'gradient norm raises ',f10.4,' rejecting step, ',
     $             'reducing dmax to',f7.4)
         lrjk=.true.
      endif
      if (lts .and. (ratio.lt.optinp%rmin .or. ratio.gt.optinp%rmax)
     $.and. (abs(depre).gt.demin1 .or. abs(deact).gt.demin1)) then
         if (iprnt.ge.1)write(outfile,190)min(dmax,dd)/two
190   format(5x,'Unacceptable ratio,',
     $          ' rejecting step, reducing dmax to',f7.4)
         lrjk=.true.
      endif
      if (lrjk) then
         DO 200 I=1,NVAR
            XPARAM(I)=XPARAM(I)-D(I)
200      CONTINUE
         dmax=min(dmax,dd)/two
         if (dmax.lt.dmin) goto 230
         goto 130
      endif
      IF(IPRNT.GE.1)WRITE(outfile,210) DD
210   FORMAT(/5X,'STEPSIZE USED IS',F9.5)
C
C     POSSIBLE USE DYNAMICAL TRUST RADIUS
      odmax=dmax
      odd=dd
      oolde=olde
      IF (LUPD .and. ( (RMX.gt.gmin) .or.
     $    (abs(depre).gt.demin1 .or. abs(deact).gt.demin1) ) ) THEN
c     Fletcher recommend dmax=dmax/4 and dmax=dmax*2
c     these are are a little more conservative since hessian is being updated
c     don't reduce trust radius due to ratio for min searches
      if (lts .and. ratio.le.tmone .or. ratio.ge.three)
     $    dmax=min(dmax,dd)/two
      if (lts .and. ratio.ge.pt75 .and. ratio.le.(four/three) 
     $                  .and. dd.gt.(dmax-tmsix)) 
     $   dmax=dmax*sqrt(two)
c     allow wider limits for increasing trust radius for min searches
      if (.not.lts .and. ratio.ge.pt5 
     $                  .and. dd.gt.(dmax-tmsix)) 
     $   dmax=dmax*sqrt(two)
c     be brave if  0.90 < ratio < 1.10 ...
      if (abs(ratio-one).lt.tmone) dmax=dmax*sqrt(two)
      dmax=max(dmax,dmin-tmsix)
      dmax=min(dmax,optinp%ddmax)
      ENDIF
c     allow stepsize up to 0.1 in the end-game where changes are less 
c     than demin1 and gradient is less than gmin
      IF (LUPD .and. RMX.lt.gmin .and.
     $   (abs(depre).lt.demin1 .and. abs(deact).lt.demin1) )
     $    dmax=max(dmax,tmone)
      if(iprnt.ge.1)WRITE(outfile,220)DMAX
 220  FORMAT(5X,'CURRENT TRUST RADIUS = ',F9.5)                  
230   if (dmax.lt.dmin) then
         status = 2
         write(outfile,240)dmin
240      format(/,5x,'TRUST RADIUS NOW LESS THAN ',F9.5,' OPTIMIZATION',
     $   ' TERMINATING',/,5X,
     1' GEOMETRY MAY NOT BE COMPLETELY OPTIMIZED')
         goto 270
      endif
C     CHECK STEPS AND ENOUGH TIME FOR ANOTHER PASS
      if (its.ge.mxstep)then
         goto 280
      endif
      do i=1, n 
        DDx(ind(i))=D(i)
      enddo
       gcomp = abs( grad(1) )
      do  i=2, n3tm
         abgc = abs( grad(i) )
         if (gcomp.lt.abgc)  gcomp = abgc
      enddo
       call optdisp(its, mlinp%geom, ener, grad(:n3tm), DDx(:n3tm),
     *           gcomp, gtol)
      GOTO 10                                                                  
C
C     ****** OPTIMIZATION TERMINATION ******
C
  250 CONTINUE
      WRITE(outfile,260)GNFINA,TOL2
  260 FORMAT(/,5X,'RMS GRADIENT =',F9.5,'  IS LESS THAN CUTOFF =',
     1F9.5,//)
  270 IFLEPO=15
      LAST=1
  280 CONTINUE
      IF (its.ge.mxstep) THEN
      write (outfile, 2200)
2200  format (/5x,'OPTIMIZATION FAILURE: Max iterations reached.',/)
      ierr = 1
       return 
       ENDIF
      FUNCT =ener

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), D(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2000)
      elseif (status .eq. 2) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), D(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      return
      end
C 
      SUBROUTINE EFOVLP(dmax,osmin,NEWMOD,NVAR,lorjk)             
c
      use files, only : outfile
      use input, only : mlopt, mlinp
      use optimize, only : ener, grad, hess
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
c

      COMMON/OPTEF/OLDF(150),D(150),VMODE(150),
     $U(150,150),DD,xlamd,xlamd0,skal,
     $MODE,its,NEGREQ,IPRNT
C	
      double precision,dimension(:),allocatable:: xo
      logical lorjk
      DATA ICALCN /0/                                                     IR1294
c
      n3tm = 3*mlinp%geom%natoms
      allocate(xo(n3tm))
       numcal = 1
C
C  ON THE FIRST STEP SIMPLY DETERMINE WHICH MODE TO FOLLOW
C 
      IF (its .EQ. 1) THEN
       IF (ICALCN .NE. NUMCAL) THEN                                       IR1294
         ICALCN=NUMCAL     
       endif                                                              IR1294
        IF (MODE. GT. NVAR) THEN
            WRITE(outfile,*)'ERROR!! MODE IS LARGER THAN NVAR',MODE
            STOP
        ENDIF
         IT=MODE
         if (iprnt .ge. 1) WRITE(outfile,40) MODE
   40 FORMAT(/5X,'Hessian Mode Following Switched on'/
     1    ,5X,'Following Mode ',I3/)
C
       ELSE
C
C  ON SUBSEQUENT STEPS DETERMINE WHICH HESSIAN EIGENVECTOR HAS
C  THE GREATEST OVERLAP WITH THE MODE WE ARE FOLLOWING
C
         IT=1
         lorjk=.false.
998      format(t20,d15.8,t40,d15.8,t60,d15.8)
         TOVLP= DDOT(NVAR,U(1,1),1,VMODE,1)
         TOVLP=ABS(TOVLP)
c        xo(1)=tovlp
         DO 10 I=2,NVAR
            OVLP=DDOT(NVAR,U(1,I),1,VMODE,1)                            IR0494
            OVLP=ABS(OVLP)
c           xo(i)=ovlp
            IF (OVLP .GT. TOVLP) THEN
               TOVLP=OVLP
               IT=I
            ENDIF
   10    CONTINUE
C
         if (iprnt .ge. 1) WRITE(outfile,30) IT,TOVLP
         if (tovlp .lt. omin) then
            if (dmax .gt. osmin) then
            lorjk=.true.
            if (iprnt.ge.1)write(outfile,31)omin
            return
            else
            if (iprnt.ge.1)write(outfile,32)omin,dmax,osmin
            endif
         endif
      ENDIF
   30 FORMAT(5X,'Overlap of Current Mode ',I3,' With Previous Mode Is ',
     $       F6.3)
   31 FORMAT(5X,'Overlap Less Than Omin',
     1F6.3,' Rejecting Previous Step')
   32 FORMAT(5X,'Overlap Less Than Omin',F6.3,' But Trust Radius',F6.3,
     $          ' Is Less Than',F6.3,/,5X,' Accepting Step')
C
C  SAVE THE EIGENVECTOR IN VMODE
C
       DO 20 I=1,NVAR
         VMODE(I)=U(I,IT)
   20 CONTINUE
C
      NEWMOD=IT
      RETURN
C
      END
C
      SUBROUTINE RSP(A,N,MATZ,W,Z)
      use files, only : outfile
      use input, only : mlopt, mlinp
      use optimize, only : ener, grad, hess

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION A(*),  W(N), Z(N,N)
*******************************************************************
*
*   EISPACK DIAGONALIZATION ROUTINES: TO FIND THE EIGENVALUES AND
*           EIGENVECTORS (IF DESIRED) OF A REAL SYMMETRIC PACKED MATRIX.
* ON INPUT-      N  IS THE ORDER OF THE MATRIX  A,
*                A  CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
*                   PACKED MATRIX STORED ROW-WISE,
*             MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF ONLY
*                   EIGENVALUES ARE DESIRED,  OTHERWISE IT IS SET TO
*                   ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND
*                   EIGENVECTORS.
* ON OUTPUT-     W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER,
*                Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO,
*
*******************************************************************
* THIS SUBROUTINE WAS CHOSEN AS BEING THE MOST RELIABLE. (JJPS)
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C FV and FV2 are scratch arrays which shouldo be dimensioned to the
C to the order of the biggest diagonalizable matrix
c
      double precision, dimension(:), allocatable :: FV1,FV2
      n3tm = N
      allocate (FV1(N),FV2(N))
      NV=(N*(N+1))/2 
      NM=N
C
20    call tred3(n,nv,a,w,fv1,fv2)
      IF (MATZ .NE. 0) GO TO 30
C     ********** FIND EIGENVALUES ONLY **********
       call tqlrat(n,w,fv2,ierr)
      GO TO 60
C     ********** FIND BOTH EIGENVALUES AND EIGENVECTORS **********
   30 DO 50    I = 1, N
C
         DO 40    J = 1, N
            Z(J,I)=0.0D0
   40    CONTINUE
C
         Z(I,I)=1.0D0
   50 CONTINUE
Ci
      call tql2(nm,n,w,fv1,z,ierr)
      IF (IERR .NE. 0) GO TO 70
      call trbak3(nm,n,nv,a,n,z,ierr)                                   IR0494
   60 return
C     ********** LAST CARD OF RSP **********
   70 write(outfile,'( "Error",I3," in RSP" )') ierr                    IR0494
      RETURN
      END
c
  	SUBROUTINE tred3 (N,NV,A,DA,E,E2)
C
C     CALLED BY:
C                 RSP
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION A(NV),DA(N),E(N),E2(N)
      DOUBLE PRECISION F,G,H,HH,SCALE
C
C     REAL SQRT,ABS,SIGN
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
C     A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
C     USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,
C
C        A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
C          INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
C          ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
C
C     ON OUTPUT-
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
C          TRANSFORMATIONS USED IN THE REDUCTION,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
C
      DATA ZERO / 0.0D0 /
      DO 90 II = 1, N
         I = N+1-II
         L = I-1
         IZ = (I*L)/2
         H = ZERO
         SCALE = ZERO
         IF (L.LT.1) GO TO 20
C
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
C
         DO 10 K = 1, L
            IZ = IZ+1
            DA(K) = A(IZ)
            SCALE = SCALE+ABS(DA(K))
   10    CONTINUE
C
         IF (SCALE.NE.ZERO) GO TO 30
   20    E(I) = ZERO
         E2(I) = ZERO
         GO TO 80
C
   30    DO 40 K = 1, L
            DA(K) = DA(K)/SCALE
            H = H+DA(K)*DA(K)
   40    CONTINUE
C
         E2(I) = SCALE*SCALE*H
         F = DA(L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE*G
         H = H-F*G
         DA(L) = F-G
         A(IZ) = SCALE*DA(L)
         IF (L.EQ.1) GO TO 80
         F = ZERO
C
         DO 60 J = 1, L
            G = ZERO
            JK = (J*(J-1))/2
C
C     ********** FORM ELEMENT OF A*U **********
C
            DO 50 K = 1, L
               JK = JK+1
               IF (K.GT.J) JK = JK+K-2
               G = G+A(JK)*DA(K)
   50       CONTINUE
C
C     ********** FORM ELEMENT OF P **********
C
            E(J) = G/H
            F = F+E(J)*DA(J)
   60    CONTINUE
C
         HH = F/(H+H)
         JK = 0
C
C     ********** FORM REDUCED A **********
C
         DO 70 J = 1, L
            F = DA(J)
            G = E(J)-HH*F
            E(J) = G
C
            DO 70 K = 1, J
               JK = JK+1
               A(JK) = A(JK)-F*E(K)-G*DA(K)
   70    CONTINUE
C
   80    DA(I) = A(IZ+1)
         A(IZ+1) = SCALE*SQRT(H)
   90 CONTINUE
C
      RETURN
C
C     ********** LAST CARD OF TRED3 **********
C
      END
C     
      SUBROUTINE tqlrat (N,DA,E2,IERR)
C
C     CALLED BY:
C                RSP
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION DA(N),E2(N)
      DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP
C
C     REAL SQRT,ABS,SIGN
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C                **********
C
      DATA ZERO,ONE,TWO / 0.0D0,1.0D0,2.0D0 /
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
      MACHEP = TWO**(-46)
C
      IERR = 0
      IF (N.EQ.1) GO TO 140
C
      DO 10 I = 2, N
         E2(I-1) = E2(I)
   10 CONTINUE
C
      F = ZERO
      B = ZERO
      E2(N) = ZERO
C
      DO 120 L = 1, N
         J = 0
         H = MACHEP*(ABS(DA(L))+SQRT(E2(L)))
         IF (B.GT.H) GO TO 20
         B = H
         C = B*B
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
   20    DO 30 M = L, N
            IF (E2(M).LE.C) GO TO 40
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
   30    CONTINUE
C
   40    IF (M.EQ.L) GO TO 80
   50    IF (J.EQ.30) GO TO 130
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         S = SQRT(E2(L))
         G = DA(L)
         P = (DA(L1)-G)/(TWO*S)
         R = SQRT(P*P+ONE)
         DA(L) = S/(P+SIGN(R,P))
         H = G-DA(L)
C
         DO 60 I = L1, N
            DA(I) = DA(I)-H
   60    CONTINUE
C
         F = F+H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
         G = DA(M)
         IF (G.EQ.ZERO) G = B
         H = G
         S = ZERO
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO 70 II = 1, MML
            I = M-II
            P = G*H
            R = P+E2(I)
            E2(I+1) = S*R
            S = E2(I)/R
            DA(I+1) = H+S*(H+DA(I))
            G = DA(I)-E2(I)/G
            IF (G.EQ.ZERO) G = B
            H = G*P/R
   70    CONTINUE
C
         E2(L) = S*G
         DA(L) = H
C
C     ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST **********
C
         IF (H.EQ.ZERO) GO TO 80
         IF (ABS(E2(L)).LE.ABS(C/H)) GO TO 80
         E2(L) = H*E2(L)
         IF (E2(L).NE.ZERO) GO TO 50
   80    P = DA(L)+F
C
C     ********** ORDER EIGENVALUES **********
C
         IF (L.EQ.1) GO TO 100
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
         DO 90 II = 2, L
            I = L+2-II
            IF (P.GE.DA(I-1)) GO TO 110
            DA(I) = DA(I-1)
   90    CONTINUE
C
  100    I = 1
  110    DA(I) = P
  120 CONTINUE
C
      GO TO 140
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  130 IERR = L
  140 RETURN
C
C     ********** LAST CARD OF TQLRAT **********
C
      END

      SUBROUTINE tql2 (NM,N,DA,E,Z,IERR)
C
C     CALLED BY:
C                RSP
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION DA(N),E(N),Z(NM,N)
      DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP
C
C     REAL SQRT,ABS,SIGN
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C                **********
C
      DATA ZERO,ONE,TWO / 0.0D0,1.0D0,2.0D0 /
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
      MACHEP = TWO**(-46)
C
      IERR = 0
      IF (N.EQ.1) GO TO 160
C
      DO 10 I = 2, N
         E(I-1) = E(I)
   10 CONTINUE
C
      F = ZERO
      B = ZERO
      E(N) = ZERO
C
      DO 110 L = 1, N
         J = 0
         H = MACHEP*(ABS(DA(L))+ABS(E(L)))
         IF (B.LT.H) B = H
C
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
C
         DO 20 M = L, N
            IF (ABS(E(M)).LE.B) GO TO 30
C
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
   20    CONTINUE
C
   30    IF (M.EQ.L) GO TO 100
   40    IF (J.EQ.30) GO TO 150
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         G = DA(L)
         P = (DA(L1)-G)/(TWO*E(L))
C
C        R = SQRT(P*P+ONE)
C
         IF (ABS(P).GT.1.0D+16) THEN
            R = ABS(P)
         ELSE
            R = SQRT(P*P+ONE)
         ENDIF
         DA(L) = E(L)/(P+SIGN(R,P))
         H = G-DA(L)
C
         DO 50 I = L1, N
            DA(I) = DA(I)-H
   50    CONTINUE
C
         F = F+H
C
C     ********** QL TRANSFORMATION **********
C
         P = DA(M)
         C = ONE
         S = ZERO
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO 90 II = 1, MML
            I = M-II
            G = C*E(I)
            H = C*P
            IF (ABS(P).LT.ABS(E(I))) GO TO 60
            C = E(I)/P
            R = SQRT(C*C+ONE)
            E(I+1) = S*P*R
            S = C/R
            C = ONE/R
            GO TO 70
   60       C = P/E(I)
            R = SQRT(C*C+ONE)
            E(I+1) = S*E(I)*R
            S = ONE/R
            C = C*S
   70       P = C*DA(I)-S*G
            DA(I+1) = H+S*(C*G+S*DA(I))
C
C     ********** FORM VECTOR **********
C
            DO 80 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S*Z(K,I)+C*H
               Z(K,I) = C*Z(K,I)-S*H
   80       CONTINUE
C
   90    CONTINUE
C
         E(L) = S*P
         DA(L) = C*P
         IF (ABS(E(L)).GT.B) GO TO 40
  100    DA(L) = DA(L)+F
  110 CONTINUE
C
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
C
      DO 140 II = 2, N
         I = II-1
         K = I
         P = DA(I)
C
         DO 120 J = II, N
            IF (DA(J).GE.P) GO TO 120
            K = J
            P = DA(J)
  120    CONTINUE
C
         IF (K.EQ.I) GO TO 140
         DA(K) = DA(I)
         DA(I) = P
C
         DO 130 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  130    CONTINUE
C
  140 CONTINUE
C
      GO TO 160
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  150 IERR = L
  160 RETURN
C
C     ********** LAST CARD OF TQL2 **********
C
      END
       SUBROUTINE trbak3 (NM,N,NV,A,M,Z,IERR)
C
C     CALLED BY:
C                RSP
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION A(NV),Z(NM,M)
      DOUBLE PRECISION H,S
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRED3.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS
C          USED IN THE REDUCTION BY  TRED3  IN ITS FIRST
C          N*(N+1)/2 POSITIONS,
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED,
C
C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
C          IN ITS FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
C          IN ITS FIRST M COLUMNS.
C
C     NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      DATA ZERO / 0.0D0 /
      IF (M.EQ.0) GO TO 60
      IF (N.EQ.1) GO TO 60
C
      DO 50 I = 2, N
         L = I-1
         IZ = (I*L)/2
         IK = IZ+I
         H = A(IK)
         IF (H.EQ.ZERO) GO TO 50
C
         DO 40 J = 1, M
            S = ZERO
            IK = IZ
C
            DO 10 K = 1, L
               IK = IK+1
               S = S+A(IK)*Z(K,J)
   10       CONTINUE
C
C     ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
C
            S = S/H
            IK = IZ
C
            DO 30 K = 1, L
               IK = IK+1
               IF (ABS(H).GT.1.0D0) GO TO 20
               SA = S*A(IK)
               IF (ABS(SA).LT.ABS(H)*1.6D+38) GO TO 20
               IERR = 1111
               RETURN
   20          CONTINUE
               Z(K,J) = Z(K,J)-S*A(IK)/H
   30       CONTINUE
C
   40    CONTINUE
C
   50 CONTINUE
C
   60 RETURN
C
C     ********** LAST CARD OF TRBAK3 **********
C
       END
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end

