SUBROUTINE solve(ttosolve,tjmat,tsolve)

!-------------------------------------------------------------
!
!  Directs the solution by either calling for a mesh
!   sweep (DD-SI) or for a ITM solution (DD-ITM)
!
!-------------------------------------------------------------

USE invar
USE itmvar
USE totvar
IMPLICIT NONE
INTEGER :: i, j, k, bit, ierr, temp, ieq, i1, sdi, cnvf, cnt, v, vit, bitsp, bitd
INTEGER :: spx, spy, spz, kc, jc, ic, crsf, cneq, cbcs, xt, yt, zt
!INTEGER, DIMENSION(neq,nsdp) :: piv
!INTEGER, DIMENSION(neq,ns1) :: fpiv
REAL*8 :: sdcf
REAL*8, INTENT(OUT) :: ttosolve, tjmat, tsolve
!REAL*8, DIMENSION(neq) :: frphi
!REAL*8, DIMENSION(bcs,8) :: frpsi, foldpsi
!REAL*8, DIMENSION(neq,nsdp) :: phi, phiold, phir, sv, rphi
!REAL*8, DIMENSION(neq,ns1) :: f, fr, fsv
!REAL*8, DIMENSION(bcs,8,nsdp) :: psii, psio, av, oldpsi, rpsi
!REAL*8, DIMENSION(bcs,8,ns1) :: fpi, fpo, fav
!REAL*8, DIMENSION(neq,neq,nsdp) :: jmat
!REAL*8, DIMENSION(neq,neq,ns1) :: fjmt
!REAL*8, DIMENSION(bcs,neq,8,nsdp) :: kmat
!REAL*8, DIMENSION(bcs,neq,8,ns1) :: fkmt
!REAL*8, DIMENSION(neq,bcs,8,nsdp) :: jpsi
!REAL*8, DIMENSION(neq,bcs,8,ns1) :: fjps
!REAL*8, DIMENSION(bcs2,bcs2,apo,8,nsdp) :: kpsi
!REAL*8, DIMENSION(bcs2,bcs2,apo,8,ns1) :: fkps

INCLUDE 'mpif.h'

! Allocate
ALLOCATE(piv(neq,nsdp),fpiv(neq,ns1))
ALLOCATE(frphi(neq),frpsi(bcs,8),foldpsi(bcs,8))
ALLOCATE(phi(neq,nsdp),phiold(neq,nsdp),phir(neq,nsdp),sv(neq,nsdp),rphi(neq,nsdp))
ALLOCATE(f(neq,ns1),fr(neq,ns1),fsv(neq,ns1))
ALLOCATE(psii(bcs,8,nsdp),psio(bcs,8,nsdp),av(bcs,8,nsdp),oldpsi(bcs,8,nsdp),rpsi(bcs,8,nsdp))
ALLOCATE(fpi(bcs,8,ns1),fpo(bcs,8,ns1),fav(bcs,8,ns1))
ALLOCATE(jmat(neq,neq,nsdp),fjmt(neq,neq,ns1))
ALLOCATE(kmat(bcs,neq,8,nsdp),fkmt(bcs,neq,8,ns1))
ALLOCATE(jpsi(neq,bcs,8,nsdp),fjps(neq,bcs,8,ns1))
ALLOCATE(kpsi(bcs2,bcs2,apo,8,nsdp),fkps(bcs2,bcs2,apo,8,ns1))

! Mark the beginning of the solution phase
IF (irank == root) THEN
   WRITE (8,*)
   WRITE (8,*) "-------------------------- THE SOLUTION ----------------------------------"
   WRITE (8,*)
END IF

! Get the time to reach this point
ttosolve = MPI_WTIME()

! Need to construct matrices for solving first
! Progress down V-cycle stages to construct operators once
spx = 1
spy = 1
spz = 1
DO v = 0, ns1
   IF (v == 0) THEN
      CALL idomats(spx,spy,spz,jmat,kmat,jpsi,kpsi,piv,sv,av)
   ELSE
      xt = MOD(xrank,spx)
      yt = MOD(yrank,spy)
      zt = MOD(zrank,spz)
      IF (xt == 0 .AND. yt == 0 .AND. zt == 0) THEN
         CALL idomatsf(spx,spy,spz,fjmt(:,:,v),fkmt(:,:,:,v),fjps(:,:,:,v),fkps(:,:,:,:,v),fpiv(:,v))
      END IF
      IF (v < ns1) THEN
         spx = spx*xcf(v)
         spy = spy*ycf(v)
         spz = spz*zcf(v)
      END IF
   END IF
END DO

! Initialize psii, phiold, the iteration counter, the convergence flag
psii = 0.0
phiold = 0.0
oldpsi = 0.0
cnt = 0
cnvf = 0

! Get the construction time
tjmat = MPI_WTIME()

! Hardwire max iterations for v>0
bitsp = 1

! Set dummy bitmx2
bitd = bitmx2 + 1

! Start the Multigrid iterations
DO vit = 1, vitmx

   !------------------------------------ Pre-Correction -------------------------------------------
   ! Work down with bitmx1 iterations the V-cycle stages until the last stage
   ! where it is solved in one iteration exactly
   ! Start with the coarsening step of multiple to one s-d per processor: STAGE 0
   spx = 1
   spy = 1
   spz = 1
   DO v = 0, ns2
      kc = zcf(v)
      jc = ycf(v)
      ic = xcf(v)
      sdcf = 1.0
      crsf = 0
      IF (kc > sdnz) THEN
         crsf = 1
         sdcf = sdcf*REAL(sdnz)/REAL(kc)
         kc = sdnz
      END IF
      IF (jc > sdny) THEN
         crsf = 1
         sdcf = sdcf*REAL(sdny)/REAL(jc)
         jc = sdny
      END IF
      IF (ic > sdnx) THEN
         crsf = 1
         sdcf = sdcf*REAL(sdnx)/REAL(ic)
         ic = sdnx
      END IF
      IF (crsf == 1) THEN
         IF (irank == root .AND. vit == 1) THEN
            warn = warn + 1
            WRITE(8,'(/,3X,A,I2,/)') "WARNING: Sub-domain coarsening factor is greater than &
                                      number of cells in one or more dimensions for stage ", v
         END IF
      END IF
      cneq = neq/(kc*jc*ic)
      cbcs = apo*(xys/(ic*jc) + xzs/(ic*kc) + yzs/(jc*kc))

      ! All processes do PGS iterations and restrict to one s-d per processor
      IF (v == 0) THEN
         DO bit = 1, bitmx1
            cnt = cnt + 1
            ! Red iterations
            sdi = 0
            DO k = 1, nzsd
               DO j = 1, nysd
                  i1 = MOD(j+k,2) + 1
                  DO i = i1, nxsd, 2
                     sdi = (k-1)*nysd*nxsd + (j-1)*nxsd + i
                     CALL idot(phi(:,sdi),sv(:,sdi),psii(:,:,sdi),psio(:,:,sdi),av(:,:,sdi), &
                               jmat(:,:,sdi),kmat(:,:,:,sdi),jpsi(:,:,:,sdi),kpsi(:,:,:,:,sdi),piv(:,sdi))
                  END DO
               END DO
            END DO
            ! Copy/Send from red to black
            CALL pgsred(bit,bitmx1,psii,psio,oldpsi)

            ! Black iterations
            sdi = 0
            DO k = 1, nzsd
               DO j = 1, nysd
                  i1 = MOD(j+k+1,2) + 1
                  DO i = i1, nxsd, 2
                     sdi = (k-1)*nysd*nxsd + (j-1)*nxsd + i
                     CALL idot(phi(:,sdi),sv(:,sdi),psii(:,:,sdi),psio(:,:,sdi),av(:,:,sdi), &
                               jmat(:,:,sdi),kmat(:,:,:,sdi),jpsi(:,:,:,sdi),kpsi(:,:,:,:,sdi),piv(:,sdi))
                  END DO
               END DO
            END DO
            ! Check for convergence and pass from black to red
            CALL pgsblk(bit,bitmx1,cnvf,phi,phiold,psii,psio,oldpsi)

            ! Exit the bit do loop if converged
            IF (cnvf == 1) EXIT

!print *, bit
!print *, phi
         END DO

         ! Exit the v loop
         IF (cnvf == 1) EXIT

         ! Call for the residual computation
         CALL residual(psii,oldpsi,rphi,rpsi,kmat,kpsi)

!do bit = 1, nsdp
!   print *, bit
!   print *, rphi(:,bit)
!end do

         ! Call to restrict to one sub-domain per processor
         CALL restrict(kc,jc,ic,cneq,cbcs,sdcf,rphi,rpsi,phi,phir,fsv(:,1),fav(:,:,1))

      ! Otherwise only certain processes move on
      ELSE
         ! Determine if your rank says you'll move on in this stage
         xt = MOD(xrank,spx)
         yt = MOD(yrank,spy)
         zt = MOD(zrank,spz)

         ! Call for the solution loop only if your rank participates in the current stage
         IF (xt == 0 .AND. yt == 0 .AND. zt == 0) THEN
            ! Reinitialize
            foldpsi = 0.0
            DO bit = 1, bitsp
               cnt = cnt + 1
               ! Call for the residual equation iteration
               CALL idotf(f(:,v),fsv(:,v),fpiv(:,v),fpo(:,:,v),fav(:,:,v),fjmt(:,:,v),fjps(:,:,:,v))
               ! Now call for communication in a PBJ sense because v>0
               CALL pbj(spx,spy,spz,fpi(:,:,v),fpo(:,:,v))
            END DO

            ! Call for the residual computation and restriction
            CALL residualf(fpi(:,:,v),foldpsi,frphi,frpsi,fkmt(:,:,:,v),fkps(:,:,:,:,v))
            CALL restrictf(v,spx,spy,spz,kc,jc,ic,cneq,cbcs,crsf,sdcf,frphi,frpsi,f(:,v),fr(:,v),fsv(:,v+1),fav(:,:,v+1))
         END IF

         ! Update spx/y/z for next loop
         spx = spx*xcf(v)
         spy = spy*ycf(v)
         spz = spz*zcf(v)
     END IF
   END DO

   ! Break out of the vit loops
   IF (cnvf == 1) THEN
      IF (irank == root) THEN
         WRITE(8,'(1X,A,I5)') "A) Multigrid converged in this many v-cycles: ", vit
         WRITE(8,'(1X,A,I5)') "A) Total iterations: ", cnt
      END IF
      tsolve = MPI_WTIME()
      EXIT
   END IF

   !----------------------------------------- Coarsest Grid ----------------------------------------------
   IF (nrank == 0) THEN
      CALL idotcg(fpiv(:,ns1),f(:,ns1),fsv(:,ns1),fjmt(:,:,ns1))
      cnt = cnt + 1
   END IF

!if (nrank == root) print *, fsv(:,1)
!if (nrank == root) print *, f(:,1)

   !---------------------------------------- Post-Correction ---------------------------------------------
   ! Work back up the V-Cycle stages until the top stage (fine grid) where
   ! convergence is tested. Start at next coarsest grid
   DO v = ns2, 0, -1
      kc = zcf(v)
      jc = ycf(v)
      ic = xcf(v)
      crsf = 0
      IF (kc > sdnz) THEN
         crsf = 1
         kc = sdnz
      END IF
      IF (jc > sdny) THEN
         crsf = 1
         jc = sdny
      END IF
      IF (ic > sdnx) THEN
         crsf = 1
         ic = sdnx
      END IF
      cneq = neq/(kc*jc*ic)

      IF (v > 0) THEN
         ! Adjust parallel parameters
         spx = spx/xcf(v)
         spy = spy/ycf(v)
         spz = spz/zcf(v)
         xt = MOD(xrank,spx)
         yt = MOD(yrank,spy)
         zt = MOD(zrank,spz)
         ! Call for the solution loop only if your rank participates in the current stage
         IF (xt == 0 .AND. yt == 0 .AND. zt == 0) THEN
            ! Interpolation step: send out correction info to finer grid, add it to f(:,v)
            CALL interpf(v,spx,spy,spz,kc,jc,ic,cneq,f(:,v),f(:,v+1),fr(:,v))

            ! Already interpolated the flux; add to the counter
            cnt = cnt + 1
         END IF

      ! Otherwise interpolate back to multiple sub-domains per processor and
      ! iterate with bitmx2 iterations
      ELSE

!print *, phi
        ! All processes interpolate to many sub-domains per p
         CALL interp(kc,jc,ic,cneq,phi,f(:,v+1),phir)

!print *, phi

         ! Now perform the iterations since v=0
         DO bit = 1, bitmx2
            cnt = cnt + 1
            ! Red iterations
            sdi = 0
            DO k = 1, nzsd
               DO j = 1, nysd
                  i1 = MOD(j+k,2) + 1
                  DO i = i1, nxsd, 2
                     sdi = (k-1)*nysd*nxsd + (j-1)*nxsd + i
                     CALL idotig(bit,phi(:,sdi),sv(:,sdi),psii(:,:,sdi),psio(:,:,sdi),av(:,:,sdi), &
                                 jmat(:,:,sdi),kmat(:,:,:,sdi),jpsi(:,:,:,sdi),kpsi(:,:,:,:,sdi),piv(:,sdi))
                  END DO
               END DO
            END DO
            ! Copy/Send from red to black
            CALL pgsred(bit,bitd,psii,psio,oldpsi)

            ! Black iterations
            sdi = 0
            DO k = 1, nzsd
               DO j = 1, nysd
                  i1 = MOD(j+k+1,2) + 1
                  DO i = i1, nxsd, 2
                     sdi = (k-1)*nysd*nxsd + (j-1)*nxsd + i

!                     CALL idot(phi(:,sdi),sv(:,sdi),psii(:,:,sdi),psio(:,:,sdi),av(:,:,sdi), &
!                               jmat(:,:,sdi),kmat(:,:,:,sdi),jpsi(:,:,:,sdi),kpsi(:,:,:,:,sdi),piv(:,sdi))

                     CALL idotig(bit,phi(:,sdi),sv(:,sdi),psii(:,:,sdi),psio(:,:,sdi),av(:,:,sdi), &
                                  jmat(:,:,sdi),kmat(:,:,:,sdi),jpsi(:,:,:,sdi),kpsi(:,:,:,:,sdi),piv(:,sdi))
                  END DO
               END DO
            END DO
            ! Check for convergence and pass from black to red
            ! Don't need oldpsi, so just use bitd, dummy value
            CALL pgsblk(bit,bitd,cnvf,phi,phiold,psii,psio,oldpsi)

            ! Exit the bit do loop if converged
            IF (cnvf == 1) EXIT
         END DO

         ! Exit the v do loop if converged
         IF (cnvf == 1) EXIT
      END IF
   END DO

   ! Final checks on convergence
   ! Break out of the vit loops
   IF (cnvf == 1) THEN
      IF (irank == root) THEN
         WRITE(8,'(1X,A,I5)') "B) Multigrid converged in this many v-cycles: ", vit
         WRITE(8,'(1X,A,I5)') "B) Total iterations: ", cnt
      END IF
      tsolve = MPI_WTIME()
      EXIT
   END IF
   IF (cnvf == 0 .AND. vit == vitmx) THEN
      IF (irank == root) WRITE(8,*) "    DID NOT CONVERGE    "
      tsolve = MPI_WTIME()
      EXIT
   END IF

! Ejnd the V-cycle iterative sequence
END DO

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

IF (irank == root) THEN
   WRITE(8,'(1X,A)') "Integral discrete ordinates..."
   WRITE(8,'(3X,A)') "...with direct solution..."
END IF

! Combine all the scalar fluxes across sub-domains on each processor individually
CALL idocomb(phi)

! Check the scalar flux printing flag
IF (sfp == 1) CALL flxgthr

! Deallocate
DEALLOCATE(piv,fpiv)
DEALLOCATE(frphi,frpsi,foldpsi,phi,phiold,phir,sv,rphi,f,fr,fsv)
DEALLOCATE(psii,psio,av,oldpsi,rpsi,fpi,fpo,fav)
DEALLOCATE(jmat,kmat,jpsi,kpsi)
DEALLOCATE(fjmt,fkmt,fjps,fkps)

RETURN
END SUBROUTINE solve


Subroutine hjan2b
  Parameter (maxptn=400001)
  Parameter (maxstr=150001)
  Parameter (dr=0.2, dt=0.2)
  Dimension dnrg2b(50), dtg2b(-24:25)
  Dimension snrg2b(50), stg2b(-24:25)
  Double Precision gx5, gy5, gz5, ft5, px5, py5, pz5, e5, xmass5
  Double Precision ataui, zt1, zt2, zt3
  Common /para1/mul
  Common /prec2/gx5(maxptn), gy5(maxptn), gz5(maxptn), ft5(maxptn), px5(maxptn), py5(maxptn), pz5(maxptn), e5(maxptn), xmass5(maxptn), ityp5(maxptn)
  Common /ilist8/lstrg1(maxptn), lpart1(maxptn)
  Common /srec1/nsp, nst, nsi
  Common /srec2/ataui(maxstr), zt1(maxstr), zt2(maxstr), zt3(maxstr)
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /arevt/iaevt, iarun, miss
  Common /arout/iout
  Save
  Data iw/0/
  If (isevt==iaevt .And. isrun==iarun) Then
    Do i = 1, 50
      dnrg2b(i) = snrg2b(i)
      dtg2b(i-25) = stg2b(i-25)
    End Do
  Else
    Do i = 1, 50
      snrg2b(i) = dnrg2b(i)
      stg2b(i-25) = dtg2b(i-25)
    End Do
    isevt = iaevt
    isrun = iarun
    iw = iw + 1
  End If
  Do i = 1, mul
    j = lstrg1(i)
    gx0 = sngl(zt1(j))
    gy0 = sngl(zt2(j))
    r0 = sqrt((sngl(gx5(i))-gx0)**2+(sngl(gy5(i))-gy0)**2)
    ir = 1 + int(r0/dr)
    If (ir>50 .Or. ir<1) Goto 100
    dnrg2b(ir) = dnrg2b(ir) + 1.0
    100 Continue
    diff2 = sngl(ft5(i)**2-gz5(i)**2)
    If (diff2<0.) Then
      Write (6, *) '4:I,ft5,gz5,diff2=', i, ft5(i), gz5(i), diff2
      tau7 = 1E-6
    Else
      tau7 = sqrt(diff2)
    End If
    dtau = tau7 - sngl(ataui(j))
    it = 1 + int(dtau/dt)
    If (it>25 .Or. it<-24) Goto 200
    dtg2b(it) = dtg2b(it) + 1.0
    200 Continue
  End Do
  Return
End Subroutine hjan2b


      SUBROUTINE NMOAPP(DATIN,DATOUT,ITX,IS,IE,ISTRET,MUTE,itype)
C     NMOAPP APPLIES THE NMO CORRECTIONS COMPUTED BY NMOTAB AND TRANSFERRED VIA
C  ARRAY ITX.  THE CORRECTIONS ARE APPLIED TO ARRAY DATIN AND ARE WRITTEN TO
C  ARRAY DATOUT.  THE CORRECTIONS IN ARRAY ITX ARE REALLY JUST INDICES
C  CORRESPONDING TO TX.  THE T0'S START WITH INDEX IS AND INCREMENT BY 1 UNTIL
C  INDEX IE IS REACHED.
C     MUTING IS PERFORMED ON ALL DATA WITH NMO STRETCH EXCEEDING ISTRET.
C THE INDEX OF THE FIRST UNMUTED VALUE IS RETURNED BY NMOAPP VIA MUTE.
C
C ARGUMENTS:
C     DATIN  - AN ARRAY OF INPUT DATA TO BE MOVED OUT.
C     DATOUT - AN ARRAY TO RECEIVE THE OUTPUT OR MOVED OUT DATA.
C              THE OUTPUT ARRAY MAY BE THE SAME AS THE INPUT ARRAY SINCE T0 IS
C              ALWAYS LESS THAN TX.
C     ITX    - THE INTEGER ARRAY OF TX INDEXES THAT POINT TO THE DATA TO BE MOVED
C              OUT
C     IS     - THE INTEGER START INDEX.  THE FIRST T0 VALUE (IN BLOCKS).  THE
C              FIRST VALUE OF THE ITX ARRAY.
C     IE     - THE INTEGER END INDEX.  THE LAST T0 VALUE (IN BLOCKS) TO MOVE.
C     ISTRET - THE STRETCH OR MAXIMUM AMOUNT OF NMO (IN BLOCKS) ALLOWED WITHOUT
C              KILLING THE DATA.  ANY DATA WHOSE NMO IS GREATER THAN ISTRET WILL
C              BE KILLED.
C     MUTE   - THE NEW OR UPDATED IST BECAUSE OF MUTING DUE TO NMO EXCEEDING THE
C              STRETCH.  SET BY NMOAPP.
c     itype  = 1, NMO or MoveOut
c            = 2, MoveIn
C
C     PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, MARCH 1979
C
c  modified by pch aug 89 to kill data before the start index
c  mod Oct 91 by pch - add itype so that movein works (data before the current is moved)
c  mod Nov 91 by pch - Zero data before the start when MoveIn
c  mod Feb 99 - Zero the sample if it comes from a time that has already
c               been past.  i.e. inverted nmo?
c  mod 27 Jul 99 - Zero it only if time is decreasing from the previous
c               sample.  Once it starts increasing again, it's ok maybe.
c               This just kills the part when the waveform becomes
c               reversed in time.
c  mod 9 May 12 - kbig was set wrong and may explain "NMO caused wavelet inversion"
c  mod 5 Jul 12 - nmoex sets the index to 99999 if sample killed by DSTRETCH
c  mod 12 Jul 12 - The first kbig was set to itx(is-1) or itx(0)
c                - Drop the wavelet inversion BS because datin is now different from datout.
c                - kbig is no longer needed.
c
      DIMENSION DATIN(1),DATOUT(1),ITX(1)
      DATA ierr/0/
      SAVE ierr
c
      MUTE = 0
      ISTR = ISTRET
      I = IS - 1
c      kbig = itx(is)
      M = 0
      IF( itype .EQ. 2 ) datin(1) = 0.
   10 I = I + 1
      IF( I .LE. IE ) THEN
          K=ITX(I)                                                      !  PICK UP THE INDEX OF DATAIN
          IF( K .LT. I .AND. itype .NE. 2 ) K = I                       !  DON'T ALLOW INVERTED NMO
          IF( IABS(K-I) .LE. ISTR .OR. itype .NE. 2 ) THEN
              DATOUT(I)=DATIN(K)                                        !  MOVE 1 SAMPLE
              IF( IABS(K-I) .GT. istr .AND. itype .EQ. 1 ) datout(i)=0.
              IF( K .LT. IS ) DATOUT(I) = 0.                            ! KILL THE DATA BEFORE THE START OF DATA
              IF( K .GT. IE ) DATOUT(I) = 0.                            ! KILL THE DATA AFTER THE END OF DATA
c              IF( k .EQ. itx(i-1) ) datout(i) = datout(i-1)             ! watch out for the last sample zeroed by us
c              IF( k .LT. kbig ) THEN
c                  datout(i) = 0.
c                  IF( ierr .EQ. 0 ) ierr = 1
c              ELSE
c                  kbig = k
c              ENDIF
c              kbig = k
          ELSE
              M = I
          ENDIF
          GO TO 10
      ENDIF
      IF( ierr .EQ. 1 ) THEN
          ierr = 2
          PRINT *,
     &' ***  WARNING  ***  Data zeroed - NMO caused wavelet inversion.'
      ENDIF
C****
C****   KILL THE DATA IF THE NMO EXCEEDS THE STRETCH FACTOR
C****
      IF( M .EQ. 0 ) RETURN
      DO 400 K = 1, M
         DATOUT(K) = 0.
  400 CONTINUE
      MUTE = M + 1
      RETURN
      END


      SUBROUTINE GETIME (CIN, IBLINE, LENLIN, JULS, ISTIME,
     * JULE, IETIME, ISTAT)
C
C     GETS STARTING AND ENDING DATES AND TIMES FROM A TIME
C     COMMAND LINE
C
C     ISTAT =  0      NO ERROR
C     ISTAT = -1      ERROR OCCURED
C
      COMMON /UNDEF_TIME/ ITIME_UNDEF
      INTEGER ITIME_UNDEF
C
      CHARACTER CIN*(*), CLINE*80
      CHARACTER CMON(12)*3
      CHARACTER*16 CVAR, CTMP
      PARAMETER (MAXF=10)
      INTEGER   IBF(10), IEF(10), ILF(10)
      INTEGER*4 JULE, JULS, JUL                                         ML
      INTEGER*4 INTL(4)                                                 ML
C     INTEGER INTL(4)                                                   Hu
      LOGICAL   LSDATE, LCUR, LSTIME, LEDATE, LSTART, LENDFL
C
      DATA CMON/'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
     *          'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/
      DATA INTL /525600, 42300, 1440, 60/
C
C
C
      ISTAT = 0
C
      IF (LENLIN.EQ.0) GO TO 900
      CLINE = CIN(IBLINE:IBLINE+LENLIN-1)
      CALL UPCASE (CLINE)
C
      IF (ISTIME.EQ.-1) ISTIME = 1
      IF (IETIME.EQ.-1) IETIME = 1440
C
C     SEPERATE LINE INTO FIELDS
      CALL PARSLI ( CLINE, MAXF, NFIELD, IBF, IEF, ILF)
      IF (NFIELD.EQ.0) GO TO 900
C
C     INITIALIZE LOCAL VARIABLES
 20   CONTINUE
      LSDATE = .FALSE.
      LSTIME = .FALSE.
      LEDATE = .FALSE.
      LCUR   = .FALSE.
      LENDFL = .FALSE.
C
C
      DO 100 N=1,NFIELD
C
C     MOVE THIS FIELD INTO IVAR
      IF (ILF(N).EQ.0) GO TO 100
      IF (ILF(N).GT.16) GO TO 900
      CVAR = CLINE(IBF(N):IEF(N))
C
      IF ((N.EQ.1).OR.((N.EQ.2).AND.(NFIELD.GT.2))) THEN
      LSTART = .TRUE.
      ELSE
      LSTART = .FALSE.
      ENDIF
C
C     Is this a reference to the current time, or another time (e.g. E)
      IF (INDEX('DTBSE', CVAR(1:1)).GT.0) THEN
C     LOOK FOR A CURRENT DATE AND TIME FLAG (I.E. "T")
      IF (CVAR(1:1) .EQ. 'T') THEN
      LCUR = .TRUE.
C     STARTING DATE AND TIME, OR ENDING?
      IF (N.EQ.1) THEN
      CALL CURTIM ( JULS, ISTIME)
      LSDATE = .TRUE.
      LSTIME = .TRUE.
      ELSE
      CALL CURTIM ( JULE, IETIME)
      LEDATE = .TRUE.
      ENDIF
C
C     ELSE CHECK DATE FLAG ("D")
      ELSE IF (CVAR(1:1) .EQ. 'D') THEN
      LCUR = .TRUE.
C     BEGINNING DATE, OR ENDING DATE?
      IF (.NOT.LSDATE) THEN
      CALL CURTIM ( JULS, IDUM)
      LSDATE = .TRUE.
      ELSE
      CALL CURTIM ( JULE, IDUM)
      LEDATE = .TRUE.
      ENDIF
C
C     Is this an ending date with a reference to the starting date
C     (e.g., "S+5H")
      ELSE IF ((CVAR(1:1).EQ.'B').OR.(CVAR(1:1).EQ.'S')) THEN
      JULE = JULS
      IETIME = ISTIME
      LEDATE = .TRUE.
      LSTART = .FALSE.
C
C     Is this a starting date with a reference to the ending date
C     (e.g., "E-1M")
      ELSE IF (CVAR(1:1).EQ.'E') THEN
C     This reference must always be in the first field
      IF (N.GT.1) GO TO 900
C     Since we may not know the ending date, compute the
C     ending date first, then come back ad compute this
C     (fool the code by setting the numb of fields to 1
C     after computing the ending date)
      IF (NFIELD.EQ.1) THEN
      IF (JULE.LE.0) GO TO 900
      JULS = JULE
      ISTIME = IETIME
      LSDATE = .TRUE.
      LSTIME = .TRUE.
      ELSE
      LENDFL = .TRUE.
      GO TO 100
      ENDIF
      ENDIF
C
C     Remove "T" (or D, S, etc.)
      CTMP = CVAR(2:)
      CVAR = CTMP
      CALL CHRLNB (CVAR, ILAST)
      IF (ILAST.EQ.0) GO TO 100
      ENDIF
C
C     SCAN FOR A DATE VALUE (IE. A MONTH)
      DO 40 I=1,12
      J = INDEX (CVAR, CMON(I))
      IF (J.GT.0) GO TO 60
 40   CONTINUE
      J = INDEX (CVAR, '/')
C
 60   CONTINUE
      IF (J.NE.0) THEN
C     IT IS A DATE
      CALL DATJUL (CVAR,JUL,IERROR)
      IF (IERROR.EQ.-1) GO TO 900
C     BEGINNING DATE OR ENDING DATE?
      IF (.NOT.LSDATE) THEN
      JULS = JUL
      LSDATE = .TRUE.
      ELSE IF (.NOT.LEDATE) THEN
      JULE = JUL
      LEDATE = .TRUE.
      ELSE
      GO TO 900
      ENDIF
      GO TO 100
      ENDIF
C
C     NO DATE FOUND
C     EITHER A TIME, OR A TIME OFFSET (EG. T-36H)
C     SCAN FOR A TIME VALUE
      J = NSCAN ( CVAR, 1, 5, '1234567890: ', 1, 12)
      IF (J.NE.0) GO TO 80
C
C     A TIME VALUE (EG. 0900)
      ITIME = IHM2M (CVAR)
      IF (ITIME.LT.0) GO TO 900
C     BEGINNING OR ENDING TIME?
      IF (.NOT.LSTIME) THEN
      ISTIME = ITIME
      LSTIME = .TRUE.
      ELSE
      IF ((N.EQ.2).AND.(LCUR)) THEN
      ISTIME = ITIME
      LSTIME = .TRUE.
      ELSE
      IETIME = ITIME
      ENDIF
      ENDIF
C
      GO TO 100
C
C
C     MUST BE A TIME OFFSET (EG. -36H)
 80   CONTINUE
      CALL CHRLNB (CVAR, NVAR)
      J = INDEX ('YMDH', CVAR(NVAR:NVAR))
      IF (J.EQ.0) GO TO 900
      NPER = INTGR (CVAR,1,NVAR-1,IERR)
      IF (IERR.NE.0) GO TO 900
C
      IF (LSTART) THEN
      J = INCTIM (INTL(J), 0, NPER, JULS, ISTIME, JULS, ISTIME)
      ELSE
      J = INCTIM (INTL(J), 0, NPER, JULE, IETIME, JULE, IETIME)
      ENDIF
C
 100  CONTINUE
C
      IF (LENDFL) THEN
      NFIELD = 1
      GO TO 20
      ENDIF
C
C
 800  CONTINUE
      RETURN
C
C
 900  CONTINUE
      ISTAT = -1
      JULS = ITIME_UNDEF
      JULE = ITIME_UNDEF
      ISTIME = -1
      IETIME = -1
      RETURN
C
      END


      integer lbjscheme
      logical jetsopphem
      double precision leptpt,leptrap,misspt,Rjlmin,Rllmin,delyjjmin,
     & leptpt2,leptrap2,gammpt,gammrap,Rgalmin,mtrans34cut,
     & gammpt2,Rgagamin,gammpt3,Rgajetmin,
     & leptveto1min,leptveto1max,leptveto2min,leptveto2max
      common/leptcuts/leptpt,leptrap,misspt,Rjlmin,Rllmin,delyjjmin,
     & leptpt2,leptrap2,gammpt,gammrap,Rgalmin,mtrans34cut,
     & gammpt2,Rgagamin,gammpt3,Rgajetmin,
     & lbjscheme,jetsopphem,
     & leptveto1min,leptveto1max,leptveto2min,leptveto2max


      SUBROUTINE DERIV(GEO,GRAD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION GRAD(*), GEO(3,*)
      COMMON / EULER/ TVEC(3,3), ID
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMMY(MAXPAR)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GRAVEC/ COSINE
      COMMON /GEOSYM/ NDEP, IDUMYS(MAXPAR,3)
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U
      COMMON /XYZGRA/ DXYZ(3,NUMATM*27)
      COMMON /ENUCLR/ ENUCLR
      COMMON /NUMCAL/ NUMCAL
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC)
      COMMON /HMATRX/ H(MPACK)
      COMMON /ATHEAT/ ATHEAT
C***********************************************************************
C
C    DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE
C          INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES.
C
C    THE MAIN ARRAYS IN DERIV ARE:
C        LOC    INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM
C               INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE
C               DERIVATIVE CALCULATION.
C        GEO    ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES.
C        GRAD   ON EXIT, CONTAINS THE DERIVATIVES
C
C***********************************************************************
      COMMON /KEYWRD / KEYWRD
      COMMON /ERRFN  / ERRFN(MAXPAR)
      CHARACTER*80 KEYWRD
      DIMENSION CHANGE(3), COORD(3,NUMATM), COLD(3,NUMATM*27)
     1,         XDERIV(3), XPARAM(MAXPAR), XJUC(3), W(N2ELEC)
      REAL WJ, WK
      LOGICAL DEBUG, TIMES, HALFE, FAST, SCF1, CI, PRECIS
      EQUIVALENCE (W,WJ)
      DATA ICALCN /0/
      IF(ICALCN.NE.NUMCAL) THEN
         I = INDEX(KEYWRD,'PRESS')
         PRESS=0.D0
         IF(I.NE.0) PRESS=READA(KEYWRD,I)*1476.8992D0
         IDLO=NATOMS+1
         IF(LABELS(NATOMS) .EQ. 107) THEN
            IDLO=NATOMS
            IF(LABELS(NATOMS-1) .EQ. 107)THEN
               IDLO=NATOMS-1
               IF(LABELS(NATOMS-2) .EQ. 107)THEN
                  IDLO=NATOMS-2
               ENDIF
            ENDIF
         ENDIF
         GRLIM=0.01D0
         DEBUG = (INDEX(KEYWRD,'DERIV') .NE. 0)
         PRECIS= (INDEX(KEYWRD,'PRECIS') .NE. 0)
         TIMES = (INDEX(KEYWRD,'TIME') .NE. 0)
         CI    = (INDEX(KEYWRD,'C.I.') .NE. 0)
         SCF1  = (INDEX(KEYWRD,'1SCF') .NE. 0)
         ICALCN=NUMCAL
         IF(INDEX(KEYWRD,'RESTART') .EQ. 0) THEN
            DO 10 I=1,NVAR
   10       ERRFN(I)=0.D0
         ENDIF
         GRLIM=0.01D0
         IF(PRECIS)GRLIM=0.0001D0
         IF(INDEX(KEYWRD,'FULSCF') .GT.0) GRLIM=1.D9
         HALFE = (NOPEN.GT.NCLOSE .OR. CI)
         IDELTA=-7
*
*   IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER
*
         IF(HALFE.AND.PRECIS) IDELTA=-3
         IF(HALFE.AND..NOT.PRECIS) IDELTA=-3
         FAST=.TRUE.
         CHANGE(1)= 10.D0**IDELTA
         CHANGE(2)= 10.D0**IDELTA
         CHANGE(3)= 10.D0**IDELTA
C
C    CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES.
C    FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN
C    INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE
C    HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF
C    CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL
C    ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND
C    DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO
C    FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH,
C    (2) FOR ANGLE, AND (3) FOR DIHEDRAL.
C
         XDERIV(1)= 0.5D0/CHANGE(1)
         XDERIV(2)= 0.5D0/CHANGE(2)
         XDERIV(3)= 0.5D0/CHANGE(3)
      ENDIF
      GNORM=0.D0
      IF(NVAR.EQ.0) RETURN
      IF(DEBUG)THEN
         WRITE(6,'('' GEO AT START OF DERIV'')')
         WRITE(6,'(F19.5,2F12.5)')((GEO(J,I),J=1,3),I=1,NATOMS)
      ENDIF
      DO 20 I=1,NVAR
         XPARAM(I)=GEO(LOC(2,I),LOC(1,I))
   20 GNORM=GNORM+GRAD(I)**2
      GNORM=SQRT(GNORM)
      FAST=(GNORM .GT. GRLIM .AND. .NOT. SCF1 .OR. .NOT. HALFE)
      TIME1=SECOND()
      IF(NDEP.NE.0) CALL SYMTRY
      CALL GMETRY(GEO,COORD)
      IF( .NOT. FAST ) THEN
         IF(DEBUG)WRITE(6,'('' DOING FULL SCF''''S IN DERIV'')')
         CALL HCORE(COORD,H,W, WJ, WK, ENUCLR)
         IF(NORBS*NELECS.GT.0)THEN
            CALL ITER(H, W, WJ, WK, AA,.TRUE.,.FALSE.)
         ELSE
            AA=0.D0
         ENDIF
         LINEAR=(NORBS*(NORBS+1))/2
         DO 30 I=1,LINEAR
   30    P(I)=PA(I)*2.D0
         AA=(AA+ENUCLR)
      ENDIF
      CALL DCART(COORD,DXYZ)
      IF(NDEP.NE.0) CALL SYMTRY
      CALL GMETRY(GEO,COORD)
      IJ=0
      DO 70 II=1,NUMAT
         DO 60 IL=L1L,L1U
            DO 60 JL=L2L,L2U
               DO 60 KL=L3L,L3U
                  DO 40 LL=1,3
   40             XJUC(LL)=COORD(LL,II)+TVEC(LL,1)*IL+TVEC(LL,2)*JL+TVEC
     1(LL,3)*KL
                  IJ=IJ+1
                  DO 50 KK=1,3
                     COLD(KK,IJ)=XJUC(KK)
   50             CONTINUE
   60    CONTINUE
   70 CONTINUE
      SUM11=1.D-9
      SUM22=1.D-9
      SUM12=1.D-9
      DO 150 I=1,NVAR
         K=LOC(1,I)
         L=LOC(2,I)
         XSTORE=XPARAM(I)
         DO 80 J=1,NVAR
   80    GEO(LOC(2,J),LOC(1,J))=XPARAM(J)
         GEO(L,K)=XSTORE-CHANGE(L)
         IF(NDEP.NE.0) CALL SYMTRY
         CALL GMETRY(GEO,COORD)
C#         CALL GEOUT
C
C    USE LOOKUP TABLE OF CARTESIAN DERIVATIVES TO WORK OUT INTERNAL
C    COORDINATE DERIVATIVE.
C
         TOTL=0.D0
         IJ=0
         DO 130 II=1,NUMAT
            IF(ID.EQ.0) THEN
               DO 90 LL=1,3
   90          TOTL=TOTL+DXYZ(LL,II)*(COORD(LL,II)-COLD(LL,II))
            ELSE
               DO 120 IL=L1L,L1U
                  DO 120 JL=L2L,L2U
                     DO 120 KL=L3L,L3U
                        DO 100 LL=1,3
  100                   XJUC(LL)=COORD(LL,II)+TVEC(LL,1)*IL+TVEC(LL,2)*J
     1L+TVEC(LL,3)*KL
                        IJ=IJ+1
                        DO 110 KK=1,3
                           TOTL=TOTL+DXYZ(KK,IJ)*(XJUC(KK)-COLD(KK,IJ))
  110                   CONTINUE
  120          CONTINUE
            ENDIF
  130    CONTINUE
         TOTL=TOTL*XDERIV(L)
C
C   IF NEEDED, CALCULATE "EXACT" DERIVITIVES.
C
         IF( .NOT. FAST ) THEN
            CALL HCORE(COORD,H,W, WJ, WK,ENUCLR)
            IF(NORBS*NELECS.GT.0)THEN
               CALL ITER(H,W, WJ, WK,EE,.TRUE.,.FALSE.)
            ELSE
               EE=0.D0
            ENDIF
            DO 140 II=1,LINEAR
  140       P(II)=PA(II)*2.D0
            EE=(EE+ENUCLR)
            TOTL1=(AA-EE)*23.061D0*XDERIV(L)*2.D0
C#            WRITE(6,*)AA-EE
            ERRFN(I)=TOTL1-TOTL
         ENDIF
         GEO(L,K)=XSTORE
         SUM11=SUM11+GRAD(I)**2
         SUM22=SUM22+TOTL**2
         SUM12=SUM12+TOTL*GRAD(I)
         GRAD(I)=TOTL+ERRFN(I)
  150 CONTINUE
      IF(DEBUG) THEN
         WRITE(6,'('' GRADIENTS'')')
         WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR)
         WRITE(6,'('' ERROR FUNCTION'')')
         WRITE(6,'(10F8.3)')(ERRFN(I),I=1,NVAR)
      ENDIF
      COSINE=SUM12/SQRT(SUM11*SUM22)
      IF(DEBUG)
     1WRITE(6,'('' COSINE OF SEARCH DIRECTION ='',F30.6)')COSINE
      IF( .NOT. FAST ) COSINE=1.D0
      IF(TIMES)
     1WRITE(6,'('' TIME FOR DERIVATIVES'',F12.6)')SECOND()-TIME1
      RETURN
      END


      program ABNBderivatives

c this program evaluates the contribution to the energy derivatives
c wrt atomic coordinates that arises from the Level1-Level1
c ab initio jobs. The atoms are only those contained in the
c ab initio fragments.
c The input file(s) contain forces (hessians) from the Level 1
c fragment pair, followed by the corresponding forces (hessians)
c for each separate fragment.

      implicit double precision(a-h,o-z)

      real*8, allocatable   :: g(:,:),h(:,:),w1(:,:,:)
      integer, allocatable   :: nat1(:),num1(:,:),natnum1(:,:,:)

      integer, allocatable   :: num(:),natnum(:,:)
      real*8, allocatable   :: w(:,:)

      dimension abforce(3,200,3), fc(3,600,600)
c this assumes that two Level 1 fragments will not have a combined
c number of atoms exceeding 200. Very likely safe.

      character*20 ca1,ca2
      character*30 ca

c get the jobtype
      open(unit=1,file='IN_JOBTYPE',status='old')
      read(1,*)
      read(1,*)jobtype
      close(unit=1)

c this program should only be called if jobtype=1 (gradients)
c or jobtype=2 (hessians)
      if(jobtype.eq.0)then
       write(6,*)' called ABNBderivatives when jobtype  neither 1 or 2'
       stop
      endif

c get the number of atoms in the whole molecule
      open(unit=1,file='name.xyz',status='old')
      read(1,*)natom
      close(unit=1)

c allocate the gradient (g) and hessian (h) for the whole molecule
      allocate(g(natom,3))
      allocate(h(3*natom,3*natom))
      allocate(num(natom))
      allocate(natnum(natom,6))
      allocate(w(natom,6))

      do n=1,natom
      do k=1,3
       g(n,k)=0.d0
      enddo
      enddo

      h=0

c get the Lev1 identities
c OUT_Lev1_ATOMALLOCATION identifies the atom numbering in the whole
c molecule for the atoms in the Level 1 fragments
      open(unit=1,file='OUT_Lev1_ATOMALLOCATION',status='old')
      read(1,*,end=900)
      read(1,*)NL1
c NL1 is the number of Level 1 fragments
      read(1,*)
      read(1,*)
      allocate(nat1(NL1))
c nat1 = the number of atoms in the fragment
      allocate(num1(NL1,200))
c num1=1 for a real atom, num1=2 for a cap
c allocation assumes no more than 200 atoms in a Level 1 fragment
      allocate(natnum1(NL1,200,6))
c natnum1 = the whole molecule atom number
      allocate(w1(NL1,200,6))
c in the case of caps, w1 = the weight this cap has on a real atom

      do n=1,NL1
       read(1,*)i1,nat1(n)
       do m=1,nat1(n)
        read(1,*)num1(n,m),
     .           (natnum1(n,m,k),w1(n,m,k),k=1,num1(n,m))
       enddo
      enddo

      close(unit=1)

      open(unit=2,file='abforces',status='unknown')
c abforces contins the forces extracted from the nonbonded
c ab initio jobs
      if(jobtype.eq.2)then
      open(unit=3,file='abhessians',status='unknown')
c abhessians contains the hessions extracted from the nonbonded
c ab initio jobs

      endif

c read in the number of ab jobs
c njobs is the total number of Level1-Level1 ab initio jobs
      read(2,*,end=127)njobs
      go to 128
127   continue
      stop
128   continue

       if(jobtype.eq.2)then
        read(3,*)
       endif

      do n=1,njobs
c read the two L1 indices
       read(2,*)n1,n2
c n1 and n2 identify the Level 1 fragments, whose atom numbers were
c read from OUT_Lev1_ATOMALLOCATION above

c read the sign
       read(2,*)nsign
c nsign is the coeffiient of the fragment pair in the sum
c over contributions to the nonbonded energy

c read the number of atoms in the ab file
       read(2,*)nat2
c nat2 = the number of atoms in the pair
c read the forces for the n1 n2 pair
c      read(2,*)
c      read(2,*)
c      read(2,*)
       do m=1,nat2
        read(2,*)i1,i2,(abforce(1,m,k),k=1,3)
       enddo
c i1 and i2 are not needed here
c      read(2,*)
c      read(2,*)
c      read(2,*)
c      read(2,*)
       read(2,*)
       read(2,*)
c read the forces for n1
       do m=1,nat1(n1)
        read(2,*)i1,i2,(abforce(2,m,k),k=1,3)
       enddo
c i1 and i2 are not needed here
c      read(2,*)
c      read(2,*)
c      read(2,*)
c      read(2,*)
       read(2,*)
       read(2,*)
c read the forces for n2
       do m=1,nat1(n2)
        read(2,*)i1,i2,(abforce(3,m,k),k=1,3)
       enddo
c i1 and i2 are not needed here
c      read(2,*)

       if(jobtype.eq.2)then
c read the second derivatives, lower triangle
c first the n1, n2 pair
        read(3,*)
        read(3,*)
        read(3,*)
        n3=3*nat2
       do i=1,n3
       do j=1,i
        read(3,*)fc(1,i,j)
       enddo
       enddo
c make fc symmetric
       do i=1,n3
       do j=i,n3
       fc(1,i,j)=fc(1,j,i)
       enddo
       enddo
c then read the n1 fragment data
        read(3,*)
        read(3,*)
        n3=3*nat1(n1)
       do i=1,n3
       do j=1,i
        read(3,*)fc(2,i,j)
       enddo
       enddo
c make fc symmetric
       do i=1,n3
       do j=i,n3
       fc(2,i,j)=fc(2,j,i)
       enddo
       enddo
        read(3,*)
        read(3,*)
c then read the n2 fragment data
        n3=3*nat1(n2)
       do i=1,n3
       do j=1,i
        read(3,*)fc(3,i,j)
       enddo
       enddo
c make fc symmetric
       do i=1,n3
       do j=i,n3
       fc(3,i,j)=fc(3,j,i)
       enddo
       enddo
c end the jojtype if
       endif

c allocate gradients
c first make a combined set of identities for n1 and n2
      num=0
      natnum=0
      w=0
      do m=1,nat1(n1)
       num(m)=num1(n1,m)
       do l=1,num(m)
       natnum(m,l)=natnum1(n1,m,l)
       w(m,l)=w1(n1,m,l)
       enddo
      enddo
      do m=1,nat1(n2)
       num(nat1(n1)+m)=num1(n2,m)
       do l=1,num1(n2,m)
        natnum(nat1(n1)+m,l)=natnum1(n2,m,l)
        w(nat1(n1)+m,l)=w1(n2,m,l)
       enddo
      enddo
      nat=nat1(n1)+nat1(n2)

       do m=1,nat1(n1)
       do j=1,num1(n1,m)
       do k=1,3
        g(natnum1(n1,m,j),k)=g(natnum1(n1,m,j),k)-nsign*
     .                   (abforce(1,m,k)-abforce(2,m,k))*w1(n1,m,j)
c the - sign in "-nsign" converts forces to gradients
c the weight w1=1 for real atoms, or a fraction for caps
       enddo
       enddo
       enddo
       do m=1,nat1(n2)
        m1=m+nat1(n1)
       do j=1,num1(n2,m)
       do k=1,3
        g(natnum1(n2,m,j),k)=g(natnum1(n2,m,j),k)-nsign*
     .                   (abforce(1,m1,k)-abforce(3,m,k))*w1(n2,m,j)
       enddo
       enddo
       enddo

c allocate hessians
c first from the pair
       if(jobtype.eq.2)then
        do k1=1,3
        do k2=1,3
        do i1=1,nat
        do i2=1,nat
         l1=3*(i1-1)+k1
         l2=3*(i2-1)+k2
        do j1=1,num(i1)
        do j2=1,num(i2)
         m1=3*(natnum(i1,j1)-1)+k1
         m2=3*(natnum(i2,j2)-1)+k2
         h(m1,m2)=h(m1,m2)+fc(1,l1,l2)*w(i1,j1)*w(i2,j2)*nsign
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo
c then subtract the n1 fragment
        do k1=1,3
        do k2=1,3
        do i1=1,nat1(n1)
        do i2=1,nat1(n1)
         l1=3*(i1-1)+k1
         l2=3*(i2-1)+k2
        do j1=1,num1(n1,i1)
        do j2=1,num1(n1,i2)
         m1=3*(natnum1(n1,i1,j1)-1)+k1
         m2=3*(natnum1(n1,i2,j2)-1)+k2
         h(m1,m2)=h(m1,m2)-fc(2,l1,l2)*w1(n1,i1,j1)*w1(n1,i2,j2)*nsign
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo
c then subtract the n2 fragment
        do k1=1,3
        do k2=1,3
        do i1=1,nat1(n2)
        do i2=1,nat1(n2)
         l1=3*(i1-1)+k1
         l2=3*(i2-1)+k2
        do j1=1,num1(n2,i1)
        do j2=1,num1(n2,i2)
         m1=3*(natnum1(n2,i1,j1)-1)+k1
         m2=3*(natnum1(n2,i2,j2)-1)+k2
         h(m1,m2)=h(m1,m2)-fc(3,l1,l2)*w1(n2,i1,j1)*w1(n2,i2,j2)*nsign
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo

c end the jobtype if
      endif

c end the loop over ab jobs (njobs)
      enddo
      close(unit=2)

900   continue
c output
      open(unit=1,file='combinedABNBderivs',status='unknown')
      write(1,*)jobtype
      write(1,*)natom
      do n=1,natom
       write(1,100)(g(n,k),k=1,3)
      enddo
100   format(6f10.6)
      if(jobtype.eq.2)then
        n3=3*natom
        write(1,100)((h(i,j),j=1,i),i=1,n3)
      endif

      close(unit=1)
      end


      PROGRAM MAIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON /KEYWRD/ KEYWRD
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /NUMCAL/ NUMCAL
      COMMON /TIME  / TIME0
      COMMON /PATH  / LATOM,LPARAM,REACT(100)
      CHARACTER*80 KEYWRD
      OPEN(UNIT=5,FILE='FOR005',STATUS='OLD',BLANK='ZERO')
      REWIND 5
      OPEN(UNIT=6,FILE='FOR006',STATUS='NEW')
      REWIND 6
      NUMCAL=1
C
      TIME0=SECOND()
C
C READ AND CHECK INPUT FILE, EXIT IF NECESSARY.
C     WRITE INPUT FILE TO UNIT 6 AS FEEDBACK TO USER
C
   10 CALL READ
      IF(INDEX(KEYWRD,'AUTHOR') .NE. 0)
     1WRITE(6,'(30X,'' MOPAC - A GENERAL MOLECULAR ORBITAL PACKAGE'',/
     2         ,10X,''   ORIGINAL VERSION WRITTEN IN 1983'',/
     3         ,10X,''     BY JAMES J. P. STEWART AT THE'',/
     4         ,10X,''     UNIVERSITY OF TEXAS AT AUSTIN'',/
     5         ,10X,''          AUSTIN, TEXAS, 78712'')')
C
C INITIALIZE CALCULATION AND WRITE CALCULATION INDEPENDENT INFO
C
      IF(INDEX(KEYWRD,'0SCF') .NE. 0) STOP
      IF(INDEX(KEYWRD,'EXTERNAL') .NE. 0) THEN
         CALL AM1
      ELSE
         CALL MOLDAT
      ENDIF
C
C CALCULATE
C
C
      IF(INDEX(KEYWRD,' DRC') .NE. 0) THEN
         CALL DRC
         STOP
      ENDIF
      IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN
         CALL REACT1(ESCF)
         GOTO 40
      ENDIF
      CLOSE (5)
      IF(INDEX(KEYWRD,'STEP1') .NE. 0) THEN
         CALL GRID
         STOP
      ENDIF
      IF (LATOM .NE. 0) THEN
C
C       DO PATH
C
         CALL PATHS
         STOP
      END IF
      IF (INDEX(KEYWRD,'FORCE') .NE. 0 ) THEN
C
C FORCE CALCULATION IF DESIRED
C
         CALL FORCE
         STOP
      ENDIF
C
      IF(INDEX(KEYWRD,'NLLSQ') .NE. 0) THEN
         CALL NLLSQ(XPARAM, NVAR )
         CALL COMPFG(XPARAM,.TRUE.,ESCF,.TRUE.,GRAD,.TRUE.)
         GOTO 40
      ENDIF
C
      IF (INDEX(KEYWRD,'RESTART').EQ.0.AND.
     1        INDEX(KEYWRD,'1SCF') .NE. 0) THEN
         NVAR=0
         IF(INDEX(KEYWRD,'GRAD').NE.0) THEN
            NVAR=0
            DO 30 I=2,NATOMS
               IF(LABELS(I).EQ.99) GOTO 30
               IF(I.EQ.2)ILIM=1
               IF(I.EQ.3)ILIM=2
               IF(I.GT.3)ILIM=3
               DO 20 J=1,ILIM
                  NVAR=NVAR+1
                  LOC(1,NVAR)=I
                  LOC(2,NVAR)=J
   20          XPARAM(NVAR)=GEO(J,I)
   30       CONTINUE
         ENDIF
      ENDIF
      IF(INDEX(KEYWRD,'SIGMA') .NE. 0) THEN
         CALL POWSQ(XPARAM, NVAR, ESCF)
         GOTO 40
      ENDIF
C
C ORDINARY GEOMETRY OPTIMISATION
C
      CALL FLEPO(XPARAM, NVAR, ESCF)
   40 CALL WRITE(TIME0, ESCF)
      IF(INDEX(KEYWRD,'POLAR') .NE. 0) THEN
         CALL POLAR
      ENDIF
      END