      PROGRAM AAAAAA 
C 
C .... AMPAC ... VERSION 2.1 ... CRAY VERSION ... FEBRUARY 1987 
C 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
      COMMON /BASEOC/ BDUM(NMECI),IBDUM(NMECI+2) 
      COMMON /CIDATA/ CIDUM(NMECI**2+1),ICIDUM(3+(1+2*NMECI)*NMECI**2) 
      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), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /LAST  / ILAST(2) 
      COMMON /MESAGE/ IFLEPO,IITER 
      COMMON /NUMCAL/ NUMCAL 
C     /OPTIM/ AS USED IN CHAIN ROUTINE 
C     COMMON /OPTIM / IMP,IMP0,LEC,IPRT,DUM1(MAXHES+NCHAIN+29+MAXPAR* 
C    .                (16+NCHAIN+2*MAXPAR)),IDUM1(22+3*NCHAIN) 
C     /OPTIM/ AS USED IN SEARCH ROUTINE 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,DUM1(3*MAXPAR**2+12*MAXPAR+ 
     .                MAXHES+4),IDUM1(2) 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /PRECI / SCFCV,SCFTOL,DUM2(9),KTYP(MAXPAR) 
C     /SCRACH/ AS USED IN DIAGIV ROUTINE 
      COMMON /SCRACH/ DUM3(3*MAXPAR**2) 
C     /SCRACH/ AS USED IN DERI1 ROUTINE 
C     COMMON /SCRACH/ DUM3(NMECI*(NMECI+1)*NUMATM*5 + MORB2) 
C     /SCRACH/ AS USED IN NMECI FUNCTION 
C     COMMON /SCRACH/ DUM3(2*NMECI**2*(2+NMECI**2)),IDUM3(12*NMECI**2) 
C     /SCRAH1/ AS USED IN DERIV ROUTINE 
C     COMMON /SCRAH1/ DUM4(MPACK+1+9*MAXPAR),IDUM4(4) 
C     /SCRAH1/ AS USED IN MECI FUNCTION 
      COMMON /SCRAH1/ DUM4(2*NMECI**2*(NMECI**2+2)),IDUM4(12*NMECI**2) 
      COMMON /SCRAH2/ DUM5(NRELAX*MORB2) 
      COMMON /TIME  / TIME0 
      COMMON /XYIJKL/ XYDUM(NMECI**4) 
      COMMON /WMATRX/ W(N2ELEC*3),NUMBW,NBAND(NUMATM) 
      CHARACTER*80 KEYWRD 
      LOGICAL FAIL 
C 
C I/O LOGICAL UNIT NUMBER 
C     PLEASE, AVOID THESE DEDICATED NUMBERS :  8,9,10,12,13,15 
C             UNIT 8 ... 
C             UNIT 9 ... FORCE CONSTANT MATRIX... 
C                     OR RESTART FILE FOR OPTIMIZATION 
C             UNIT 10... DENSITY MATRICES 
C             UNIT 12... 
C             UNIT 13... DATA FOR GRAPHICS 
C             UNIT 15... MO COEFFICIENTS 
C 
      LEC= 5 
      IPRT=6 
C 
      NUMCAL=1 
      CALL SECOND (TIME0) 
C 
C READ AND CHECK INPUT FILE, EXIT IF NECESSARY. 
C     WRITE INPUT FILE TO UNIT IPRT AS FEEDBACK TO USER 
C 
      CALL READ 
      IF(INDEX(KEYWRD,'0SCF').NE.0) STOP 
C 
C INITIALIZE CALCULATION AND WRITE CALCULATION INDEPENDENT INFO 
C 
      IF(INDEX(KEYWRD,'EXTERNAL') .NE. 0) THEN 
         CALL AM1 
      ELSE 
         CALL MOLDAT 
      ENDIF 
C 
C CALCULATE IF 1SCF NOT REQUIRED 
C 
      IF(INDEX(KEYWRD,'1SCF') .NE. 0) GO TO 10 
C 
C     SECTION TRAJECTORY 
C     ------------------ 
      IF(INDEX(KEYWRD,'DRC'  ) .NE. 0) THEN 
C     FOLLOW THE DYNAMIC REACTION COORDINATE 
         CALL DRC 
         STOP 
      ENDIF 
      IF(INDEX(KEYWRD,'PATH' ) .NE. 0) THEN 
C     FOLLOW THE STATIC REACTION PATH 
         CALL PATH (IND,XPARAM,ESCF,GRAD,NVAR) 
         GO TO 100 
      ENDIF 
C 
C     SECTION TRANSITION STATE SEARCH 
C     ------------------------------- 
      IF(INDEX(KEYWRD,'SADD') .NE. 0) THEN 
C     USING THE 'SADDLE' METHOD 
         CALL REACT1(ESCF) 
         STOP 
      ENDIF 
      IF(INDEX(KEYWRD,'CHAI') .NE. 0) THEN 
C     USING THE 'CHAIN' METHOD 
         CALL CHAIN (IND,XPARAM,ESCF,GRAD,NVAR) 
         GO TO 100 
      ENDIF 
      IF (LATOM                .NE. 0) THEN 
C     USING A REACTION COORDINATE 
         CALL PATHS 
         STOP 
      ENDIF 
C 
C     SECTION 2-D GRID 
C     ---------------- 
      IF(INDEX(KEYWRD,'STEP1') .NE. 0) THEN 
         CALL GRID 
         STOP 
      ENDIF 
C 
C     SECTION MINIMISATION OF THE GRADIENT NORM 
C     ----------------------------------------- 
      IF(INDEX(KEYWRD,'NLLS') .NE. 0) THEN 
C     USING NONLINEAR LEAST SQUARE METHOD 
         CALL NLLSQ(XPARAM, NVAR, ESCF, GRAD ) 
         GOTO 100 
      ENDIF 
      IF(INDEX(KEYWRD,'SIGM') .NE. 0) THEN 
C     USING MAC IVER KOMORNICKI METHOD 
         CALL POWSQ(XPARAM,NVAR,ESCF) 
         GO TO 100 
      ENDIF 
      IF(INDEX(KEYWRD,'POWE') .NE. 0) THEN 
C     USING POWELL ALGORITHM 
         CALL POWELL(IND,XPARAM,ESCF,GRAD,NVAR) 
         GO TO 100 
      ENDIF 
C 
C     SECTION SECOND DERIVATIVES 
C     -------------------------- 
      IF(INDEX(KEYWRD,'FORC') .NE. 0) THEN 
C     THERMODYNAMIC WITH THE 'FORCE' ALGORITHM 
         CALL FORCE 
         STOP 
      ENDIF 
      IF(INDEX(KEYWRD,'LTRD') .NE. 0) THEN 
C     GRADIENT MINIMISATION USING THE FULL NEWTON METHOD 
         IND=2 
         CALL LTRD(IND,XPARAM,ESCF,GRAD,NVAR) 
         GO TO 100 
      ENDIF 
      IF(INDEX(KEYWRD,'NEWT') .NE. 0) THEN 
C     ENERGY MINIMISATION USING THE FULL NEWTON METHOD 
         IND=1 
         CALL LTRD(IND,XPARAM,ESCF,GRAD,NVAR) 
         GO TO 100 
      ENDIF 
C 
C     SECTION ENERGY MINIMIZATION OR SINGLE CALCULATION 
C     ------------------------------------------------- 
   10 IF(INDEX(KEYWRD,'REST')   .EQ. 0 .AND. 
     1   INDEX(KEYWRD,'1SCF')   .NE. 0) THEN 
C     DO A SINGLE CALCULATION ... 
         NVAR=0 
         IF(INDEX(KEYWRD,'GRAD').NE.0) THEN 
C     WITH A SINGLE GRADIENT COMPUTATION 
            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 
C     ORDINARY GEOMETRY OPTIMISATION (DFP METHOD) 
      CALL FLEPO(XPARAM, NVAR, ESCF) 
C 
C     SECTION FINAL PRINTING 
C     ---------------------- 
  100 CALL WRITE(TIME0, ESCF) 
      IF(INDEX(KEYWRD,'POLAR') .NE. 0) THEN 
C     WITH POLARISATION COMPUTATION 
         CALL POLAR 
      ENDIF 
      END 
      FUNCTION AABABC(IOCCA1, IOCCB1, IOCCA2, IOCCB2, NMOS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION IOCCA1(NMOS), IOCCB1(NMOS), IOCCA2(NMOS), IOCCB2(NMOS) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
* AABABC EVALUATES THE C.I. MATRIX ELEMENT FOR TWO MICROSTATES DIFFERING 
*       BY BETA ELECTRON. THAT IS, ONE MICROSTATE HAS A BETA ELECTRON 
*       IN PSI(I) WHICH, IN THE OTHER MICROSTATE IS IN PSI(J) 
* 
*********************************************************************** 
      COMMON /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
      COMMON /BASEOC/ OCCA(NMECI) 
       SAVE
      DO 10 I=1,NMOS 
   10 IF(IOCCA1(I).NE.IOCCA2(I)) GOTO 20 
   20 IJ=IOCCB1(I) 
      DO 30 J=I+1,NMOS 
         IF(IOCCA1(J).NE.IOCCA2(J)) GOTO 40 
   30 IJ=IJ+IOCCA1(J)+IOCCB1(J) 
   40 SUM=0.D0 
      DO 50 K=1,NMOS 
   50 SUM=SUM+ (XY(I,J,K,K)-XY(I,K,J,K))*(IOCCA1(K)-OCCA(K)) + 
     1          XY(I,J,K,K)             *(IOCCB1(K)-OCCA(K)) 
      AABABC=SUM*FLOAT(1-2*MOD(IJ,2)) 
      RETURN 
      END 
      FUNCTION AABACD(IOCCA1, IOCCB1, IOCCA2, IOCCB2, NMOS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION IOCCA1(NMOS), IOCCB1(NMOS), IOCCA2(NMOS), IOCCB2(NMOS) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
* AABACD EVALUATES THE C.I. MATRIX ELEMENT FOR TWO MICROSTATES DIFFERING 
*       BY TWO ALPHA MOS. ONE MICROSTATE HAS ALPHA ELECTRONS IN 
*       M.O.S PSI(I) AND PSI(J) FOR WHICH THE OTHER MICROSTATE HAS 
*       ELECTRONS IN PSI(K) AND PSI(L) 
* 
*********************************************************************** 
      COMMON /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
       SAVE
      IJ=0 
      DO 10 I=1,NMOS 
   10 IF(IOCCA1(I) .LT. IOCCA2(I)) GOTO 20 
   20 DO 30 J=I+1,NMOS 
         IF(IOCCA1(J) .LT. IOCCA2(J)) GOTO 40 
   30 IJ=IJ+IOCCA2(J)+IOCCB2(J) 
   40 DO 50 K=1,NMOS 
   50 IF(IOCCA1(K) .GT. IOCCA2(K)) GOTO 60 
   60 DO 70 L=K+1,NMOS 
         IF(IOCCA1(L) .GT. IOCCA2(L)) GOTO 80 
   70 IJ=IJ+IOCCA1(L)+IOCCB1(L) 
   80 IJ=IJ+IOCCB2(I)+IOCCB1(K) 
      AABACD=(XY(I,K,J,L)-XY(I,L,K,J))*FLOAT(1-2*MOD(IJ,2)) 
      RETURN 
      END 
      FUNCTION AABBCD(IOCCA1, IOCCB1, IOCCA2, IOCCB2, NMOS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION IOCCA1(NMOS), IOCCB1(NMOS), IOCCA2(NMOS), IOCCB2(NMOS) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
* AABBCD EVALUATES THE C.I. MATRIX ELEMENT FOR TWO MICROSTATES DIFFERING 
*       BY TWO SETS OF M.O.S. ONE MICROSTATE HAS AN ALPHA ELECTRON 
*       IN PSI(I) AND A BETA ELECTRON IN PSI(K) FOR WHICH THE OTHER 
*       MICROSTATE HAS AN ALPHA ELECTRON IN PSI(J) AND A BETA ELECTRON 
*       IN PSI(L) 
* 
*********************************************************************** 
      COMMON /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
      COMMON /SPQR/ ISPQR(100,10),IS,ILOOP, JLOOP 
       SAVE
      DO 10 I=1,NMOS 
   10 IF(IOCCA1(I) .NE. IOCCA2(I)) GOTO 20 
   20 DO 30 J=I+1,NMOS 
   30 IF(IOCCA1(J) .NE. IOCCA2(J)) GOTO 40 
   40 DO 50 K=1,NMOS 
   50 IF(IOCCB1(K) .NE. IOCCB2(K)) GOTO 60 
   60 DO 70 L=K+1,NMOS 
   70 IF(IOCCB1(L) .NE. IOCCB2(L)) GOTO 80 
   80 IF( I.EQ.K .AND. J.EQ.L .AND. IOCCA1(I).NE.IOCCB1(I)) THEN 
         ISPQR(ILOOP,IS)=JLOOP 
         IS=IS+1 
      ENDIF 
      IF(IOCCA1(I) .LT. IOCCA2(I)) THEN 
         M=I 
         I=J 
         J=M 
      ENDIF 
      IF(IOCCB1(K) .LT. IOCCB2(K)) THEN 
         M=K 
         K=L 
         L=M 
      ENDIF 
      XR=XY(I,J,K,L) 
C#      WRITE(6,'(4I5,F12.6)')I,J,K,L,XR 
C 
C   NOW UNTANGLE THE MICROSTATES 
C 
      IJ=1 
      IF( I.GT.K .AND. J.GT.L .OR. I.LE.K .AND. J.LE.L)IJ=0 
      M=J 
      J=K 
      K=M 
      IF( I.GT.J ) IJ=IJ+IOCCA1(J)+IOCCB1(I) 
      IF( K.GT.L ) IJ=IJ+IOCCA2(L)+IOCCB2(K) 
      IF(I.NE.J)THEN 
         IJMAX=MAX(I,J) 
         IJMIN=MIN(I,J) 
         DO 90 M=IJMIN,IJMAX 
   90    IJ=IJ+IOCCB1(M)+IOCCA1(M) 
      ENDIF 
      IF(K.NE.L) THEN 
         KLMIN=MIN(K,L) 
         KLMAX=MAX(K,L) 
         DO 100 M=KLMIN,KLMAX 
  100    IJ=IJ+IOCCB2(M)+IOCCA2(M) 
      ENDIF 
C 
C   IJ IN THE PERMUTATION NUMBER, .EQUIV. -1 IF IJ IS ODD. 
C 
      AABBCD=XR*FLOAT(1-2*MOD(IJ,2)) 
      RETURN 
      END 
      FUNCTION BABBBC(IOCCA1, IOCCB1, IOCCA2, IOCCB2, NMOS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION IOCCA1(NMOS), IOCCB1(NMOS), IOCCA2(NMOS), IOCCB2(NMOS) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
* BABBBC EVALUATES THE C.I. MATRIX ELEMENT FOR TWO MICROSTATES DIFFERING 
*       BY ONE BETA ELECTRON. THAT IS, ONE MICROSTATE HAS A BETA 
*       ELECTRON IN PSI(I) AND THE OTHER MICROSTATE HAS AN ELECTRON IN 
*       PSI(J). 
*********************************************************************** 
      COMMON /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
      COMMON /BASEOC/ OCCA(NMECI) 
       SAVE
      DO 10 I=1,NMOS 
   10 IF(IOCCB1(I).NE.IOCCB2(I)) GOTO 20 
   20 IJ=0 
      DO 30 J=I+1,NMOS 
         IF(IOCCB1(J).NE.IOCCB2(J)) GOTO 40 
   30 IJ=IJ+IOCCA1(J)+IOCCB1(J) 
   40 IJ=IJ+IOCCA1(J) 
C 
C   THE UNPAIRED M.O.S ARE I AND J 
      SUM=0.D0 
      DO 50 K=1,NMOS 
   50 SUM=SUM+ (XY(I,J,K,K)-XY(I,K,J,K))*(IOCCB1(K)-OCCA(K)) + 
     1          XY(I,J,K,K)             *(IOCCA1(K)-OCCA(K)) 
      BABBBC=SUM*FLOAT(1-2*MOD(IJ,2)) 
      RETURN 
      END 
      FUNCTION BABBCD(IOCCA1, IOCCB1, IOCCA2, IOCCB2, NMOS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION IOCCA1(NMOS), IOCCB1(NMOS), IOCCA2(NMOS), IOCCB2(NMOS) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
* BABBCD EVALUATES THE C.I. MATRIX ELEMENT FOR TWO MICROSTATES DIFFERING 
*       BY TWO BETA MOS. ONE MICROSTATE HAS BETA ELECTRONS IN 
*       M.O.S PSI(I) AND PSI(J) FOR WHICH THE OTHER MICROSTATE HAS 
*       ELECTRONS IN PSI(K) AND PSI(L) 
* 
*********************************************************************** 
      COMMON /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
       SAVE
      IJ=0 
      DO 10 I=1,NMOS 
   10 IF(IOCCB1(I) .LT. IOCCB2(I)) GOTO 20 
   20 DO 30 J=I+1,NMOS 
         IF(IOCCB1(J) .LT. IOCCB2(J)) GOTO 40 
   30 IJ=IJ+IOCCA2(J)+IOCCB2(J) 
   40 IJ=IJ+IOCCA2(J) 
      DO 50 K=1,NMOS 
   50 IF(IOCCB1(K) .GT. IOCCB2(K)) GOTO 60 
   60 DO 70 L=K+1,NMOS 
         IF(IOCCB1(L) .GT. IOCCB2(L)) GOTO 80 
   70 IJ=IJ+IOCCA1(L)+IOCCB1(L) 
   80 IJ=IJ+IOCCA1(L) 
      IF((IJ/2)*2.EQ.IJ) THEN 
         ONE=1.D0 
      ELSE 
         ONE=-1.D0 
      ENDIF 
      BABBCD=(XY(I,K,J,L)-XY(I,L,J,K))*ONE 
      RETURN 
      END 
      FUNCTION DIAGI(IALPHA,IBETA,EIGA,XY,NMOS) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XY(NMECI,NMECI,NMECI,NMECI), EIGA(NMECI), 
     1IALPHA(NMOS), IBETA(NMOS) 
       SAVE
************************************************************************ 
* 
*  CALCULATES THE ENERGY OF A MICROSTATE DEFINED BY IALPHA AND IBETA 
* 
************************************************************************ 
      X=0.0D0 
      DO 20 I=1,NMOS 
         IF (IALPHA(I).NE.0)THEN 
            X=X+EIGA(I) 
            DO 10  J=1,NMOS 
               X=X+((XY(I,I,J,J)-XY(I,J,I,J))*IALPHA(J)*0.5D0 + 
     1        (XY(I,I,J,J)            )*IBETA(J)) 
   10       CONTINUE 
         ENDIF 
   20 CONTINUE 
      DO 40 I=1,NMOS 
         IF (IBETA(I).NE.0) THEN 
            X=X+EIGA(I) 
            DO 30 J=1,I 
   30       X=X+(XY(I,I,J,J)-XY(I,J,I,J))*IBETA(J) 
         ENDIF 
   40 CONTINUE 
      DIAGI=X 
      RETURN 
      END 
      SUBROUTINE ANAVIB(COORD,EIGS,N3,VIBS,RIJ) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION COORD(3,100),EIGS(N3),VIBS(N3,N3), RIJ(900) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ELEMTS/ ELEMNT(107) 
      LOGICAL VIB1, VIB2 
      CHARACTER*2 ELEMNT 
      DIMENSION VANRAD(86) 
      DATA VANRAD/ 
     1   0.32,0.93, 
     2   1.23, 0.90, 0.82, 0.77, 0.75, 0.73, 0.72, 0.71, 
     3   1.54, 1.36, 1.18, 1.11, 1.06, 1.02, 0.99, 0.98, 
     4   2.03, 1.74, 1.44, 1.32, 1.22, 1.18, 1.17, 1.17, 1.16, 
     5   1.15, 1.17, 1.25, 1.26, 1.22, 1.20, 1.16, 1.14, 1.12, 
     6   2.16, 1.91, 1.62, 1.45, 1.34, 1.30, 1.27, 1.25, 1.25, 
     7   1.28, 1.34, 1.48, 1.44, 1.41, 1.40, 1.36, 1.33, 1.31, 
     8   2.35, 1.98, 1.69, 
     9   1.65, 1.65, 1.64, 1.63, 1.62, 1.85, 1.61, 1.59, 1.59, 1.58, 
     1   1.57, 1.56, 1.56, 1.56, 
     2   1.44, 1.34, 1.30, 1.28, 1.26, 1.27, 1.30, 1.34, 
     3   1.49, 1.48, 1.47, 1.46, 1.46, 1.45,1.45/ 
       SAVE
      N3=NUMAT*3 
C 
C    COMPUTE INTERATOMIC DISTANCES. 
C 
      L=0 
      DO 10 I=1,NUMAT 
         DO 10 J=1,I 
            L=L+1 
   10 RIJ(L)=SQRT((COORD(1,J)-COORD(1,I))**2+ 
     1            (COORD(2,J)-COORD(2,I))**2+ 
     2            (COORD(3,J)-COORD(3,I))**2) 
C 
C     ANALYSE VIBRATIONS 
C 
      WRITE(6,'(//10X,''DESCRIPTION OF VIBRATIONS'',/)') 
      DO 30 K=1,N3 
         VIB1=.TRUE. 
         VIB2=.TRUE. 
         J3=0 
         L=0 
         DO 20 J=1,NUMAT 
            XJ=COORD(1,J) 
            YJ=COORD(2,J) 
            ZJ=COORD(3,J) 
            J1=J3+1 
            J2=J1+1 
            J3=J2+1 
            I3=0 
            DO 20 I=1,J 
               XI=COORD(1,I) 
               YI=COORD(2,I) 
               ZI=COORD(3,I) 
               I1=I3+1 
               I2=I1+1 
               I3=I2+1 
               L=L+1 
               VDW=(VANRAD(NAT(I))+VANRAD(NAT(J)))*1.4 
               IF(   RIJ(L)  .LT.  VDW) THEN 
                  X= VIBS(J1,K)-VIBS(I1,K) 
                  Y= VIBS(J2,K)-VIBS(I2,K) 
                  Z= VIBS(J3,K)-VIBS(I3,K) 
                  SHIFT=X*X+Y*Y+Z*Z 
                  IF(SHIFT .GT. 0.1) THEN 
                     SHIFT=SQRT(SHIFT) 
                     RADIAL=ABS(X*(XI-XJ)+Y*(YI-YJ)+Z*(ZI-ZJ)) 
     1                  /(SHIFT*RIJ(L))*100.D0 
                     IF (VIB1) THEN 
                        WRITE(6,'(/,'' VIB.'',I3,''    ATOMS  '', 
     1A2,I2,''  AND  '',A2,I2,''  SHIFT'', 
     2F6.2,''  ANGSTROMS'',F7.1,''%  RADIALLY'')')K,ELEMNT(NAT(I)),I, 
     3ELEMNT(NAT(J)),J,SHIFT,RADIAL 
                        VIB1=.FALSE. 
                     ELSEIF (VIB2) THEN 
                        VIB2=.FALSE. 
                        WRITE(6,'('' FREQ.   '',F8.2,2X, 
     1A2,I2,''       '',A2,I2,7X,F6.2,''           '', 
     2F7.1,''%          '')')EIGS(K),ELEMNT(NAT(I)),I, 
     3ELEMNT(NAT(J)),J,SHIFT,RADIAL 
                     ELSE 
                        WRITE(6,'(''                   '', 
     1A2,I2,''       '',A2,I2,7X,F6.2,''           '', 
     2F7.1,''%          '')')ELEMNT(NAT(I)),I, 
     3ELEMNT(NAT(J)),J,SHIFT,RADIAL 
                     ENDIF 
                  ENDIF 
               ENDIF 
   20    CONTINUE 
   30 CONTINUE 
      RETURN 
      END 
      SUBROUTINE AXIS(COORD,NUMAT,A,B,C,SUMW, MASS,EVEC) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
* 
*  AXIS CALCULATES THE THREE MOMENTS OF INERTIA AND THE MOLECULAR 
*       WEIGHT.  THE MOMENTS OF INERTIA ARE RETURNED IN A, B, AND C. 
*       THE MOLECULAR WEIGHT IN SUMW. 
*       THE UNITS OF INERTIA ARE 10**(-40)GRAM-CM**2, 
*       AND MOL.WEIGHT IN ATOMIC-MASS-UNITS. (AMU'S) 
************************************************************************ 
      DIMENSION COORD(3,NUMAT) 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      DIMENSION T(6), X(NUMATM), Y(NUMATM), 
     1          Z(NUMATM), ROT(3), XYZMOM(3), EIG(3), EVEC(3,3) 
      LOGICAL FIRST 
      DATA T /6*0.D0/, FIRST/.TRUE./ 
       SAVE
************************************************************************ 
*     CONST1 =  10**40/(N*A*A) 
*               N = AVERGADRO'S NUMBER 
*               A = CM IN AN ANGSTROM 
*               10**40 IS TO ALLOW UNITS TO BE 10**(-40)GRAM-CM**2 
* 
************************************************************************ 
      CONST1 = 1.66053D0 
************************************************************************ 
* 
*     CONST2 = CONVERSION FACTOR FROM ANGSTROM-AMU TO CM**(-1) 
*            = (PLANCK'S CONSTANT)/(4*PI*PI) 
* 
************************************************************************ 
      CONST2=16.85803902 
C    FIRST WE CENTRE THE MOLECULE ABOUT THE CENTRE OF GRAVITY, 
C    THIS DEPENDS ON THE ISOTOPIC MASSES, AND THE CARTESIAN GEOMETRY. 
C 
      SUMW=0.D0 
      SUMWX=0.D0 
      SUMWY=0.D0 
      SUMWZ=0.D0 
      WEIGHT=1.D0 
      DO 10 I=1,NUMAT 
         IF(MASS.GT.0)WEIGHT=ATMASS(I) 
         SUMW=SUMW+WEIGHT 
         SUMWX=SUMWX+WEIGHT*COORD(1,I) 
         SUMWY=SUMWY+WEIGHT*COORD(2,I) 
   10 SUMWZ=SUMWZ+WEIGHT*COORD(3,I) 
      IF(MASS.GT.0.AND.FIRST) 
     1 WRITE(6,'(/10X,''MOLECULAR WEIGHT ='',F8.2,/)')SUMW 
      SUMWX=SUMWX/SUMW 
      SUMWY=SUMWY/SUMW 
      SUMWZ=SUMWZ/SUMW 
      DO 20 I=1,NUMAT 
         X(I)=COORD(1,I)-SUMWX 
         Y(I)=COORD(2,I)-SUMWY 
   20 Z(I)=COORD(3,I)-SUMWZ 
************************************************************************ 
* 
*    MATRIX FOR MOMENTS OF INERTIA IS OF FORM 
* 
*           !   Y**2+Z**2                         ! 
*           !    -Y*X       Z**2+X**2             ! -I =0 
*           !    -Z*X        -Z*Y       X**2+Y**2 ! 
* 
************************************************************************ 
      DO 30 I=1,6 
   30 T(I)=I*1.D-10 
      DO 40 I=1,NUMAT 
         IF(MASS.GT.0)WEIGHT=ATMASS(I) 
         T(1)=T(1)+WEIGHT*(Y(I)**2+Z(I)**2) 
         T(2)=T(2)-WEIGHT*X(I)*Y(I) 
         T(3)=T(3)+WEIGHT*(Z(I)**2+X(I)**2) 
         T(4)=T(4)-WEIGHT*Z(I)*X(I) 
         T(5)=T(5)-WEIGHT*Y(I)*Z(I) 
   40 T(6)=T(6)+WEIGHT*(X(I)**2+Y(I)**2) 
      CALL HQRII(T,3,3,EIG,EVEC) 
      IF(MASS.GT.0.AND. FIRST) THEN 
         WRITE(6,'(//10X,'' PRINCIPAL MOMENTS OF INERTIA IN CM(-1)'',/)' 
     1) 
         DO 50 I=1,3 
            IF(EIG(I).LT.3.D-4) THEN 
               EIG(I)=0.D0 
               ROT(I)=0.D0 
            ELSE 
               ROT(I)=CONST2/EIG(I) 
            ENDIF 
   50    XYZMOM(I)=EIG(I)*CONST1 
         WRITE(6,'(10X,''A ='',F12.6,''   B ='',F12.6, 
     1''   C ='',F12.6,/)')(ROT(I),I=1,3) 
         WRITE(6,'(//10X,'' PRINCIPAL MOMENTS OF INERTIA IN '', 
     1''UNITS OF 10**(-40)*GRAM-CM**2'',/)') 
         WRITE(6,'(10X,''A ='',F12.6,''   B ='',F12.6, 
     1''   C ='',F12.6,/)')(XYZMOM(I),I=1,3) 
         C=ROT(1) 
         B=ROT(2) 
         A=ROT(3) 
      ENDIF 
C 
C   NOW TO ORIENT THE MOLECULE SO THE CHIRALITY IS PRESERVED 
C 
      SUM=EVEC(1,1)*(EVEC(2,2)*EVEC(3,3)-EVEC(3,2)*EVEC(2,3)) + 
     1    EVEC(1,2)*(EVEC(2,3)*EVEC(3,1)-EVEC(2,1)*EVEC(3,3)) + 
     2    EVEC(1,3)*(EVEC(2,1)*EVEC(3,2)-EVEC(2,2)*EVEC(3,1)) 
      IF( SUM .LT. 0) THEN 
         DO 60 J=1,3 
   60    EVEC(J,1)=-EVEC(J,1) 
      ENDIF 
      DO 70 I=1,NUMAT 
         COORD(1,I)=X(I) 
         COORD(2,I)=Y(I) 
         COORD(3,I)=Z(I) 
   70 CONTINUE 
      IF(MASS.GT.0)FIRST=.FALSE. 
      END 
      BLOCK DATA 
      IMPLICIT REAL (A-H,O-Z) 
      COMMON /NATORB/ NATORB(107) 
      COMMON /ELEMTS/ ELEMNT(107) 
*********************************************************************** 
* 
*     COMMON BLOCKS FOR AM1 
* 
*********************************************************************** 
     +       /ALPHA / ALP(107) 
     1       /CORE  / CORE(107) 
     2       /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107) 
     3       /EXPONT/ ZS(107),ZP(107),ZD(107) 
     4       /ONELEC/ USS(107),UPP(107),UDD(107) 
     5       /BETAS / BETAS(107),BETAP(107),BETAD(107) 
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107), 
     +                GSD(107),GPD(107),GDD(107) 
     7       /ATOMIC/ EISOL(107),EHEAT(107) 
     8       /AM1REF/ AM1REF(107) 
     9       /VSIPS / VS(107),VP(107),VD(107) 
     A       /ISTOPE/ AMS(107) 
     B       /IDEAS / GUESS1(107,10),GUESS2(107,10),GUESS3(107,10) 
     C               ,NGUESS(107) 
     D       /GAUSS / FN1(107),FN2(107) 
*********************************************************************** 
* 
*     COMMON BLOCKS FOR MNDO 
* 
*********************************************************************** 
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107), 
     1ZPM(107), ZDM(107), BETASM(107), BETAPM(107), BETADM(107), 
     2ALPM(107), EISOLM(107), DDM(107), QQM(107), AMM(107), ADM(107), 
     3AQM(107) ,GSSM(107), GSPM(107), GPPM(107), GP2M(107), HSPM(107), 
     4POLVOM(107) 
      COMMON /ALPTM/ ALPTM(30), EMUDTM(30) 
* 
*  COMMON BLOCKS FOR MINDO/3 
* 
      COMMON /ONELE3 /  USS3(18),UPP3(18)
     1       /TWOEL3 /  F03(107)
     2       /ATOMI3 /  EISOL3(18),EHEAT3(18)
     3       /BETA3  /  BETA3(153)
     4       /ALPHA3 /  ALP3(153)
     5       /EXPON3 /  ZS3(18),ZP3(18)
*
*  END OF MINDO/3 COMMON BLOCKS
*
      include 'PARAM'
      END
      SUBROUTINE BONDS(P) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      PARAMETER (NATMS2=MAXPAR*MAXPAR-MAXORB*MAXORB) 
      DIMENSION P(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /SCRACH/ B(MAXORB,MAXORB), BONDAB(NATMS2) 
C*********************************************************************** 
C 
C   CALCULATES, AND PRINTS, THE BOND INDICES AND VALENCIES OF ATOMS 
C 
C  FOR REFERENCE, SEE "BOND INDICES AND VALENCY", J. C. S. DALTON, 
C  ARMSTRONG, D.R., PERKINS, P.G., AND STEWART, J.J.P., 838 (1973) 
C 
C   ON INPUT 
C            P = DENSITY MATRIX, LOWER HALF TRIANGLE, PACKED. 
C            P   IS NOT ALTERED BY BONDS. 
C 
C*********************************************************************** 
       SAVE
      WRITE(6,10) 
   10 FORMAT(//20X,'BOND ORDERS AND VALENCIES',//) 
      K=0 
      DO 20 I=1,NORBS 
         DO 20 J=1,I 
            K=K+1 
            B(I,J)=P(K) 
   20 B(J,I)=P(K) 
      IJ = 0 
      DO 60 I=1,NUMAT 
         L=NFIRST(I) 
         LL=NLAST(I) 
         DO 40 J=1,I 
            IJ = IJ + 1 
            K=NFIRST(J) 
            KK=NLAST(J) 
            X=0.0 
            DO 30 IL=L,LL 
               DO 30 IH=K,KK 
   30       X=X+B(IL,IH)*B(IL,IH) 
   40    BONDAB(IJ)=X 
         X=-BONDAB(IJ) 
         DO 50 J=L,LL 
   50    X=X+2.D0*B(J,J) 
         BONDAB(IJ)=X 
   60 CONTINUE 
      CALL VECPRT( BONDAB, NUMAT) 
      RETURN 
      END 
      SUBROUTINE CALPAR 
      IMPLICIT REAL (A-H,O-Z) 
      COMMON /ONELEC/ USS(107),UPP(107),UDD(107) 
     1       /ATOMIC/ EISOL(107),EHEAT(107) 
     2       /ALPHA / ALP(107) 
     3       /EXPONT/ ZS(107),ZP(107),ZD(107) 
     4       /GAUSS / FN1(107),FN2(107) 
     5       /BETAS / BETAS(107),BETAP(107),BETAD(107) 
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107), 
     7                GSD(107),GPD(107),GDD(107) 
     8       /IDEAS / GUESS1(107,10), GUESS2(107,10), GUESS3(107,10) 
     9               ,NGUESS(107) 
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107),ZPM(107), 
     1ZDM(107), BETASM(107), BETAPM(107), BETADM(107), ALPM(107), 
     2EISOLM(107), DDM(107), QQM(107), AMM(107), ADM(107), AQM(107) 
     3,GSSM(107),GSPM(107),GPPM(107),GP2M(107),HSPM(107), POLVOM(107) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON/MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107) 
      DIMENSION NSPQN(107) 
      CHARACTER KEYWRD*80 
      DIMENSION USSC(107), UPPC(107), GSSC(107), GSPC(107), HSPC(107), 
     1GP2C(107), GPPC(107), UDDC(107), GSDC(107), GDDC(107) 
      DATA NSPQN/2*1,8*2,8*3,18*4,18*5,32*6,21*0/ 
C 
C THE CONTINUATION LINES INDICATE THE PRINCIPAL QUANTUM NUMBER. 
C 
      DATA USSC/ 
     11.D0,                                                      0.D0, 
     21.D0,                                               6*2.D0,0.D0, 
     31.D0,                                               6*2.D0,0.D0, 
     41.D0,4*2.D0,1.D0,4*2.D0,1.D0,                       6*2.D0,0.D0, 
     51.D0,3*2.D0,2*1.D0,2.D0,2*1.D0,0.D0,1.D0,           6*2.D0,0.D0, 
     61.D0,22*2.D0,1.D0,1.D0,                             6*2.D0,0.D0, 
     721*0.D0/ 
      DATA  UPPC/ 
     1 2*0.D0, 
     2 2*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0, 
     3 2*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0, 
     412*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0, 
     512*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0, 
     626*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0, 
     721*0.D0/ 
      DATA UDDC/18*0.D0, 
     1 2*0.D0,1.D0,2.D0,3.D0,5.D0,5.D0,6.D0,7.D0,8.D0,1.D1,1.D1,6*0.D0, 
     2 2*0.D0,1.D0,2.D0,4.D0,5.D0,5.D0,7.D0,8.D0,1.D1,1.D1,1.D1,6*0.D0, 
     3 2*0.D0,1.D0,6*0.D0,1.D0,6*0.D0,1.D0,2.D0,3.D0,4.D0, 
     4                           5.D0,6.D0,7.D0,9.D0,1.D1,1.D1,6*0.D0, 
     5 21*0.D0/ 
      DATA GSSC/2*0.D0, 
     1 0.D0,6*1.D0,0.D0, 
     2 0.D0,6*1.D0,0.D0, 
     3 0.D0,4*1.D0,0.D0,4*1.D0,0.D0,6*1.D0,0.D0, 
     4 0.D0,3*1.D0,7*0.D0,6*1.D0,0.D0, 
     5 0.D0,22*1.D0,2*1.D0,6*1.D0,0.D0, 
     6 21*0.D0/ 
      DATA GSPC/2*0.D0, 
     1 2*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0, 
     2 2*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0, 
     312*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0, 
     412*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0, 
     526*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0, 
     621*0.D0/ 
      DATA HSPC/2*0.D0, 
     1 2*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0, 
     2 2*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0, 
     312*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0, 
     412*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0, 
     526*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0, 
     621*0.D0/ 
      DATA GP2C/2*0.D0, 
     1 3*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0, 
     2 3*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0, 
     313*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0, 
     413*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0, 
     527*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0, 
     621*0.D0/ 
      DATA GPPC/2*0.D0, 
     1 3*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0, 
     2 3*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0, 
     313*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0, 
     413*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0, 
     527*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0, 
     621*0.D0/ 
     7GSDC/18*0.D0, 
     8 2*0.D0,2.D0,4.D0,6.D0,5.D0,10.D0,12.D0,14.D0,16.D0,10.D0,7*0.D0, 
     9 2*0.D0,2.D0,4.D0,4.D0,5.D0,6.D0,7.D0,8.D0,0.D0,1.D1,7*0.D0, 
     1 2*0.D0,2.D0,6*0.D0,2.D0,6*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,12.D0, 
     2                                         14.D0,9.D0,10.D0,7*0.D0, 
     321*0.D0/ 
      DATA GDDC/18*0.D0, 
     1 3*0.D0,1.D0,3.D0,10.D0,10.D0,15.D0,21.D0,28.D0,8*0.D0, 
     2 3*0.D0,1.D0,6.D0,10.D0,15.D0,21.D0,28.D0,45.D0,8*0.D0, 
     317*0.D0,1.D0,3.D0, 6.D0,10.D0,15.D0,21.D0,36.D0,8*0.D0, 
     421*0.D0/ 
C  The DATA block shown above is derived from the ground-state atomic 
C  configuration of the elements.  In checking it, pay careful attention 
C  to the actual ground-state configuration. Note also that there are no 
C  configurations which have both p and d electrons in the valence shell 
C 
C     SET SCALING PARAMETER. 
       SAVE
      P=2.D0 
      P2=P*P 
      P4=P**4 
      DO 30 I=2,107 
         IF(ZP(I).LT.1.D-4.AND.ZS(I).LT.1.D-4)GOTO 30 
********************************************************************** 
* 
*   CONSTRAINTS ON THE POSSIBLE VALUES OF PARAMETERS 
* 
********************************************************************** 
         IF(ZP(I).LT.0.3D0) ZP(I)=0.3D0 
C  PUT IN ANY CONSTRAINTS AT THIS POINT 
********************************************************************** 
         HPP=0.5D0*(GPP(I)-GP2(I)) 
         HPP=MAX(0.1D0,HPP) 
         HSP(I)=MAX(0.1D0,HSP(I)) 
         EISOL(I)=USS(I)*USSC(I)+UPP(I)*UPPC(I)+UDD(I)*UDDC(I)+ 
     1         GSS(I)*GSSC(I)+GPP(I)*GPPC(I)+GSP(I)*GSPC(I)+ 
     2         GP2(I)*GP2C(I)+HSP(I)*HSPC(I)+GSD(I)*GSDC(I)+ 
     3         GDD(I)*GDDC(I) 
         QN=NSPQN(I) 
         DD(I)=(2.D0*QN+1)*(4.D0*ZS(I)*ZP(I))**(QN+0.5D0)/(ZS(I)+ZP(I)) 
     1**(2.D0*QN+2)/SQRT(3.D0) 
         DDM(I)=DD(I) 
         QQ(I)=SQRT((4.D0*QN*QN+6.D0*QN+2.D0)/20.D0)/ZP(I) 
         QQM(I)=QQ(I) 
C     CALCULATE ADDITIVE TERMS, IN ATOMIC UNITS. 
         JMAX=5 
         GDD1= (P2*HSP(I)/(27.21* 4.*DD(I)**2))**(1./3.) 
         GQQ= (P4*HPP/(27.21*48.*QQ(I)**4))**0.2 
         D1=GDD1 
         D2=GDD1+0.04 
         Q1=GQQ 
         Q2=GQQ+0.04 
         DO 10 J=1,JMAX 
            DF=D2-D1 
            HSP1= 2.*D1 - 2./SQRT(4.*DD(I)**2+1./D1**2) 
            HSP2= 2.*D2 - 2./SQRT(4.*DD(I)**2+1./D2**2) 
            HSP1= HSP1/P2 
            HSP2= HSP2/P2 
            D3= D1 + DF*(HSP(I)/27.21-HSP1)/(HSP2-HSP1) 
            D1= D2 
            D2= D3 
   10    CONTINUE 
         DO 20 J=1,JMAX 
            QF=Q2-Q1 
            HPP1= 4.*Q1 - 8./SQRT(4.*QQ(I)**2+1./Q1**2) 
     1            + 4./SQRT(8.*QQ(I)**2+1./Q1**2) 
            HPP2= 4.*Q2 - 8./SQRT(4.*QQ(I)**2+1./Q2**2) 
     1            + 4./SQRT(8.*QQ(I)**2+1./Q2**2) 
            HPP1= HPP1/P4 
            HPP2= HPP2/P4 
            Q3= Q1 + QF*(HPP/27.21-HPP1)/(HPP2-HPP1) 
            Q1= Q2 
            Q2= Q3 
   20    CONTINUE 
         AM(I)= GSS(I)/27.21 
         AD(I)= D2 
         AQ(I)= Q2 
         AMM(I)=AM(I) 
         ADM(I)=AD(I) 
         AQM(I)=AQ(I) 
   30 CONTINUE 
      EISOL(1)=USS(1) 
      AM(1)=GSS(1)/27.21D0 
      AD(1)=AM(1) 
      AQ(1)=AM(1) 
      AMM(1)=AM(1) 
      ADM(1)=AD(1) 
      AQM(1)=AQ(1) 
C 
C     DEBUG PRINTING. 
C     THIS IS FORMATTED FOR DIRECT INSERTION INTO 'BLOCK DATA' 
C 
      IF(INDEX(KEYWRD,'DEP').EQ.0) RETURN 
      WRITE(6,50) 
      DO 60 I=1,107 
         IF(ZS(I).EQ.0) GOTO 60 
         WRITE(6,'(''C'',20X,''DATA FOR ELEMENT'',I3)')I 
         WRITE(6,'(6X,''DATA USS   ('',I3,'')/'',F16.7,''D0/'')') 
     1                    I,USS(I) 
         IF(UPP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA UPP   ('',I3,'')/'',F16.7,''D0/'')')I,UPP(I) 
         IF(UDD(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA UDD   ('',I3,'')/'',F16.7,''D0/'')')I,UDD(I) 
         IF(BETAS(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA BETAS ('',I3,'')/'',F16.7,''D0/'')') 
     2I,BETAS(I) 
         IF(BETAP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA BETAP ('',I3,'')/'',F16.7,''D0/'')') 
     2I,BETAP(I) 
         IF(BETAD(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA BETAD ('',I3,'')/'',F16.7,''D0/'')') 
     2I,BETAD(I) 
         WRITE(6,'(6X,''DATA ZS    ('',I3,'')/'',F16.7,''D0/'')') 
     1I,ZS(I) 
         IF(ZP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA ZP    ('',I3,'')/'',F16.7,''D0/'')')I,ZP(I) 
         IF(ZD(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA ZD    ('',I3,'')/'',F16.7,''D0/'')')I,ZD(I) 
         WRITE(6,'(6X,''DATA ALP   ('',I3,'')/'',F16.7,''D0/'')') 
     1I,ALP(I) 
         WRITE(6,'(6X,''DATA EISOL ('',I3,'')/'',F16.7,''D0/'')') 
     1I,EISOL(I) 
         IF(GSS(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA GSS   ('',I3,'')/'',F16.7,''D0/'')') 
     2I,GSS(I) 
         IF(GSP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA GSP   ('',I3,'')/'',F16.7,''D0/'')') 
     2I,GSP(I) 
         IF(GPP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA GPP   ('',I3,'')/'',F16.7,''D0/'')') 
     2I,GPP(I) 
         IF(GP2(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA GP2   ('',I3,'')/'',F16.7,''D0/'')') 
     2I,GP2(I) 
         IF(HSP(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA HSP   ('',I3,'')/'',F16.7,''D0/'')') 
     2I,HSP(I) 
         IF(DD(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA DD    ('',I3,'')/'',F16.7,''D0/'')')I,DD(I) 
         IF(QQ(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA QQ    ('',I3,'')/'',F16.7,''D0/'')')I,QQ(I) 
         WRITE(6,'(6X,''DATA AM    ('',I3,'')/'',F16.7,''D0/'')') 
     1I,AM(I) 
         IF(AD(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA AD    ('',I3,'')/'',F16.7,''D0/'')')I,AD(I) 
         IF(AQ(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA AQ    ('',I3,'')/'',F16.7,''D0/'')')I,AQ(I) 
         IF(FN1(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA FN1   ('',I3,'')/'',F16.7,''D0/'')')I,FN1(I) 
         IF(FN2(I) .NE. 0.D0) 
     1WRITE(6,'(6X,''DATA FN2   ('',I3,'')/'',F16.7,''D0/'')')I,FN2(I) 
         DO 40 J=1,NGUESS(I) 
            WRITE(6,'(6X,''DATA GUESS1('',I3,'','',I1,'')/'', 
     1F16.7,''D0/'')')I,J,GUESS1(I,J) 
            WRITE(6,'(6X,''DATA GUESS2('',I3,'','',I1,'')/'', 
     1F16.7,''D0/'')')I,J,GUESS2(I,J) 
            WRITE(6,'(6X,''DATA GUESS3('',I3,'','',I1,'')/'', 
     1F16.7,''D0/'')')I,J,GUESS3(I,J) 
   40    CONTINUE 
         WRITE(6,'(6X,''DATA NGUESS('',I2,'')  /'',I2,''/'')') 
     +   I,NGUESS(I) 
   50    FORMAT(1H ,1X,'OUTPUT        INCLUDES DEBUG INFORMATION',//) 
   60 CONTINUE 
      RETURN 
      END 
      SUBROUTINE CHAIN (IND,XX,FF,GG,NN) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C---------- 
C     TRANSITION STATE BY THE CHAIN METHOD ... MAIN SUBROUTINE . 
C---------- 
C     REQUIRED SUBROUTINES : 
C        COMPFG (X,F,FAIL,G,ASKG) : ENERGY (F) AT POINT (X)... 
C                                   AND GRADIENT (G) IF ASKG=.TRUE. 
C        COL ,ECRIT,QUADRI,RABIOT : CHAIN METHOD. 
C        DOT,SUPDOT,DIAGIV : MATHEMATICAL PACKAGE. 
C---------- 
C     THE COMMON/OPTIM/        INCLUDES THE WHOLE DATA REQUIRED. 
C     NOTE...THIS STRUCTURE ALLOWS TO OVERLAY THIS BRANCH (COL,QUADRI, 
C     RABIOT,DIAGIV,ECRIT,DOT,SUPDOT) WITH THOSE OF THE ENERGY AND 
C     GRADIENT COMPUTATION (COMPFG) 
C     MOREOVER,ONLY THIS SUBROUTINE MUST BE MODIFIED FOR IMPLEMENTATION 
C     OF THE ALGORITHM IN AN OTHER PACKAGE . 
C---------- 
C 
      DIMENSION XX(1),GG(1) 
      COMMON /PRECI / SCFCV,SCFTOL,BIDPRE(9),KTYP(MAXPAR) 
      COMMON /MESAGE/ IFLEPO 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,H(MAXHES),GNEW(MAXPAR) 
     .               ,XNEW(MAXPAR),ENEW,GOLD(MAXPAR),XOLD(MAXPAR),EOLD 
     .               ,QDER,DMAX,COSDIR(MAXPAR,2),TRANS1(MAXPAR) 
     .               ,HAUT(MAXPAR+2),DIR(MAXPAR),EIGEN(MAXPAR),R(2) 
     .               ,EPS1,COSTET,Q,D,D1,D2,D3,D4,D5,D6,D7,D8,D9,CORREL 
     .               ,PIGI,GIGI,XVAR(MAXPAR,MAXPAR),GVAR(MAXPAR,MAXPAR) 
     .               ,HVEC(MAXPAR,4),THR1,THR2,COORD(MAXPAR+1,NCHAIN) 
     .               ,X(MAXPAR),F,G(MAXPAR),EPS,DELTAE 
     .               ,ISTAB,IJUMP,IROTH,NVAR,ITEG,IBRCH,INDI(NCHAIN,2) 
     .               ,NP1,ITE,KK,JVOIS,ITEST,MM,ITETOT 
     .               ,N,LIMIT,IS,NLR(2),NT,FAIL,IBID,FLAG,FLACHN(NCHAIN) 
      COMMON /SCRACH/ GEO(3,NUMATM),DUMY(NUMATM),IDUM1(NUMATM) 
     .               ,IDUM2(3,NUMATM) 
      COMMON /GEOKST/ NATOMS 
      COMMON /GEOVAR/ NDUMM,LOC(2,MAXPAR) 
      COMMON /TIME  / TIME0 
      COMMON /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
      LOGICAL FAIL,FAIL2,IBID,FLAG,FLACHN,SHOWT 
       SAVE
C 
C     STANDARD PARAMETERS AND INITIALIZATION 
      NT=NCHAIN 
      COSTET=30.D0 
      DMAX=0.3D0 
      N=NN 
C     'LEN1&2' ARE THE LENGTH OF /OPTIM/ TO BE SAVED WHEN TIME UP. 
C     (IN INTEGER*4 UNIT,TOTAL LENGTH=MAXPAR*LENGT1+LENGT2) 
C     ACTUAL TOTAL LENGTH=26+NCHAIN*3    + 
C     2*( 29+2*MAXPAR*MAXPAR+MAXHES+16*MAXPAR+NCHAIN*(MAXPAR+1) ) 
      LEN1=2*(MAXPAR*2+16+NCHAIN) 
      LEN2=NCHAIN*3+26 +2*(29+MAXHES+NCHAIN) 
      SHOWT=INDEX(KEYWRD,'TIME') .NE. 0 
      TLEFT=3600. 
      TIME1 =TIME0 
      I= INDEX(KEYWRD,' T=') 
      IF (I.NE.0) TLEFT=READA(KEYWRD,I) 
      WRITE(IPRT,110) TLEFT 
      IF (INDEX(KEYWRD,'REST') .NE. 0) THEN 
         CALL SAVOPT(LEN1,LEN2,.TRUE.) 
         GO TO 5 
      ENDIF 
      DO 1 I=1,N 
    1 X(I)=XX(I) 
      INDI(1,1)=1 
      INDI(1,2)=NT 
      NP1=N+1 
C     COORDINATES AND ENERGY OF LEFT AND RIGHT MINIMA 
      DO 4 K=1,2 
      JPOS=INDI(1,K) 
C     READ COORDINATES (ANGSTROM AND DEGREES) 
      CALL GETGEO(LEC,IDUM1,GEO,IDUM2,IDUM1,IDUM1,IDUM1,DUMY 
     1           ,NATOMS,IBID) 
      DO 2 I=1,N 
    2 COORD(I,JPOS)=GEO(LOC(2,I),LOC(1,I)) 
C     CONVERT IN ANGSTROM AND RADIAN 
      DO 3 I=1,N 
      IF(KTYP(I).GT.1) COORD(I,JPOS)=COORD(I,JPOS)/57.29577951D0 
    3 CONTINUE 
C     CALCULATE THE ENERGY OF THIS MINIMA 
      CALL COMPFG (COORD(1,JPOS),COORD(NP1,JPOS),FAIL,G,.FALSE.) 
    4 FAIL=.TRUE. 
      IS=0 
C 
C     STANDARD THRESHOLDS ON CONVERGENCE AND ACCURACY 
C 
    5 DELTAE=MAX(1.D2*SCFCV,0.1D0) 
      EPS=5.D0 
      LIMIT=30+3*N 
      IF(INDEX(KEYWRD,'PRECI') .NE. 0) THEN 
         EPS=EPS*0.1D0 
         LIMIT=LIMIT*10 
      ENDIF 
      I= INDEX(KEYWRD,'CYCLES=') 
      IF (I.NE.0) LIMIT=READA(KEYWRD,I) 
      I= INDEX(KEYWRD,'GNORM=') 
      IF (I.NE.0) EPS=ABS(READA(KEYWRD,I)) 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF (IMP.NE.0) IMP=READA(KEYWRD,IMP) 
C 
C     ITERATIONS 
C 
   10 CALL COL 
C     NOTE ... IF FAIL=.T. THEN SCF TO BE INITIALISED WITH STANDARD 
C                 DIAGONAL DENSITY MATRICES (CF SUBROUTINE 'ITER'). 
C              FAIL=.T. ON COMPFG RETURN IIF ACTUAL DIVERGENCE. 
C              PLEASE, LOOK AT THE DISPATCHING ACCORDING TO 'IS' IN COL. 
      GO TO (11,11,13,21,20,30,30,21,30),IS 
   11 FAIL=.TRUE. 
      GO TO 21 
   13 FAIL=ISTAB.NE.1 
      CALL SECOND (TIME2) 
      TIME=TIME2-TIME1 
      TIME1=TIME2 
   20 SCFTOL=1.D0 
      IF(SHOWT)WRITE(IPRT,100)TIME,TIME2-TIME0 
      CALL COMPFG(X,F,FAIL,G,.TRUE.) 
      IF(TLEFT-2.5D0*TIME.LT.TIME2-TIME0) THEN 
         CALL SAVOPT(LEN1,LEN2,.FALSE.) 
         FAIL=.TRUE. 
         GO TO 30 
      ELSE 
         GO TO 10 
      ENDIF 
   21 SCFTOL=1.D2 
      CALL COMPFG (X,F,FAIL,G,.FALSE.) 
      GO TO 10 
C     TERMINATION 
   30 DO 31 I=1,N 
      XX(I)=X(I) 
   31 GG(I)=G(I) 
      SCFTOL=1.D0 
      FAIL2=.FALSE. 
      CALL COMPFG(X,FF,FAIL2,G,.FALSE.) 
      IND=0 
      IFLEPO=11 
      IF(FAIL.OR.FAIL2) THEN 
         IND=1 
         IFLEPO=12 
      ENDIF 
      RETURN 
  100 FORMAT(' ELAPSED TIME IN CHAIN METHOD =',F9.3,'  INTEGRAL =',F10.3 
     .      ,' SECOND') 
  110 FORMAT(' TOTAL TIME ALLOWED FOR THIS RUN :',F10.2,' SECONDS') 
      END 
      SUBROUTINE COL 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C 
C     TRANSITION STATE... CHAIN METHOD . 
C               PAU JULY 1978 
C     RELEASE 1.1  ...    OCTOBER 1979 
C             1.2         JUNE 1980 
C             1.3         JULY 1981 
C     RELEASE 2.0  ...    JANUARY 1984 (MAJOR CHANGE IN 'QUADRI') 
C             2.1         JANUARY 1986 
C---------- 
C 
C     LABORATOIRE DE CHIMIE STRUCTURALE 
C             UNIVERSITE DE PAU ET DES PAYS DE L'ADOUR 
C             AVENUE DE L'UNIVERSITE 
C                             64000  PAU  (FRANCE) 
C---------- 
C 
C     REFERENCE : D.LIOTARD  AND J.P.PENOT,IN : 
C         NUMERICAL METHODS IN THE STUDY OF CRITICAL PHENOMENA 
C         (J.DELLA DORA,J.DEMONGEOT,B.LACOLLE EDS) SPRINGER VERLAG 1981. 
C 
C---------- 
C 
C      MAXIMUM :MAXPAR OPTIMIZED VARIABLES 
C               NCHAIN POINTS ON THE CHAIN (CONFER VARIABLE NT). 
C 
C---------- 
C 
C     CALLS OF ENERGY ARE CONTROLED BY VARIABLE IS... 
C        IS=0 :    INITIALIZE SOME VARIABLES 
C           1 :    ENERGY OF THE APPROXIMATE SADDLE POINT 
C           2 :    ENERGY OF THE POINTS GENERATED ON THE INITIAL CHAIN 
C           3 :    ENERGY AND GRADIENT AT THE HIGHEST POINT (ITERATIVE) 
C           4 :    ENERGY OF THE CURRENT POINT DURING MONODIMENSIONAL 
C                  OPTIMIZATION (DOUBLY ITERATIVE) 
C           5 :    ENERGY AND ADDITIONAL GRADIENT FOR UPDATING 
C                  THE HESSIAN WHEN LINEAR INDEPENDANCE IS NOT SATISFIED 
C           6 :    UNUSED 
C           7 :    UNUSED 
C           8 :    ENERGY OF A POINT WHICH HAS BEEN INSERTED IN THE 
C                  CHAIN TO MAINTAIN THE LENGTH OF THE LINKS < DMAX . 
C                  (ITERATIVE) 
C           9 :    THE ALGORITHM STOPS (SEE THE LOGICAL VARIABLE FAIL) 
C 
C     ABSOLUTE ERROR ON ENERGY MUST BE < DELTAE 
C 
C---------- 
C 
C     KEY VARIABLES : 
C        N :       DIMENSION OF THE PROBLEM (NUMBER OF PARAMETERS). 
C        INDI(M,K) : POINT NUMBER M IS LOCATED ON CHAIN NUMBER K 
C                  ACCORDING TO THE FOLLOWING CODE : 
C                  K=1 : LEFT PART     K=2 : RIGHT PART. 
C                     AND FOR I = 1 TO N ... 
C                  LET MM=INDI(M,K), 
C        COORD(I,MM) : COORDINATES OF THE POINT NUMBER M . 
C        COORD(N+1,MM) : ENERGY OF THE POINT NUMBER M . 
C                  THE REACTANT (LEFT MINIMUM) IS THE FIRST POINT, 
C                  THE PRODUCT (RIGHT MINIMUM) IS THE LAST ONE . 
C                  THE HIGHEST POINT IS STORED SEPARATELY : 
C        HAUT(I),I=1,N : COORDINATES ; HAUT(N+1) : ENERGY ; 
C                  HAUT(N+2) : EUCLIDIAN NORM OF THE GRADIENT . 
C        X(I) :    COORDINATES OF THE CURRENT POINT THE ENERGY 
C                  OF WHICH IS REQUIRED . 
C        F,G(I) :  RETURN VALUES OF ENERGY AND GRADIENT . 
C        FAIL :    LOGICAL VARIABLE = .TRUE. IF SCF DIVERGENCE; 
C                  ON LEAVING SUBROUTINE "COL" : DIVERGENCE OF THE 
C                  ALGORITHM . 
C        IMP :     PRINTOUT CONTROL... 
C                  0 : NOTHING BUT ERROR MESSAGES . 
C                  1 : GENERAL MESSAGES ISSUED FROM THE PROGRAM . 
C                  1 TO 4 : CONFER SP 'BARAT'.(PRINTOUT AT EACH 
C                  ITERATION) 
C        H,GNEW,XNEW,GOLD,XOLD,EIGEN,XVAR,GVAR,HVEC : 
C                  SEE THE SUBROUTINE 'QUADRI'FOR QUADRATIC INFORMATION 
C                  TREATMENT . 
C 
C---------- 
C 
C     REQUIRED DATA : 
C        N :       NUMBER OF VARIABLES . 
C        COORD(I,1),I=1,N+1 : COORDINATES AND ENERGY OF THE REACTANT. 
C        COORD(I,NT),I=1,N+1 : IDEM FOR THE PRODUCT. 
C        LIMIT :   MAXIMUM NUMBER OF ITERATIONS . 
C        EPS :     CONVERGENCE THRESHOLD ON RMS GRADIENT . 
C        IMP :     PRINTOUT CONTROL . 
C        DMAX :    INITIAL MAXIMUM LENGTH OF A LINK. 
C        COSTET :  DISCRIMINATION ANGLE; (USUALLY 30 DEGREES) 
C        X(I),I=1,N: COORDINATES OF THE APPROXIMATE SADDLE POINT. 
C 
C        THE INITIAL CHAIN IS GENERATED FOLLOWING TWO STRAIGHT LINES: 
C                       LEFT                          RIGHT 
C        REACTANT--------P---------SADDLE POINT---------P-------PRODUCTS 
C        COORD(I,1)                    X(I)                  COORD(I,NT) 
C 
C---------- 
C 
C 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,H(MAXHES),GNEW(MAXPAR) 
     .              ,XNEW(MAXPAR),ENEW,GOLD(MAXPAR),XOLD(MAXPAR),EOLD 
     .              ,QDER,DMAX,COSDIR(MAXPAR,2),TRANS1(MAXPAR) 
     .              ,HAUT(MAXPAR+2),DIR(MAXPAR),EIGEN(MAXPAR),R(2),EPS1 
     .              ,COSTET,Q,D,D1,D2,D3,D4,D5,D6,D7,D8,D9,CORREL,PIGI 
     .              ,GIGI,XVAR(MAXPAR,MAXPAR),GVAR(MAXPAR,MAXPAR) 
     .              ,HVEC(MAXPAR,4),THR1,THR2,COORD(MAXPAR+1,NCHAIN) 
     .              ,X(MAXPAR),F,G(MAXPAR),EPS,DELTAE 
     .              ,ISTAB,IJUMP,IROTH,NVAR,ITEG,IBRCH,INDI(NCHAIN,2) 
     .              ,NP1,ITE,KK,JVOIS,ITEST,MM,ITETOT 
     .              ,N,LIMIT,IS,NLR(2),NT,FAIL,MONO,FLAG,FLACHN(NCHAIN) 
      LOGICAL FAIL,MONO,FLAG,FLACHN 
      DIMENSION BARAT(2),DPAS(4),DFON(4),P(MAXPAR,MAXPAR) 
      EQUIVALENCE (DPAS(1),D2),(DFON(1),D6) 
      DATA BARAT /6H  LEFT,6H RIGHT/ 
C 
C... DISPATCHING ACCORDING TO IS 
       SAVE
      ITETOT=ITETOT+1 
      GO TO (9010,9020,9030,9040,9050,9060,9070,9080),IS 
C 
C        *****   SECTION 0   ***** 
C 
C     INITIALIZATION AND CONTROL 
      IF(IS.NE.0) GO TO 9999 
      ISTAB=0 
      NP1 = N+1 
      ITE = 0 
      ITETOT=0 
      ITEG=0 
      PIGI=0.D0 
      GIGI=0.D0 
      IBRCH=0 
      DO 30 I=1,NT 
   30 FLACHN(I)=.TRUE. 
      FLACHN(1)=.FALSE. 
      FLACHN(NT)=.FALSE. 
      NLR(1)=1 
      NLR(2)=1 
      DO 40 I=1,N 
   40 HAUT(I) = X(I) 
C     CONTROL THE CONSISTENCY OF THE MAXIMUM LENGTH 
      DMAX=DABS(DMAX) 
      IF (DMAX.EQ.0.D0) DMAX=1.D30 
      D1=0.D0 
      D2=0.D0 
      D3=0.D0 
      DO 60 I=1,N 
      D1 = D1+(COORD(I,1)-COORD(I,NT))**2 
      D2 = D2+(COORD(I,1)-HAUT(I))**2 
   60 D3 = D3+(COORD(I,NT)-HAUT(I))**2 
      DMAX = MIN(DMAX,SQRT(MIN(D1,D2,D3))/2.99D0) 
      D9=DMAX*1.D-1 
      COSTET=DMOD(COSTET,90.D0) 
      IF(COSTET.EQ.0.D0) COSTET=30.D0 
      WRITE (IPRT,2020) COSTET,DMAX,N,LIMIT,EPS,IMP 
      COSTET=DABS(DCOS(COSTET*3.141692654D0/180.D0)) 
      WRITE (IPRT,2000) 
      WRITE (IPRT,2010) (I,COORD(I,1),HAUT(I),COORD(I,NT),I=1,N) 
      IS = 1 
      RETURN 
C     ( ENERGY OF THE FIRST POINT ) 
 9010 CONTINUE 
      WRITE(IPRT,2015) COORD(NP1,1),F,COORD(NP1,NT) 
      IF(FAIL) GO TO 232 
      IF(F.LE.MAX(COORD(NP1,1),COORD(NP1,NT))) WRITE(IPRT,3070) F 
      HAUT(NP1)=F 
C     THE INITIAL CHAIN IS GENERATED 
      CALL VOISIN 
      JVOIS=0 
  110 JVOIS=JVOIS+1 
      IF(JVOIS.GT.2) GO TO 170 
      ITEST = IDINT (R(JVOIS)/DMAX) 
      IF (ITEST.EQ.0) GO TO 110 
      D8=R(JVOIS)/(ITEST+1) 
      KK = 0 
  120 KK=KK+1 
      IF (KK.GT.ITEST) GO TO 110 
      PAS=D8*(ITEST+1-KK) 
      DO 130 I=1,N 
  130 X(I) = HAUT(I) - COSDIR(I,JVOIS)*PAS 
      IS = 2 
      RETURN 
C     (ENERGY OF THE GENERATED POINT ) 
 9020 CONTINUE 
      IF(FAIL) GO TO 232 
      CALL RABIOT (X,F,N,BARAT) 
      IF(FAIL) GO TO 225 
      GO TO 120 
C 
C... BEGINNING OF ITERATIVE LOOP : LOOK OUT FOR SQUALLS.... 
C 
C        *****   SECTION 1   ***** 
C 
C     HIGHEST POINT RESEARCH AND COMPUTATION OF THE GRADIENT 
C     THE RETURNED COORDINATES ARE IN HAUT AND X 
C     ISTAB=1 IF THE HIGHEST POINT HAS NOT BEEN SHIFTED 
C          =0 OTHERWISE 
  170 CALL PTHAUT 
      ITE=ITE+1 
      ITEG=ITEG+1 
      IS = 3 
      RETURN 
C     ( ENERGY AND GRADIENT AT THE HIGHEST POINT ) 
 9030 CONTINUE 
      IBRCH=1 
      IF(.NOT.FAIL) GO TO 211 
      WRITE(IPRT,3090) ITE 
      GO TO 232 
C     NOTE ... THE ENERGY SHOULD BE TWICE THE SAME . IF NOT,THEN SOME 
C              TROUBLE HAS OCCURED IN SCF ITERATION. 
  211 IF(DABS(F-HAUT(NP1)).LE.DELTAE) GO TO 215 
      WRITE(IPRT,3050) HAUT(NP1),F,(X(I),I=1,N) 
      WRITE(IPRT,2060) 
      GO TO 231 
  215 HAUT(NP1) = F 
      ENEW=F 
      HAUT(N+2)=SQRT(DOT(G,G,N)) 
      RMS=HAUT(N+2)/SQRT(FLOAT(N)) 
      DO 220 I=1,N 
      XNEW(I)=X(I) 
  220 GNEW(I) = G(I) 
      IF(F.LE.MAX(COORD(NP1,1),COORD(NP1,NT))) GO TO 233 
C 
C        *****   SECTION 2   ***** 
C 
C     TEST FOR CONVERGENCE ON RMS GRADIENT AND INDIVIDUAL COMPONENTS 
      IF (RMS.GT.EPS) GO TO 230 
      A=EPS*2.D0 
      DO 221 I=1,N 
  221 A=MAX(A,ABS(G(I))) 
      IF(A.GT.EPS*2.D0) GO TO 230 
C     ... VENI , VIDI , VINCIT . 
      WRITE (IPRT,2050) ITETOT,ITEG 
      IBRCH=0 
C     PRINTOUT AND EXIT 
  225 IS=9 
      IMP=MAX0(IMP,4) 
      IJUMP=2 
      FAIL=.TRUE. 
      CALL QUADR (XVAR,GVAR,P,N,NVAR) 
      FAIL=IBRCH.NE.0 
      CALL ECRIT(BARAT) 
      IMP=IMP0 
      DO 226 I=1,N 
      X(I)=XNEW(I) 
  226 G(I)=GNEW(I) 
      F=ENEW 
      RETURN 
  230 IF(ITE.LE.LIMIT) GO TO 235 
C 
C     DIVERGENCE OR LOSS OF PRECISION : PROGRAM STOPS . 
      WRITE(IPRT,2040) LIMIT 
  231 FAIL=.TRUE. 
      GO TO 225 
  232 WRITE(IPRT,3080) 
      GO TO 225 
  233 WRITE(IPRT,3100) F 
      GO TO 231 
  234 WRITE(IPRT,2060) 
      GO TO 231 
C 
C     UPDATE QUADRATIC INFORMATION 
  235 MONO=ITE.LT.N.OR.Q.NE.0.D0 
      CALL QUADRI(XVAR,GVAR,P,N,NVAR) 
      IF(MONO) GO TO 237 
      ITEG=ITEG+1 
      IS=5 
      RETURN 
C      ( ENERGY AND GRADIENT  FOR HESSIAN ) 
 9050 CONTINUE 
      IF(FAIL) WRITE (IPRT,2110) 
      CALL QUADR(XVAR,GVAR,P,N,NVAR) 
C 
C     PRINTOUT AT EACH ITERATION (UNDER IMP CONTROL) 
  237 FAIL=.FALSE. 
      IF(IMP.GT.0) CALL ECRIT (BARAT) 
C 
C     ENSURE THAT DMAX IS NOT EXCEEDED 
C     DMAX CAN'T BE LOWER THAN A TENTH OF ITS INITIAL VALUE 
      IF(DMAX.LE.D9.OR.MOD(ITE,N).NE.0) GO TO 239 
      I=ITE/N 
      DMAX=DMAX*FLOAT(I+5)/FLOAT(I+6) 
      IF(IMP.GT.0) WRITE(IPRT,2100) DMAX 
C 
C        *****   SECTION 3   ***** 
C 
C     SELECT THE DIRECTION OF HIGHEST POINT SHIFTING 
C     AT THE BEGINNING OF THIS SECTION THE QUADRATIC DIRECTION IS IN DIR 
  239 CALL VOISIN 
      JVOIS=1 
      IF(DOT(DIR,COSDIR(1,1),N).GT.DOT(DIR,COSDIR(1,2),N)) JVOIS=2 
      IF(Q.EQ.0.D0.OR.ISTAB.NE.1) GO TO 240 
C     DIR : QUADRATIC TERMINATION  (IBRCH=1) 
      D=Q 
      D1=QDER 
      IBRCH=1 
      IF(IMP.GT.0.AND.D1.GT.0.D0) WRITE(IPRT,2070) D1 
      IF(IMP.GT.0.AND.D1.LT.0.D0) WRITE(IPRT,2071) D1 
      GO TO 300 
C     WORK OUT TANGENTIAL GRADIENT:TRANS1,(NORM:GTNORM) 
  240 DO 250 I=1,N 
  250 TRANS1(I) = COSDIR(I,1) - COSDIR(I,2) 
      TNORM=SQRT(DOT(TRANS1,TRANS1,N)) 
      DO 260 I=1,N 
  260 TRANS1(I)=TRANS1(I)/TNORM 
      GTNORM=DOT(TRANS1,GNEW,N) 
      IF(DABS(GTNORM).GT.HAUT(N+2)*COSTET) GO TO 280 
      IF(Q.EQ.0.D0.OR.QDER.GT.0.D0) GO TO 270 
C     DIR : QUADRATIC DESCENT (IBRCH=2) 
      D=Q 
      D1=QDER 
      IBRCH=2 
      IF(IMP.GT.0) WRITE(IPRT,2072) D1 
      GO TO 300 
C     DIR : DESCENDING GRADIENT PERPENDICULAR TO THE PATH(IBRCH=3) 
  270 D=DMAX 
      IF(ITE.GT.4) D=MIN(D,MAX(CORREL*HAUT(N+2),D*3.D-4)) 
  273 DO 271 I=1,N 
  271 DIR(I)=TRANS1(I)*GTNORM-GNEW(I) 
      TNORM=SQRT(DOT(DIR,DIR,N)) 
      DO 272 I=1,N 
  272 DIR(I)=DIR(I)/TNORM 
      D1=DOT(DIR,GNEW,N) 
      IBRCH=3 
      IF(IMP.GT.0) WRITE(IPRT,2073) D1 
      GO TO 300 
  280 IF(Q.EQ.0.D0.OR.QDER.LT.0.D0) GO TO 290 
C     DIR : QUADRATIC ASCENT  (IBRCH=4) 
      D=MIN(Q,MAX(R(JVOIS), DMAX*0.1D0)) 
      D1=QDER 
      IBRCH=4 
      IF(IMP.GT.0) WRITE(IPRT,2074)BARAT(JVOIS),D1 
      GO TO 300 
  290 JVOIS=0 
      D1=HAUT(N+2)*0.17D0 
      DO 291 K=1,2 
      TNORM=-DOT(GNEW,COSDIR(1,K),N) 
      IF(TNORM.LT.D1) GO TO 291 
      D1=TNORM 
      JVOIS=K 
  291 CONTINUE 
      IF(JVOIS.EQ.0) GO TO 293 
C     DIR : TOWARDS THE MOST ASCENDING NEIGHBOUR (IBRCH=5) 
      DO 292 I=1,N 
  292 DIR(I)=-COSDIR(I,JVOIS) 
      D=-D1*(R(JVOIS)**2)/(2.D0*(COORD(NP1,INDI(NLR(JVOIS),JVOIS)) 
     $  -HAUT(NP1)-D1*R(JVOIS))) 
      IBRCH=5 
      IF(IMP.GT.0) WRITE(IPRT,2075) BARAT(JVOIS),D1 
      GO TO 300 
  293 D=(R(1)+R(2))/2.D0 
      IF(DABS(GTNORM).GE.HAUT(N+2)*0.17D0) GO TO 273 
C     DIR : MIDDLE OF THE NEIGHBOURS(NO OPTIMIZED RESEARCH),(IBRCH=6) 
      DO 294 I=1,N 
  294 DIR(I)=COSDIR(I,1)+COSDIR(I,2) 
      TNORM=-SQRT(DOT(DIR,DIR,N)) 
      DO 295 I=1,N 
  295 DIR(I)=DIR(I)/TNORM 
      IBRCH=6 
      IF(IMP.GT.0) WRITE(IPRT,2076) 
C     END OF SELECTION. 
C NORMALIZED DIRECTION : DIR. STEP 1 OF LENGTH : D. SLOPE : D1 
C 
C        *****   SECTION 4   ***** 
C 
C     MONODIMENSIONAL OPTIMIZATION ALONG THE DIRECTION DIR 
  300 KK=0 
      MONO=.FALSE. 
  301 KK=KK+1 
      IF(KK.LT.5) GO TO 302 
      KK=4 
      IF (MONO.OR.DPAS(KK).LT.DMAX*2.D-4) GO TO 320 
      D=DMAX*1D-4 
      IMP=MAX0(IMP,2) 
  302 DO 303 I=1,N 
  303 X(I)=HAUT(I)+D*DIR(I) 
      IS=4 
      RETURN 
C      ( F : ENERGY OF THE POINT CORRESPONDING TO STEP D ) 
 9040 CONTINUE 
      IF(.NOT.FAIL) GO TO 305 
      WRITE(IPRT,2080) ITE,D 
      IF(D.LE.DMAX*1.D-4) GO TO 232 
      IMP=MAX0(IMP,2) 
      KK=KK-1 
      D=D/10.D0 
      GO TO 301 
  305 IF(IMP.GT.1) WRITE(IPRT,3020) KK,D,F 
      IF(IBRCH.EQ.6) GO TO 820 
      IF (.NOT.MONO.AND.D1*(F-HAUT(NP1)).GT.0.D0) MONO=.TRUE. 
      DPAS(KK)=D 
      DFON(KK)=F 
      A=(F-HAUT(NP1)-D1*D)/(D**2) 
      D=DMAX 
      IF(A *D1.LT.-1.D-30) D=-D1/(A*2.D0) 
      THR=20.D0 
      IF (MONO) THR=3.D0 
      D=MAX(DPAS(KK)/THR,DMAX*5.D-4,MIN(DMAX,DPAS(KK)*5.D0,D)) 
      IF(IBRCH.GE.4) D=MIN(D,R(JVOIS)) 
      IF (.NOT.MONO) GO TO 301 
      THR=0.05D0*KK 
      DO 312 I=1,KK 
      IF(DABS((D-DPAS(I))/(D+DPAS(I))).LE.THR) GO TO 320 
  312 CONTINUE 
      GO TO 301 
C     THE BEST TRIAL IS KEPT . 
  320 F=HAUT(NP1) 
      IF (MONO) GO TO 321 
      D=0.D0 
      GO TO 323 
  321 DO 322 I=1,KK 
      IF(D1*(DFON(I)-F).LT.0.D0) GO TO 322 
      D=DPAS(I) 
      F=DFON(I) 
  322 CONTINUE 
  323 DO 324 I=1,N 
  324 X(I)=HAUT(I)+D*DIR(I) 
      IF (.NOT.MONO) GO TO 234 
      IMP=IMP0 
C     END OF MONODIMENSIONAL RESEARCH . SELECTED POINT . 
C     STEP : D   COORDINATES : X   ENERGY : F 
C 
C        *****   SECTION 5   ***** 
C 
C     IN CASE OF ASCENDING INTERPOLATION THE PREVIOUS HIGHEST POINT 
C     MAY BE KEPT (TO AVOID AN EXPENSIVE INSERTION ) 
  820 IF(IBRCH.NE.4.OR.IBRCH.NE.5) GO TO 825 
      JVOIS=3-JVOIS 
      K=INDI(NLR(JVOIS),JVOIS) 
      DO 821 I=1,N 
  821 TRANS1(I)=X(I)-COORD(I,K) 
      GTNORM=SQRT(DOT(TRANS1,TRANS1,N)) 
      IF(GTNORM.LT.DMAX) GO TO 825 
      CALL RABIOT (HAUT,HAUT(NP1),N,BARAT) 
      IF(FAIL) GO TO 225 
  825 HAUT(NP1) = F 
      DO 830 I=1,N 
  830 HAUT(I) = X(I) 
      IF(IBRCH.NE.3) GO TO 840 
C 
C     UPDATE THE STEP LENGTH STATISTICAL ESTIMATE 
      PIGI=PIGI+D *HAUT(N+2) 
      GIGI=GIGI+HAUT(N+2)**2 
      CORREL=1.1D0*PIGI/GIGI 
C 
C 
C     POSSIBLE SMOOTHING AND INSERTION 
  840 CALL VOISIN 
      JVOIS=0 
C     D2 IS THE RADIUS OF THE CUT BALL 
      D2=MIN(MAX(R(1),R(2),DMAX*1.D-1),DMAX) 
  845 JVOIS=JVOIS+1 
      IF(JVOIS.GT.2) GO TO 170 
      IF(NLR(JVOIS).EQ.1) GO TO 865 
C     ELIMINATION 
      KFIN=NLR(JVOIS)-1 
      DO 860 K=1,KFIN 
      L=INDI(K,JVOIS) 
      DO 850 I=1,N 
  850 X(I)=HAUT(I)-COORD(I,L) 
      XNORM=DOT(X,X,N) 
      IF(SQRT(XNORM).LE.D2) GO TO 851 
      IF(K.EQ.1) GO TO 856 
      SCAL=DOT(X,G,N) 
      IF((SCAL-GNORM)*(XNORM-SCAL).GE.0.D0)  GO TO 856 
      IF(SQRT((GNORM*XNORM-SCAL**2)/(GNORM+XNORM-2.D0*SCAL)).GT.D2) 
     1                          GO TO 856 
      KCOUP=K-1 
      GO TO 852 
  851 KCOUP=K 
      IF(K.NE.1.AND.SQRT(XNORM).LE.DMAX*1.D-1) KCOUP=KCOUP-1 
  852 KP1=KCOUP+1 
      IF(IMP.GT.0) WRITE(IPRT,3060) BARAT(JVOIS),KP1,NLR(JVOIS) 
      DO 855 I=KP1,NLR(JVOIS) 
  855 FLACHN(INDI(I,JVOIS))=.TRUE. 
      NLR(JVOIS)=KCOUP 
      CALL VOISIN 
      GO TO 865 
  856 GNORM=XNORM 
      DO 860 I=1,N 
  860 G(I)=X(I) 
C     INSERTION 
  865 IF(R(JVOIS).LE.DMAX) GO TO 845 
      PAS=R(JVOIS)/2.D0 
      DO 870 I=1,N 
  870 X(I) = HAUT(I) - COSDIR(I,JVOIS)*PAS 
      IS = 8 
      RETURN 
C     ( ENERGY OF THE GENERATED NEIGHBOUR ) 
 9080 CONTINUE 
      IF(.NOT.FAIL) GO TO 875 
      WRITE(IPRT,3110) ITE,BARAT(JVOIS) 
      GO TO 845 
  875 CALL RABIOT (X,F,N,BARAT) 
      IF(FAIL) GO TO 225 
      GO TO 845 
C 
C 
C     RETURNED BRANCHES ACTUALLY UNUSED 
 9060 CONTINUE 
 9070 CONTINUE 
 9999 WRITE(IPRT,2090) IS 
      GO TO 231 
C 
C 
 2000 FORMAT('0COORDINATES OF MINIMA AND IMPOSED POINT:'/, 
     $'   N      LEFT MINI   INTERMEDIATE   RIGHT MINI'/) 
 2010 FORMAT(I5,3F14.6) 
 2015 FORMAT(/' ENERGY',1P,3D14.4/) 
 2020 FORMAT('1SADDLE POINT RESEARCH... CHAIN METHOD'/ 
     . 9X,'DISCRIMINATION ANGLE:',F5.1,' DEGREES',7X, 
     . 'MAXIMUM LINK LENGTH:',F6.3/ 
     .9X,'DIMENSION:',I3,5X,'MAX.ITERATION:',I4/ 
     .9X,'RMS GRAD CV THRESHOLD:',1PD8.1,10X,'PRINTOUT LEVEL =',I3) 
 2040 FORMAT(' STOP ... ITERATION >',I5,' IN ''CHAIN'' METHOD') 
 2050 FORMAT('0CONVERGENCE ACHIEVED AFTER ',I5,' CALLS OF ENERGY',I4, 
     .' OF WHICH WITH GRADIENT') 
 2060 FORMAT(/' *** LOSS OF PRECISION ON ENERGY OR GRADIENT : STOP ***') 
 2070 FORMAT(' ASCENDING QUADRATIC TERMINATION   SLOPE:',1PD12.3) 
 2071 FORMAT(' DESCENDING QUADRATIC TERMINATION   SLOPE:',1PD12.3) 
 2072 FORMAT(' QUADRATIC DESCENT   SLOPE:',1PD12.3) 
 2073 FORMAT(' DESCENT BY PROJECTED GRADIENT   SLOPE:',1PD12.3) 
 2074 FORMAT(' QUADRATIC ASCENT ON THE',A6,3X,'SLOPE:',1PD12.3) 
 2075 FORMAT(' UP TO NEIGHBOUR ON THE',A6,3X,'SLOPE:',1PD12.3) 
 2076 FORMAT(' BISSECTOR IMPOSED') 
 2080 FORMAT(' ITERATION',I5,' MONODIMENSIONAL RESEARCH. STEP:',F12.8,' 
     .ENERGY DIVERGENCE') 
 2090 FORMAT(' ABNORMAL RETURN... IS =',I2,' STOP') 
 2100 FORMAT(' MAXIMUM DISTANCE REDUCED TO :',F7.4) 
 2110 FORMAT(' WARNING : ENERGY DIVERGENCE FOR EXTRA POINT (HESSIAN)') 
 3020 FORMAT(I4,'  STEP :',F12.8,'   ENERGY :',F12.8) 
 3050 FORMAT(' UNRELIABLE ENERGY AT HIGHEST POINT...E OLD=', 
     . 1P,D13.6,'  E NEW=',D13.6/ 
     .' PROBABLE CROSSING OF STATES. THE CORRESPONDING GEOMETRY IS :' 
     . ,0P/(8F10.5)) 
 3060 FORMAT(' ELIMINATION ON THE',A6,'  FROM',I3,' TO',I3) 
 3070 FORMAT(' WARNING : THE INTERMEDIATE POINT (',1P,D13.6, 
     .' ) IS LOWER THAN A MINIMUM') 
 3080 FORMAT(10X,'DIVERGENCE OF ENERGY ... STOP') 
 3090 FORMAT(' ITERATION',I5,' ENERGY AT HIGHEST POINT IS EVALUATED') 
 3100 FORMAT(' THE SADDLE POINT (',1PD13.6,' ) IS LOWER THAN REACTANTS.. 
     ....STOP') 
 3110 FORMAT(' WARNING : ENERGY DIVERGENCE AT ITERATION',I5,' NON INSERT 
     .ION ON THE',A6) 
      END 
      SUBROUTINE ECRIT (BARAT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C      SADDLE POINT/CHAIN... 
C     PRINTOUT AT EACH ITERATION (CONTROLED BY IMP) 
C 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,H(MAXHES),GNEW(MAXPAR) 
     .              ,XNEW(MAXPAR),ENEW,GOLD(MAXPAR),XOLD(MAXPAR),EOLD 
     .              ,QDER,DMAX,COSDIR(MAXPAR,2),TRANS1(MAXPAR) 
     .              ,HAUT(MAXPAR+2),DIR(MAXPAR),EIGEN(MAXPAR),R(2),EPS1 
     .              ,COSTET,Q,D,D1,D2,D3,D4,D5,D6,D7,D8,D9,CORREL,PIGI 
     .              ,GIGI,XVAR(MAXPAR,MAXPAR),GVAR(MAXPAR,MAXPAR) 
     .              ,HVEC(MAXPAR,4),THR1,THR2,COORD(MAXPAR+1,NCHAIN) 
     .              ,X(MAXPAR),F,G(MAXPAR),EPS,DELTAE 
     .              ,ISTAB,IJUMP,IROTH,NVAR,ITEG,IBRCH,INDI(NCHAIN,2) 
     .              ,NP1,ITE,KK,JVOIS,ITEST,MM,ITETOT 
     .              ,N,LIMIT,IS,NLR(2),NT,FAIL,IBID,FLAG,FLACHN(NCHAIN) 
      DIMENSION BARAT(2) 
      LOGICAL FAIL,IBID,FLAG,FLACHN 
       SAVE
C 
C     GENERAL INFORMATION 
      GG=HAUT(N+2)**2 
      RMS=HAUT(N+2)/SQRT(FLOAT(N)) 
      WRITE (IPRT,200) ITE,ENEW,RMS,GG,MM,(BARAT(I),NLR(I),I=1,2) 
      IF(IMP.LT.2) RETURN 
C     COORDINATES AND GRADIENT AT THE HIGHEST POINT 
      WRITE(IPRT,150) (XNEW(I),I=1,N) 
      WRITE(IPRT,100) (GNEW(I),I=1,N) 
      IF(IMP.LT.3.OR.MM.LT.0) GO TO 21 
C     ESTIMATED SECOND DERIVATIVES 
      WRITE(IPRT,301) 
      MI=MIN0(MM+1,4,N) 
      DO 20 I=1,MI 
   20 WRITE(IPRT,300) I,EIGEN(I),(HVEC(J,I),J=1,N) 
   21 IF(IMP.LT.4) RETURN 
C     CHAIN OF POINTS 
      DO 10   J=1,2 
      WRITE(IPRT,500) BARAT(J),NLR(J) 
      IFIN = NLR(J) 
      DO 10  I=1,IFIN 
      K=INDI((J-1)*(IFIN+1)+(3-2*J)*I,J) 
   10 WRITE (IPRT,400 ) COORD(NP1,K),(COORD(L,K),L=1,N) 
      RETURN 
C 
  100 FORMAT(' GRADIENT    :',6F10.5/(14X,6F10.5)) 
  150 FORMAT(' COORDINATES :',6F10.5/(14X,6F10.5)) 
  200 FORMAT('0ITERATION',I5,1X,'HIGH POINT...ENERGY:',1PD16.8,3X, 
     1 'RMS GRAD.:',D8.2/' <G!G>=',D12.6,5X,'INDEX:',I4,3X, 
     2 'CHAIN LENGTH...',2(A6,':',I2)) 
  300 FORMAT(I3,1P,D13.5,' ... ',0P,7F8.4,/,(21X,7F8.4)) 
  301 FORMAT(' ESTIMATED EIGENVALUES AND EIGENVECTORS OF THE HESSIAN ') 
  500 FORMAT(A6,' CHAIN ','LENGTH:',I3,5X,'ENERGY AND COORDINATES(A,RAD) 
     1 ...') 
  400 FORMAT(1P,D15.7,' ...',5D12.4,/(19X,5D12.4)) 
      END 
      SUBROUTINE RABIOT (X,F,N,BARAT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C----------------------------------------------------------------------- 
C 
C     CHAIN ... INSERTION OF A POINT IN THE CHAIN 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,H(MAXHES),GNEW(MAXPAR) 
     .              ,XNEW(MAXPAR),ENEW,GOLD(MAXPAR),XOLD(MAXPAR),EOLD 
     .              ,QDER,DMAX,COSDIR(MAXPAR,2),TRANS1(MAXPAR) 
     .              ,HAUT(MAXPAR+2),DIR(MAXPAR),EIGEN(MAXPAR),R(2),EPS1 
     .              ,COSTET,Q,D,D1,D2,D3,D4,D5,D6,D7,D8,D9,CORREL,PIGI 
     .              ,GIGI,XVAR(MAXPAR,MAXPAR),GVAR(MAXPAR,MAXPAR) 
     .              ,HVEC(MAXPAR,4),THR1,THR2,COORD(MAXPAR+1,NCHAIN) 
     .              ,XOUT(MAXPAR),FOUT,G(MAXPAR),EPS,DELTAE 
     .              ,ISTAB,IJUMP,IROTH,NVAR,ITEG,IBRCH,INDI(NCHAIN,2) 
     .              ,NP1,ITE,KK,JVOIS,ITEST,MM,ITETOT,NBID 
     .              ,LIMIT,IS,NLR(2),NT,FAIL,IBID,FLAG,FLACHN(NCHAIN) 
      LOGICAL FAIL,IBID,FLAG,FLACHN 
      DIMENSION IT1(2),X(1),BARAT(2) 
       SAVE
      NLR(JVOIS)=NLR(JVOIS)+1 
      IF (NLR(1)+NLR(2).GT.NT) GO TO 120 
      DO 110 JJ=2,NT 
      IF (FLACHN(JJ)) THEN 
         INDI(NLR(JVOIS),JVOIS)=JJ 
         FLACHN(JJ)=.FALSE. 
         DO 100 I=1,N 
  100    COORD(I,JJ) = X(I) 
         COORD (NP1,JJ) = F 
         IF(IMP.GT.0) WRITE(IPRT,1010) BARAT(JVOIS),F 
         RETURN 
      ENDIF 
  110 CONTINUE 
  120 WRITE (IPRT,1000) NLR,NT 
      FAIL=.TRUE. 
      RETURN 
 1000 FORMAT ('0NB OF POINTS ON THE LEFT :',I3,/ 
     $        ' NB OF POINTS ON THE RIGHT :',I3,/ 
     $        ' STOP : THE CHAIN IS TOO LONG >',I3) 
 1010 FORMAT(' INSERTION ON THE',A6,'  ENERGY=',1PD13.5) 
C 
C----------------------------------------------------------------------- 
      ENTRY PTHAUT 
C     CHAIN ... SEARCH FOR THE HIGHEST POINT AND UPDATE ASSOCIATED 
C     INDEXES .ISTAB=1 MEANS THAT THE HIGHEST POINT REMAIN AT THE SAME 
C     INDEX , THUS ALLOWING QUADRATIC DIRECTION . 
C     THE HIGHEST POINT COORDINATES ARE RETURNED IN HAUT AND XOUT 
C 
      EREF = HAUT (NP1) 
      DO 220 J=1,2 
      IT1(J) = 0 
      KKFIN = NLR(J) 
      IF(KKFIN.LE.1) GO TO 220 
      DO 210 K=KKFIN,2,-1 
      IF (COORD(NP1,INDI(K,J)).LE.EREF) GO TO 210 
      EREF = COORD(NP1,INDI(K,J)) 
      IT1(J) = K 
  210 CONTINUE 
  220 CONTINUE 
      IF(IT1(1).NE.0.OR.IT1(2).NE.0) GO TO 225 
      ISTAB=1 
      DO 221 I=1,NP1 
  221 XOUT(I)=HAUT(I) 
      RETURN 
C 
C     SHIFTING MUST BE DONE 
  225 J=2 
      ISTAB=0 
      IF (IT1(2).EQ.0) J=1 
      IT = IT1(J) 
      K=3-J 
      NLR(K) = NLR(K)+1 
      JL = INDI(IT,J) 
      INDI(NLR(K),K)=JL 
      DO 230 I=1,NP1 
      XOUT(I)=COORD(I,JL) 
      COORD(I,JL) = HAUT(I) 
  230 HAUT(I)=XOUT(I) 
      IF (IT.EQ.NLR(J)) GO TO 250 
      DO 240 I=NLR(J),IT+1,-1 
      NLR(K)=NLR(K)+1 
  240 INDI(NLR(K),K)=INDI(I,J) 
  250 NLR(J)=IT-1 
      RETURN 
C 
C----------------------------------------------------------------------- 
      ENTRY VOISIN 
C     CHAIN ... DIRECTIONAL COSINES OF THE NEIGHBOURS AND DISTANCES 
C 
      DO 320 J=1,2 
      K = INDI(NLR(J),J) 
      DO 310 I=1,NBID 
  310 COSDIR(I,J) = HAUT(I) - COORD(I,K) 
      R(J)=SQRT(DOT(COSDIR(1,J),COSDIR(1,J),NBID)) 
      IF(R(J).GT.DMAX*1.D-6) GO TO 315 
      WRITE(IPRT,1020) J,R(J) 
      R(J)=DMAX*1.D-6 
  315 DO 320 I=1,NBID 
  320 COSDIR(I,J) = COSDIR(I,J)/R(J) 
      RETURN 
 1020 FORMAT(' WARNING : CONTIGUOUS LINK',I2,' OF ',1PD11.3,'LENGTH ') 
      END 
      SUBROUTINE QUADRI(XVAR,GVAR,P,NLO,NVARLO) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C 
C     SADDLE POINT/CHAIN... 
C     UPDATE QUADRATIC INFORMATION AND TEST FOR VALIDITY . 
C     PAU   (N*N) VERSION . JANUARY 1984 
C 
C 
C                            ARGUMENTS : 
C     DIR(N) : NORMALIZED QUADRATIC DIRECTION 
C     Q : QUADRATIC DIRECTION LENGTH 
C     CONVENTION : Q=0 MEANS THAT QUADRATIC DIRECTION IS NOT OPERATIVE 
C     MM : HESSIAN INDEX (NUMBER OF NEGATIVE EIGENVALUES) 
C     CONVENTION : MM<0 MEANS THAT HESSIAN IS NOT YET AVAILABLE 
C     EIGEN : MAIN CURVATURES (EIGENVALUES) 
C     HVEC : FIRST EIGENVECTORS OF THE HESSIAN 
C 
C                            DESCRIPTION : 
C     NOTATIONS :  (A)' IS THE TRANSPOSE MATRIX OF (A) . 
C                  INV(A) : IS THE INVERSE MATRIX OF (A) 
C     DEFINITIONS : 
C                  (GNEW)  GRADIENT AT CURRENT POINT (XNEW) . 
C                  (X) LAST VARIATION OF THE COORDINATES (VECTOR) 
C                  (G) ASSOCIATED VARIATION OF THE GRADIENT 
C                  (XVAR) & (GVAR) : PREVIOUS VARIATIONS 
C                                   STORED IN "FIRST-IN FIRST-OUT" ORDER 
C                  (P) CALCULATED HESSIAN 
C                  (H) INV(P) IN CANONICAL ORDER . 
C     SECTION 0 :  VARIOUS INITIALIZATIONS 
C     SECTION 1 :  TEST WHETHER <X!X> > DMAX*DTHR. PROJECTION OF (X) 
C                  INTO THE SUB-SPACE -(XVAR)- MAY NOT EXCEED PROLIM 
C     SECTION 2 :  (X) IS CLOSE TO -(XVAR)- ... TRY TO SUBSTITUTE 
C                  A VECTOR OF (XVAR) BY (X).PROXIMITY CRITERIUM: 
C                  SQUARE OF DOT PRODUCT . 
C     SECTION 3 :  "FIFO" STORAGE OF ORTHONORMALIZED (X) IN (XVAR) 
C                  AND SIMILARLY FOR  (G) IN (GVAR) . 
C     SECTION 4 :  ELABORATE AN INDEPENDANT DIRECTION IF REQUIRED. 
C                  CALL "COMPFG" AND RETURN VIA "QUADR" (CALCULATE AN 
C                  "EXTRA GRADIENT") . 
C     SECTION 5 :  AS SOON AS THE DIMENSION OF -(XVAR)- IS EQUAL TO N 
C                  (P) IS CALCULATED : 
C                       (P1) = (GVAR)*(XVAR)' 
C                       (P) = ( (P1)+(P1)' )*0.5 
C     SECTION 6 :  DIAGONALIZE (P) AND EVALUATE INDEX M . 
C                  STORAGE OF EIGENVALUES (EIGEN) AND VECTORS (HVEC) 
C                  COMPUTE (H)=INV(P) . 
C     SECTION 7 :  QUADRATIC DIRECTION (DIR) = -INV(P)*(GNEW) 
C                  (DIR) IS NORMALIZED TO 1 
C                  THE DIRECTION IS OPERATIVE IF : 
C                       - MM=1 
C                       - <DIR!DIR>  < DMAX**2 
C                       - <DIR!GNEW> .NE. 0  (THRESHOLD : 0.17) . 
C     SECTION 8 :  CHANGE IN GENERATION : THE YOUNG BECOME OLD . 
C                  AND UPDATE THE FLAG FOR ROTATION ONTO 
C                  EIGENVECTORS BASIS. 
C 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,H(MAXHES),GNEW(MAXPAR) 
     .              ,XNEW(MAXPAR),ENEW,GOLD(MAXPAR),XOLD(MAXPAR),EOLD 
     .              ,QDER,DMAX,COSDIR(MAXPAR,2),TRANS1(MAXPAR) 
     .              ,HAUT(MAXPAR+2),DIR(MAXPAR),EIGEN(MAXPAR),R(2),EPS1 
     .              ,COSTET,Q,D,D1,D2,D3,D4,D5,D6,D7,D8,D9,CORREL,PIGI 
     .              ,GIGI,XVAM(MAXPAR,MAXPAR),GVAM(MAXPAR,MAXPAR) 
     .              ,HVEC(MAXPAR,4),PROLIM,DTHR,COORD(MAXPAR+1,NCHAIN) 
     .              ,X(MAXPAR),F,G(MAXPAR),EPS,DELTAE 
     .              ,ISTAB,IJUMP,IROTH,NVAR,ITEG,IBRCH,INDI(NCHAIN,2) 
     .              ,NP1,ITE,KK,JVOIS,ITEST,MM,ITETOT 
     .              ,N,LIMIT,IS,NLR(2),NT,FAIL,MONO,FLAG,FLACHN(NCHAIN) 
      LOGICAL FAIL,MONO,FLAG,FLACHN 
      DIMENSION XVAR(NLO,NLO),GVAR(NLO,NLO),P(NLO,NLO) 
       SAVE
C 
C        *****  SECTION 0  ***** 
C     INITIALIZATION 
      IF(ITE.GT.1) GO TO 10 
      DTHR=0.05D0 
      MM=-N 
      Q=0 
      NVAR=0 
      PROLIM=MIN(30.D0,1.D1+FLOAT(N)/4.D0)/57.3D0 
      PROLIM=DCOS(PROLIM)**2 
      IROTH=0 
      FLAG=.FALSE. 
      GO TO 80 
C 
C        *****  SECTION 1  ***** 
C     TEST FOR PRECISION AND LINEAR INDEPENDANCE OF X / XVAR 
C 
   10 DO 11 I=1,N 
      X(I)=XNEW(I)-XOLD(I) 
   11 G(I)=GNEW(I)-GOLD(I) 
      XNORM=SQRT(DOT(X,X,N)) 
      IJUMP=1 
      IF(XNORM.LT.DMAX*DTHR) GO TO 40 
      DO 12 I=1,N 
      X(I)=X(I)/XNORM 
   12 G(I)=G(I)/XNORM 
      IF(NVAR.EQ.0) GO TO 30 
      DO 13 I=1,NVAR 
   13 XOLD(I)=DOT(XVAR(1,I),X,N) 
      XPROJ=DOT(XOLD,XOLD,NVAR) 
      IF (XPROJ.LE.PROLIM) GO TO 30 
C 
C     *****   SECTION 2  ***** 
C     X NON INDEPENDANT. A SUBSTITUTION IS TRIED. 
C 
      DO 20 I=1,NVAR 
      K=I 
      IF (XPROJ-PROLIM.LE.XOLD(I)*XOLD(I)) GO TO 21 
   20 CONTINUE 
      GO TO 40 
   21 XPROJ=XPROJ-XOLD(K)*XOLD(K) 
      NVAR=NVAR-1 
      IF (K.GT.NVAR) GO TO 30 
CDIR$ IVDEP 
      DO 22 I=K,NVAR 
   22 XOLD(I)=XOLD(I+1) 
      J=1+N*(K-1) 
      K=NVAR*N 
CDIR$ IVDEP 
      DO 23 I=J,K 
      XVAR(I,1)=XVAR(I+N,1) 
   23 GVAR(I,1)=GVAR(I+N,1) 
C 
C       *****   SECTION 3  ***** 
C     ORTHONORMALIZE  AND STORE. 
C 
   30 NVAR=NVAR+1 
      IJUMP=2 
      DO 31 I=1,N 
      XVAR(I,NVAR)=X(I) 
   31 GVAR(I,NVAR)=G(I) 
      IF (NVAR.EQ.1) GO TO 40 
      I1=NVAR-1 
      DO 32 J=1,I1 
CDIR$ IVDEP 
      DO 32 I=1,N 
      XVAR(I,NVAR)=XVAR(I,NVAR)-XOLD(J)*XVAR(I,J) 
   32 GVAR(I,NVAR)=GVAR(I,NVAR)-XOLD(J)*GVAR(I,J) 
      XNORM=SQRT(1.D0-XPROJ) 
      DO 33 I=1,N 
      XVAR(I,NVAR)=XVAR(I,NVAR)/XNORM 
   33 GVAR(I,NVAR)=GVAR(I,NVAR)/XNORM 
C 
C       *****  SECTION 4 ***** 
C     IF REQUIRED,GENERATE AN "EXTRA" DIRECTION ... ASSOCIATED POINT: X 
C 
   40 IF (MONO) GO TO 50 
      IF (NVAR.EQ.N) GO TO 46 
      XTEMP=1.D0 
      DO 42 I=1,N 
      XNORM=0.D0 
      DO 41 J=1,NVAR 
   41 XNORM=XNORM+XVAR(I,J)**2 
      IF (XNORM.GE.XTEMP) GO TO 42 
      K=I 
      XTEMP=XNORM 
   42 CONTINUE 
      DO 43 I=1,N 
      X(I)=0.D0 
   43 XOLD(I)=XVAR(K,I) 
      X(K)=1.D0 
      DO 44 J=1,NVAR 
CDIR$ IVDEP 
      DO 44 I=1,N 
   44 X(I)=X(I)-XOLD(J)*XVAR(I,J) 
      XNORM=SQRT(1.D0-XPROJ)/(DMAX*DTHR) 
      DO 45 I=1,N 
   45 X(I)=XNEW(I)+X(I)/XNORM 
      RETURN 
   46 XNORM=DTHR*DMAX 
      DO 47 I=1,N 
   47 X(I)=XNEW(I)+XVAR(I,1)*XNORM 
      IROTH=IROTH-1 
      RETURN 
C 
C     THIS ENTRY IS USED WHEN AN "EXTRA GRADIENT" HAS BEEN CALCULATED 
C 
      ENTRY QUADR (XVAR,GVAR,P,NLO,NVARLO) 
      IF (FAIL) GO TO 50 
      IJUMP=2 
      IF (NVAR.LT.N) GO TO 49 
      NVAR=N-1 
      K=N*NVAR 
CDIR$ IVDEP 
      DO 48 I=1,K 
      XVAR(I,1)=XVAR(I+N,1) 
   48 GVAR(I,1)=GVAR(I+N,1) 
   49 NVAR=NVAR+1 
      XNORM=1.D0/(DTHR*DMAX) 
      DO 400 I=1,N 
      XVAR(I,NVAR)=(X(I)-XNEW(I))*XNORM 
  400 GVAR(I,NVAR)=(G(I)-GNEW(I))*XNORM 
C 
C      *****   SECTION 5   ***** 
C     UPDATE THE HESSIAN. 
C 
   50 FAIL=.FALSE. 
      IF (NVAR.EQ.N) GO TO 51 
      MM=NVAR-N 
      GO TO 70 
   51 IF (IJUMP.EQ.1) GO TO 70 
      J=N*N 
      DO 52 I=1,J 
   52 P(I,1)=0.D0 
      DO 53 I=1,N 
      DO 53 K=1,N 
      DO 53 J=1,N 
   53 P(I,J)=P(I,J)+GVAR(I,K)*XVAR(J,K) 
      DO 54 I=1,N 
CDIR$ IVDEP 
      DO 54 J=1,I 
      P(I,J)=(P(I,J)+P(J,I))/2.D0 
   54 P(J,I)=P(I,J) 
C 
C        *****  SECTION 6  ***** 
C     ANALYSE THE HESSIAN : INDEX AND REGULARITY 
C 
      IF(IMP.GE.3.OR.FLAG) GO TO 60 
C     DIRECT INVERSION IF EIGENVECTORS NOT REQUIRED 
      CALL INVERT (P,N,MM,EIGEN,EPS1) 
      GO TO 68 
   60 CALL DIAGIV (P,N,N,EIGEN,EPS1) 
      MM=0 
      DO 61 I=1,N 
      IF(EIGEN(I).GT.0.D0) GO TO 66 
   61 MM=I 
   66 IF(.NOT.FLAG) GO TO 62 
      DO 65 J=1,N 
      DO 65 I=1,N 
      GVAR(I,J)=P(I,J)*EIGEN(J) 
   65 XVAR(I,J)=P(I,J) 
      IROTH=MM+2 
   62 K=MIN0(4,MM+1) 
      DO 63 J=1,K 
      DO 63 I=1,N 
   63 HVEC(I,J)=P(I,J) 
      CALL INVRT1(P,N,EIGEN,EPS1) 
C     STORAGE OF THE INVERSE HESSIAN . 
   68 K=0 
      DO 69 I=1,N 
      DO 69 J=1,I 
      K=K+1 
   69 H(K)=P(I,J) 
C 
C        *****  SECTION 7  ***** 
C     QUADRATIC TERMINATION DIRECTION . 
C 
   70 IF(MM.EQ.1) GO TO 72 
   71 Q=0 
      GO TO 80 
   72 CALL SUPDOT(DIR,H,GNEW,N,1) 
      Q=SQRT(DOT(DIR,DIR,N)) 
      IF(Q.GT.DMAX) GO TO 71 
      DO 74 I=1,N 
   74 DIR(I)=-DIR(I)/Q 
      QDER=DOT(DIR,GNEW,N) 
      IF(DABS(QDER).LT.HAUT(N+2)*0.17D0) Q=0 
C 
C        *****  SECTION 8  ***** 
C      SAVE XNEW AND GNEW . 
C 
   80 EOLD=ENEW 
      DO 81 I=1,N 
      XOLD(I)=XNEW(I) 
   81 GOLD(I)=GNEW(I) 
      FLAG=NVAR.EQ.N.AND.MM.GT.1.AND.IROTH.LE.0 
      RETURN 
      END 
      SUBROUTINE CHRGE(P,Q) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION P(*),Q(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
C*********************************************************************** 
C 
C      CHRGE STORES IN Q THE TOTAL ELECTRON DENSITIES ON THE ATOMS 
C 
C      ON INPUT P      = DENSITY MATRIX 
C 
C      ON OUTPUT Q     = ATOM ELECTRON DENSITIES 
C 
C*********************************************************************** 
       SAVE
      K=0 
      DO 10 I=1,NUMAT 
         IA=NFIRST(I) 
         IB=NLAST(I) 
         Q(I)=0.D0 
         DO 10 J=IA,IB 
            K=K+J 
   10 Q(I)=Q(I)+P(K) 
      RETURN 
      END 
      SUBROUTINE CNVG(PNEW, P, P1,NORBS, NITER, PL) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION P1(*), P(*), PNEW(*) 
      LOGICAL EXTRAP 
C*********************************************************************** 
C 
C  CNVG IS A TWO-POINT INTERPOLATION ROUTINE FOR SPEEDING CONVERGENCE 
C       OF THE DENSITY MATRIX. 
C 
C ON OUTPUT P      = NEW DENSITY MATRIX 
C           P1     = DIAGONAL OF OLD DENSITY MATRIX 
C           PL     = LARGEST DIFFERENCE BETWEEN OLD AND NEW DENSITY 
C                    MATRICES 
C*********************************************************************** 
       SAVE
      PL=0.0D00 
      FACA=0.0D00 
      DAMP=1.D10 
      IF(NITER.GT.3)DAMP=0.05D0 
      FACB=0.0D00 
      FAC=0.0D00 
      II=MOD(NITER,3) 
      EXTRAP=II.NE.0 
      K=0 
      DO 20 I=1,NORBS 
         K=K+I 
         A=PNEW(K) 
         SA=ABS(A-P(K)) 
         IF (SA.GT.PL) PL=SA 
         IF (EXTRAP) GO TO 10 
         FACA=FACA+SA**2 
         FACB=FACB+(A-2.D00*P(K)+P1(I))**2 
   10    P1(I)=P(K) 
   20 P(K)=A 
      IF (FACB.LE.0.0D00) GO TO 30 
      IF (FACA.LT.(100.D00*FACB)) FAC=SQRT(FACA/FACB) 
   30 IE=0 
      DO 50 I=1,NORBS 
         II=I-1 
         DO 40 J=1,II 
            IE=IE+1 
            A=PNEW(IE) 
            P(IE)=A+FAC*(A-P(IE)) 
            PNEW(IE)=P(IE) 
   40    CONTINUE 
         IE=IE+1 
         IF(ABS(P(IE)-P1(I)) .GT. DAMP) THEN 
            P(IE)=P1(I)+SIGN(DAMP,P(IE)-P1(I)) 
         ELSE 
            P(IE)=P(IE)+FAC*(P(IE)-P1(I)) 
         ENDIF 
         P(IE)=MIN(2.D0,MAX(P(IE),0.D0)) 
   50 PNEW(IE)=P(IE) 
      RETURN 
      END 
      SUBROUTINE COMPFG(XPARAM,ESCF,FAIL,GRAD,LGRAD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XPARAM(*),GRAD(*) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,DUMY(MAXPAR) 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /ATHEAT/ ATHEAT 
      COMMON /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NWDUM(NUMATM+1) 
      COMMON /ENUCLR/ ENUCLR 
      COMMON /ELECT / ELECT 
      COMMON /HMATRX/ H(MPACK) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /MESAGE/ IFLEPO,IITER 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT 
C*********************************************************************** 
C 
C   COMPFG CALCULATES (A) THE HEAT OF FORMATION OF THE SYSTEM, AND 
C                     (B) THE GRADIENTS, IF LGRAD IS .TRUE. 
C 
C   ON INPUT  XPARAM = ARRAY OF PARAMETERS (INTERNAL OR CARTESIAN COORD) 
C             LGRAD  = .TRUE. IF GRADIENTS ARE NEEDED, .FALSE. OTHERWISE 
C             FAIL   = .TRUE. IF DENSITY MATRIX TO BE RESTORED WITH 
C                             STANDARD DIAGONAL ONES,  .FALSE. OTHERWISE 
C 
C   ON OUTPUT ESCF   = HEAT OF FORMATION. 
C             FAIL   =.TRUE. IF SCF NOT CONVERGED,     .FALSE. OTHERWISE 
C             GRAD   = ARRAY OF GRADIENTS, IF REQUIRED BY LGRAD = .TRUE. 
C 
C*********************************************************************** 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST, DEBUG, PRINT, FAIL, RESTOR, LGRAD 
      DIMENSION COORD(3,NUMATM), W(1) 
      EQUIVALENCE (W,WJ) 
      DATA FIRST /.TRUE./ 
       SAVE
      IF (FIRST) THEN 
         FIRST=.FALSE. 
         PRINT=(INDEX(KEYWRD,'COMP') .NE. 0) 
         DEBUG=(INDEX(KEYWRD,'DEBU') .NE. 0 .AND. PRINT) 
      ENDIF 
C 
C SET UP COORDINATES FOR CURRENT CALCULATION 
C 
C       PLACE THE NEW VALUES OF THE VARIABLES IN THE ARRAY GEO. 
C       MAKE CHANGES IN THE GEOMETRY. 
      DO 10 I=1,NVAR 
      K=LOC(1,I) 
      L=LOC(2,I) 
   10 GEO(L,K)=XPARAM(I) 
C     IMPOSE THE SYMMETRY CONDITIONS + COMPUTE THE DEPENDENT-PARAMETERS 
      IF(NDEP.NE.0) CALL SYMTRY 
C     NOW COMPUTE THE ATOMIC COORDINATES. 
      IF( DEBUG ) THEN 
         WRITE(IPRT,FMT='('' INTERNAL COORDS'',/100(/,3F12.6))') 
     1                ((GEO(J,I),J=1,3),I=1,5) 
      ENDIF 
      CALL GMETRY(GEO,COORD) 
      IF( DEBUG ) THEN 
         WRITE(IPRT,FMT='('' CARTESIAN COORDS'',/100(/,3F12.6))') 
     1                ((COORD(J,I),J=1,3),I=1,5) 
      ENDIF 
      CALL HCORE(COORD, H, W, WJ, WK, ENUCLR) 
C 
C COMPUTE THE HEAT OF FORMATION. 
C 
      RESTOR=FAIL.OR.INDEX(KEYWRD,'FAIL').NE.0 
      CALL ITER(H, W, WJ, WK, ELECT, LGRAD, RESTOR) 
      ESCF=(ELECT+ENUCLR)*23.061D0+ATHEAT 
      FAIL=IITER.NE.1 
      IF(FAIL)  WRITE(IPRT,FMT='('' * * * *** WARNING *** * * * SCF'' 
     *          ,'' NOT CONVERGED IN COMPFG'')') 
      IF(PRINT.OR.FAIL.OR.DEBUG) THEN 
         WRITE(IPRT,FMT='('' COMPFG : HEAT OF FORMATION'',G30.17)')ESCF 
         WRITE(IPRT,FMT='('' PARAMETERS     '',8F8.4,(/10F8.4))') 
     *                (XPARAM(I),I=1,NVAR) 
      ENDIF 
C 
C FIND DERIVATIVES IF DESIRED 
C 
      IF(LGRAD.AND..NOT.FAIL) THEN 
         CALL DERIV(GRAD,FAIL) 
         IF(FAIL) WRITE(IPRT,FMT='('' * * * *** WARNING *** * * * SCF'', 
     *            '' NOT CONVERGED IN DERIV'')') 
         IF(PRINT.OR.DEBUG.OR.FAIL) 
     *   WRITE(IPRT,FMT='('' GRADIENT       '',8F8.2,(/10F8.2))') 
     *                (GRAD(I),I=1,NVAR) 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE AM1 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      CHARACTER NUMBRS(0:9)*1, PARTYP(25)*5, FILES*64, 
     1          KEYWRD*80, TEXT*50, TXTNEW*50, ELEMNT(107)*2 
      COMMON /ATHEAT/ ATHEAT 
     1       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     2                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     3                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ATOMIC/ EISOL(107),EHEAT(107) 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION  IJPARS(5,99), PARSIJ(99) 
      DATA NUMBRS/' ','1','2','3','4','5','6','7','8','9'/ 
      DATA PARTYP/'USS  ','UPP  ','UDD  ','ZS   ','ZP   ','ZD   ', 
     1    'BETAS','BETAP','BETAD','GSS  ','GSP  ','GPP  ','GP2  ', 
     2    'HSP  ','AM1  ','EXPC ','GAUSS','ALP  ','GSD  ','GPD  ', 
     3    'GDD  ','FN1  ','FN2  ','FN3  ','ORB  '/ 
      DATA (ELEMNT(I),I=1,107)/'H ','HE', 
     1 'LI','BE','B ','C ','N ','O ','F ','NE', 
     2 'NA','MG','AL','SI','P ','S ','CL','AR', 
     3 'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI','CU', 
     4 'ZN','GA','GE','AS','SE','BR','KR', 
     5 'RB','SR','Y ','ZR','NB','MO','TC','RU','RH','PD','AG', 
     6 'CD','IN','SN','SB','TE','I ','XE', 
     7 'CS','BA','LA','CE','PR','ND','PM','SM','EU','GD','TB','DY', 
     8 'HO','ER','TM','YB','LU','HF','TA','W ','RE','OS','IR','PT', 
     9 'AU','HG','TL','PB','BI','PO','AT','RN', 
     1 'FR','RA','AC','TH','PA','U ','NP','PU','AM','CM','BK','CF','XX', 
     2 'FM','MD','NO','++','+','--','-','TV'/ 
       SAVE
      I=INDEX(KEYWRD,'EXTERNAL=')+9 
      J=INDEX(KEYWRD(I:),' ')+I-1 
      FILES=KEYWRD(I:J) 
      WRITE(6,'(//5X,'' PARAMETER TYPE      ELEMENT    PARAMETER'')') 
      OPEN(14,STATUS='OLD',FILE=FILES) 
      I=0 
   10 READ(14,'(A40)',ERR=100,IOSTAT=IOS)TEXT 
      IF(TEXT.EQ.' ')GOTO 100 
      IF(INDEX(TEXT,'END').NE.0)GOTO 100 
      ILOWA = ICHAR('a') 
      ILOWZ = ICHAR('z') 
      ICAPA = ICHAR('A') 
************************************************************************ 
      DO 20 I=1,50 
         ILINE=ICHAR(TEXT(I:I)) 
         IF(ILINE.GE.ILOWA.AND.ILINE.LE.ILOWZ) THEN 
            TEXT(I:I)=CHAR(ILINE+ICAPA-ILOWA) 
         ENDIF 
   20 CONTINUE 
************************************************************************ 
      IF(INDEX(TEXT,'END') .NE. 0) GOTO 100 
      DO 30 J=1,25 
      IF(J.GT.21) THEN 
         IT=INDEX(TEXT,'FN') 
         TXTNEW = TEXT(1:IT+2) 
         IF(INDEX(TXTNEW,PARTYP(J)) .NE. 0) GOTO 50 
      ENDIF 
      IF(INDEX(TEXT,PARTYP(J)) .NE. 0) GOTO 50 
  30  CONTINUE 
      WRITE(6,'(''   NAME NOT FOUND'')') 
      STOP 
   50 IPARAM=J 
      IF(IPARAM.GT.21) THEN 
         I=INDEX(TEXT,'FN') 
         KFN=READA(TEXT,I+3) 
      ELSE 
         KFN=0 
      ENDIF 
      I=INDEX(TEXT,PARTYP(J)) 
      K=INDEX(TEXT(I:),' ')+1 
      TXTNEW=TEXT(K:) 
      TEXT=TXTNEW 
      DO 60 J=1,107 
   60 IF(INDEX(TEXT,' '//ELEMNT(J)) .NE. 0) GOTO 70 
      WRITE(6,'('' ELEMENT NOT FOUND '')') 
      WRITE(6,*)' FAULTY LINE: "'//TEXT//'"' 
      STOP 
   70 IELMNT=J 
      PARAM=READA(TEXT,INDEX(TEXT,ELEMNT(J))) 
      DO 80 I=1,LPARS 
         IF(IJPARS(1,I).EQ.KFN.AND.IJPARS(2,I).EQ.IELMNT.AND. 
     1IJPARS(3,I).EQ.IPARAM) GOTO 90 
   80 CONTINUE 
      LPARS=LPARS+1 
      I=LPARS 
   90 IJPARS(1,I)=KFN 
      IJPARS(2,I)=IELMNT 
      IJPARS(3,I)=IPARAM 
      PARSIJ(I)=PARAM 
      GOTO 10 
  100 CONTINUE 
      CLOSE(14) 
      DO 130 J=1,107 
         DO 120 K=1,25 
            DO 110 I=1,LPARS 
               IPARAM=IJPARS(3,I) 
               KFN=IJPARS(1,I) 
               IELMNT=IJPARS(2,I) 
               IF(IPARAM.NE.K) GOTO 110 
               IF(IELMNT.NE.J) GOTO 110 
               PARAM=PARSIJ(I) 
               WRITE(6,'(10X,A5,A1,11X,A2,F17.6)') 
     1PARTYP(IPARAM),NUMBRS(KFN), 
     2ELEMNT(IELMNT),PARAM 
               CALL UPDATE(IPARAM,IELMNT,PARAM,1,KFN) 
  110       CONTINUE 
  120    CONTINUE 
  130 CONTINUE 
      CALL MOLDAT 
      CALL CALPAR 
      ATHEAT=0.D0 
      ETH=0.D0 
      DO 140 I=1,NUMAT 
         NI=NAT(I) 
         ATHEAT=ATHEAT+EHEAT(NI) 
  140 ETH=ETH+EISOL(NI) 
      ATHEAT=ATHEAT-ETH*23.061D0 
      RETURN 
      END 
      SUBROUTINE DCART (COORD,DXYZ,CHNGE) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C*********************************************************************** 
C 
C    DCART CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE 
C          CARTESIAN COORDINATES FOR RHF CLOSED SHELL OR UHF FUNCTION. 
C    THE INTEGRAL DERIVATIVES ARE COMPUTED BY 1 OR 2-POINTS FINITE 
C          DIFFERENCE WITH STEP SIZE CHNGE2 . 
C 
C    INPUT 
C        COORD(3,*) : CARTESIAN COORDINATES (ANGSTROMS). 
C        DXYZ       : NOT DEFINED. 
C        CHNGE      : STEP SIZE OF FINITE DIFFERENCE. 
C    OUTPUT 
C        DXYZ(3,*)  : CARTESIAN DERIVATIVES. 
C 
C*********************************************************************** 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U, K1L,K2L,K3L,K1U,K2U,K3U 
      DIMENSION COORD(3,*), DXYZ(3,*) 
      DIMENSION PDI(171),PADI(171),PBDI(171), 
     1CDI(3,2),NDI(2),LSTOR1(6), LSTOR2(6) 
      CHARACTER*80 KEYWRD 
      LOGICAL DEBUG, FIRST, MAKEP, PRECI 
      EQUIVALENCE (LSTOR1(1),L1L), (LSTOR2(1), K1L) 
      DATA FIRST/.TRUE./ 
       SAVE
C 
      IF (FIRST) THEN 
         DEBUG = (INDEX(KEYWRD,'DCAR') .NE. 0) 
         PRECI = (INDEX(KEYWRD,'PREC') + 
     .            INDEX(KEYWRD,'POWE') + 
     .            INDEX(KEYWRD,'NLLS') + 
     .            INDEX(KEYWRD,'SIGM') + 
     .            INDEX(KEYWRD,'LTRD') + 
     .            INDEX(KEYWRD,'NEWT') + 
     .            INDEX(KEYWRD,'FORC') .NE. 0) 
         FIRST = .FALSE. 
      ENDIF 
      CHNGE2=CHNGE*0.5D0 
      NCELLS=(L1U-L1L+1)*(L2U-L2L+1)*(L3U-L3L+1) 
      DO 10 I=1,6 
      LSTOR2(I)=LSTOR1(I) 
   10 LSTOR1(I)=0 
      IOFSET=(NCELLS+1)/2 
      NUMTOT=NUMAT*NCELLS 
      DO 20 I=1,NUMTOT 
      DO 20 J=1,3 
   20 DXYZ(J,I)=0.D0 
      DO 120 II=1,NUMAT 
         III=NCELLS*(II-1)+IOFSET 
         IM1=II 
         IF=NFIRST(II) 
         IM=NMIDLE(II) 
         IL=NLAST(II) 
         NDI(2)=NAT(II) 
         DO 30 I=1,3 
   30    CDI(I,2)=COORD(I,II) 
         DO 120 JJ=1,IM1 
            JJJ=NCELLS*(JJ-1) 
C  FORM DIATOMIC MATRICES 
            JF=NFIRST(JJ) 
            JM=NMIDLE(JJ) 
            JL=NLAST(JJ) 
C   GET FIRST ATOM 
            NDI(1)=NAT(JJ) 
            MAKEP=.TRUE. 
            DO 110 IK=K1L,K1U 
               DO 110 JK=K2L,K2U 
                  DO 110 KL=K3L,K3U 
                     JJJ=JJJ+1 
                     DO 40 L=1,3 
   40                CDI(L,1)=COORD(L,JJ)+TVEC(L,1)*IK+TVEC(L,2)*JK+TVEC 
     1(L,3)*KL 
                     IF(.NOT. MAKEP) GOTO 90 
                     MAKEP=.FALSE. 
                     IJ=0 
                     DO 50 I=JF,JL 
                        K=I*(I-1)/2+JF-1 
                        DO 50 J=JF,I 
                           IJ=IJ+1 
                           K=K+1 
                           PADI(IJ)=PA(K) 
                           PBDI(IJ)=PB(K) 
   50                PDI(IJ)=P(K) 
C GET SECOND ATOM FIRST ATOM INTERSECTION 
                     DO 80 I=IF,IL 
                        L=I*(I-1)/2 
                        K=L+JF-1 
                        DO 60 J=JF,JL 
                           IJ=IJ+1 
                           K=K+1 
                           PADI(IJ)=PA(K) 
                           PBDI(IJ)=PB(K) 
   60                   PDI(IJ)=P(K) 
                        K=L+IF-1 
                        DO 70 L=IF,I 
                           K=K+1 
                           IJ=IJ+1 
                           PADI(IJ)=PA(K) 
                           PBDI(IJ)=PB(K) 
   70                   PDI(IJ)=P(K) 
   80                CONTINUE 
   90                CONTINUE 
                     IF(II.EQ.JJ) GOTO  110 
                     IF( .NOT.PRECI) THEN 
                        CDI(1,1)=CDI(1,1)+CHNGE2 
                        CDI(2,1)=CDI(2,1)+CHNGE2 
                        CDI(3,1)=CDI(3,1)+CHNGE2 
                        CALL DHC(PDI,PADI,PBDI,CDI,NDI,JF,JM,JL,IF,IM,IL 
     1                          ,NORBS,AA,CUC) 
                     ENDIF 
                     DO 100 K=1,3 
                     IF( PRECI ) THEN 
                        CDI(K,2)=CDI(K,2)-CHNGE2 
                        CALL DHC(PDI,PADI,PBDI,CDI,NDI,JF,JM,JL,IF,IM,IL 
     1                          ,NORBS,AA,CUC) 
                        ENDIF 
                        CDI(K,2)=CDI(K,2)+CHNGE 
                        CALL DHC(PDI,PADI,PBDI,CDI,NDI,JF,JM,JL,IF,IM,IL 
     1                          ,NORBS,EE,CUC) 
                        CDI(K,2)=CDI(K,2)-CHNGE2 
                        IF( .NOT.PRECI) CDI(K,2)=CDI(K,2)-CHNGE2 
                        DERIV=(AA-EE)*23.061D0/CHNGE 
                        DXYZ(K,III)=DXYZ(K,III)-DERIV 
                        DXYZ(K,JJJ)=DXYZ(K,JJJ)+DERIV 
  100                CONTINUE 
  110       CONTINUE 
  120 CONTINUE 
      DO 130 I=1,6 
  130 LSTOR1(I)=LSTOR2(I) 
      IF (  .NOT. DEBUG) RETURN 
      WRITE(6,'(//10X,''CARTESIAN COORDINATE DERIVATIVES'',//3X, 
     1''ATOM  AT. NO.'',5X,''X'',12X,''Y'',12X,''Z'',/)') 
      WRITE(6,'(2I6,F13.6,2F13.6)') 
     1 (I,NAT((I-1)/NCELLS+1),(DXYZ(J,I),J=1,3),I=1,NUMTOT) 
      RETURN 
      END 
      SUBROUTINE DHC (P,PA,PB,XI,NAT,IF,IM,IL,JF,JM,JL, 
     1NORBS,DENER,CUC) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION P(*), PA(*), PB(*) 
      DIMENSION XI(3,*),NFIRST(2),NMIDLE(2),NLAST(2),NAT(*) 
C*********************************************************************** 
C 
C  DHC CALCULATES THE ENERGY CONTRIBUTIONS FROM THOSE PAIRS OF ATOMS 
C         THAT HAVE BEEN MOVED BY SUBROUTINE DERIV. 
C 
C*********************************************************************** 
      COMMON /KEYWRD/ KEYWRD 
     1       /ONELEC/ USS(107),UPP(107),UDD(107) 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /NUMCAL/ NUMCAL 
      CHARACTER*80 KEYWRD 
      LOGICAL UHF, CUC 
      DIMENSION H(171), SHMAT(9,9), F(171), 
     1          WJ(100), E1B(10), E2A(10), WK(100), W(100) 
      DATA ICALCN /0/ 
       SAVE
      IF( ICALCN.NE.NUMCAL) THEN 
         ICALCN=NUMCAL 
         WLIM=1.D0 
         IF(ID.EQ.0)WLIM=0.D0 
         UHF=(INDEX(KEYWRD,'UHF') .NE. 0) 
      ENDIF 
      NFIRST(1)=1 
      NMIDLE(1)=IM-IF+1 
      NLAST(1)=IL-IF+1 
      NFIRST(2)=NLAST(1)+1 
      NMIDLE(2)=NFIRST(2)+JM-JF 
      NLAST(2)=NFIRST(2)+JL-JF 
      LINEAR=(NLAST(2)*(NLAST(2)+1))/2 
      DO 10 I=1,LINEAR 
         F(I)=0.D0 
   10 H(I)=0.0D00 
      DO 20 I=1,2 
         NI=NAT(I) 
         J=NFIRST(I) 
         H((J*(J+1))/2)=USS(NI) 
         H(((J+1)*(J+2))/2)=UPP(NI) 
         H(((J+2)*(J+3))/2)=UPP(NI) 
         H(((J+3)*(J+4))/2)=UPP(NI) 
         H(((J+4)*(J+5))/2)=UDD(NI) 
         H(((J+5)*(J+6))/2)=UDD(NI) 
         H(((J+6)*(J+7))/2)=UDD(NI) 
         H(((J+7)*(J+8))/2)=UDD(NI) 
         H(((J+8)*(J+9))/2)=UDD(NI) 
         H(((J+9)*(J+10))/2)=UDD(NI) 
   20 CONTINUE 
      DO 30 I=1,LINEAR 
   30 F(I)=H(I) 
      JA=NFIRST(2) 
      JB=NLAST(2) 
      JC=NMIDLE(2) 
      IA=NFIRST(1) 
      IB=NLAST(1) 
      IC=NMIDLE(1) 
      JT=JB*(JB+1)/2 
      J=2 
      I=1 
      NJ=NAT(2) 
      NI=NAT(1) 
      CALL H1ELEC(NI,NJ,XI(1,1),XI(1,2),SHMAT) 
      J1=0 
      DO 40 J=JA,JB 
         JJ=J*(J-1)/2 
         J1=J1+1 
         I1=0 
         DO 40 I=IA,IB 
            JJ=JJ+1 
            I1=I1+1 
            H(JJ)=SHMAT(I1,J1) 
   40 F(JJ)=SHMAT(I1,J1) 
      KR=1 
      IF(ID.EQ.0)THEN 
         CALL ROTATE (NJ,NI,XI(1,2),XI(1,1),W(KR),KR,E2A,E1B,ENUCLR,100. 
     1D0) 
      ELSE 
         CALL SOLROT (NJ,NI,XI(1,2),XI(1,1),WJ,WK,KR,E2A,E1B,ENUCLR,100. 
     1D0) 
         IF(WJ(1).LT.WLIM)THEN 
            DO 50 I=1,KR-1 
   50       WK(I)=0.D0 
         ENDIF 
      ENDIF 
C 
C    * ENUCLR IS SUMMED OVER CORE-CORE REPULSION INTEGRALS. 
C 
      I2=0 
      DO 60 I1=IA,IC 
         II=I1*(I1-1)/2+IA-1 
         DO 60 J1=IA,I1 
            II=II+1 
            I2=I2+1 
            H(II)=H(II)+E1B(I2) 
   60 F(II)=F(II)+E1B(I2) 
      DO  70 I1=IC+1,IB 
         II=(I1*(I1+1))/2 
         F(II)=F(II)+E1B(1) 
   70 H(II)=H(II)+E1B(1) 
      I2=0 
      DO 80 I1=JA,JC 
         II=I1*(I1-1)/2+JA-1 
         DO 80 J1=JA,I1 
            II=II+1 
            I2=I2+1 
            H(II)=H(II)+E2A(I2) 
   80 F(II)=F(II)+E2A(I2) 
      DO 90 I1=JC+1,JB 
         II=(I1*(I1+1))/2 
         F(II)=F(II)+E2A(1) 
   90 H(II)=H(II)+E2A(1) 
      CALL FOCK2D(F,P,PA,W, WJ, WK,2,NFIRST,NMIDLE,NLAST) 
      EE=HELECT(NLAST(2),PA,H,F) 
      IF( UHF ) THEN 
         DO 100 I=1,LINEAR 
  100    F(I)=H(I) 
         CALL FOCK2D(F,P,PB,W, WJ, WK,2,NFIRST,NMIDLE,NLAST) 
         EE=EE+HELECT(NLAST(2),PB,H,F) 
      ELSE 
         EE=EE*2.D0 
      ENDIF 
      DENER=EE+ENUCLR 
      RETURN 
C 
      END 
      SUBROUTINE DENROT 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ELEMTS/ ELEMNT(107) 
      COMMON /SCRACH/ B(MAXORB*MAXORB), BONDAB(MAXPAR**2-MAXORB*MAXORB) 
************************************************************************ 
* 
* DENROT PRINTS THE DENSITY MATRIX AS (S-SIGMA, P-SIGMA, P-PI) RATHER 
*        THAN (S, PX, PY, PZ). 
* 
************************************************************************ 
      DIMENSION AROT(9,9), C(3,5,5), PAB(9,9), VECT(9,9) 
      DIMENSION NATOM(MAXORB) 
      DIMENSION XYZ(3,NUMATM), IROT(5,35), ISP(9) 
      CHARACTER * 6 LINE(21) 
      CHARACTER ELEMNT*2,ATORBS(9)*7,ITEXT(MAXORB)*7,JTEXT(MAXORB)*2 
      DATA ATORBS/'S-SIGMA','P-SIGMA','  P-PI ','  P-PI ','D-SIGMA', 
     1            '  D-PI ','  D-PI ',' D-DELL',' D-DELL'/ 
*********************************************************************** 
* IROT IS A MAPPING LIST. FOR EACH ELEMENT OF AROT 5 NUMBERS ARE 
* NEEDED. THESE ARE, IN ORDER, FIRST AND SECOND SUBSCRIPTS OF AROT, 
* AND FIRST,SECOND, AND THIRD SUBSCRIPTS OF C, THUS THE FIRST 
* LINE OF IROT DEFINES AROT(1,1)=C(1,3,3) 
* 
*********************************************************************** 
      DATA IROT/1,1,1,3,3, 2,2,2,4,3, 3,2,2,2,3, 4,2,2,3,3, 2,3,2,4,2, 
     1          3,3,2,2,2, 4,3,2,3,2, 2,4,2,4,4, 3,4,2,2,4, 4,4,2,3,4, 
     2          5,5,3,1,5, 6,5,3,4,3, 7,5,3,3,3, 8,5,3,2,3, 9,5,3,5,3, 
     3          5,6,3,1,2, 6,6,3,4,2, 7,7,3,3,2, 8,6,3,2,2, 9,6,3,5,2, 
     4          5,7,3,1,4, 6,7,3,4,4, 7,7,3,3,4, 8,7,3,2,4, 9,7,3,5,4, 
     5          5,8,3,1,1, 6,8,3,4,1, 7,8,3,3,1, 8,8,3,2,1, 9,8,3,5,1, 
     6          5,9,3,1,5, 6,9,3,4,5, 7,9,3,3,5, 8,9,3,2,5, 9,9,3,5,5/ 
      DATA ISP /1,2,3,3,4,5,5,6,6/ 
       SAVE
      CALL GMETRY(GEO,XYZ) 
      IPRT=0 
      DO 110 I=1,NUMAT 
         IF=NFIRST(I) 
         IL=NLAST(I) 
         IPQ=IL-IF-1 
         II=IPQ+2 
         DO 10 I1=1,II 
            J1=IPRT+ISP(I1) 
            ITEXT(J1)=ATORBS(I1) 
            JTEXT(J1)=ELEMNT(NAT(I)) 
            NATOM(J1)=I 
   10    CONTINUE 
         IPRT=J1 
         IF(IPQ.NE.2)IPQ=MIN(MAX(IPQ,1),3) 
         DO 110 J=1,I 
            JF=NFIRST(J) 
            JL=NLAST(J) 
            JPQ=JL-JF-1 
            JJ=JPQ+2 
            IF(JPQ.NE.2)JPQ=MIN(MAX(JPQ,1),3) 
            DO 20 I1=1,9 
               DO 20 J1=1,9 
   20       PAB(I1,J1)=0.D0 
            KK=0 
            DO 30 K=IF,IL 
               KK=KK+1 
               LL=0 
               DO 30 L=JF,JL 
                  LL=LL+1 
   30       PAB(KK,LL)=P(L+(K*(K-1))/2) 
            CALL COE(XYZ(1,I),XYZ(2,I),XYZ(3,I), 
     1                 XYZ(1,J),XYZ(2,J),XYZ(3,J),IPQ,JPQ,C,R) 
            DO 40 I1=1,9 
               DO 40 J1=1,9 
   40       AROT(I1,J1)=0.D0 
            DO 50 I1=1,35 
   50       AROT(IROT(1,I1),IROT(2,I1))= 
     1            C(IROT(3,I1),IROT(4,I1),IROT(5,I1)) 
            L1=ISP(II) 
            L2=ISP(JJ) 
            DO 60 I1=1,9 
               DO 60 J1=1,9 
   60       VECT(I1,J1)=-1.D0 
            DO 70 I1=1,L1 
               DO 70 J1=1,L2 
   70       VECT(I1,J1)=0.D0 
            IF(I.NE.J) THEN 
               IJ=MAX(II,JJ) 
               DO 90 I1=1,II 
                  DO 90 J1=1,JJ 
                     SUM=0.D0 
                     DO 80 L1=1,IJ 
                        DO 80 L2=1,IJ 
   80                SUM=SUM+AROT(L1,I1)*PAB(L1,L2)*AROT(L2,J1) 
   90          VECT(ISP(I1),ISP(J1))= 
     1                        VECT(ISP(I1),ISP(J1))+SUM**2 
            ENDIF 
            K=0 
            DO  100 I1=IF,IL 
               K=K+1 
               L=0 
               DO 100 J1=JF,JL 
                  L=L+1 
  100       IF(J1.LE.I1) B(J1+(I1*(I1-1))/2)=VECT(K,L) 
  110 CONTINUE 
C 
C NOW TO REMOVE ALL THE DEAD SPACE IN P, CHARACTERISED BY -1.0 
C 
      LINEAR=(NORBS*(NORBS+1))/2 
      L=0 
      DO 120 I=1,LINEAR 
         IF(B(I).GT.-0.1) THEN 
            L=L+1 
            B(L)=B(I) 
         ENDIF 
  120 CONTINUE 
C 
C   PUT ATOMIC ORBITAL VALENCIES ONTO THE DIAGONAL 
C 
      DO 150 I=1,IPRT 
         SUM=0.D0 
         II=(I*(I-1))/2 
         DO 130 J=1,I 
  130    SUM=SUM+B(J+II) 
         DO 140 J=I+1,IPRT 
  140    SUM=SUM+B((J*(J-1))/2+I) 
  150 B((I*(I+1))/2)=SUM 
      DO 160 I=1,21 
  160 LINE(I)='------' 
      LIMIT=(IPRT*(IPRT+1))/2 
      KK=8 
      NA=1 
  170 LL=0 
      M=MIN0((IPRT+1-NA),6) 
      MA=2*M+1 
      M=NA+M-1 
      WRITE(6,'(/16X,10(1X,A7,3X))')(ITEXT(I),I=NA,M) 
      WRITE(6,'(15X,10(2X,A2,I3,4X))')(JTEXT(I),NATOM(I),I=NA,M) 
      WRITE (6,'(20A6)') (LINE(K),K=1,MA) 
      DO 190 I=NA,IPRT 
         LL=LL+1 
         K=(I*(I-1))/2 
         L=MIN0((K+M),(K+I)) 
         K=K+NA 
         IF ((KK+LL).LE.50) GO TO 180 
         WRITE (6,'(''1'')') 
         WRITE(6,'(/17X,10(1X,A7,3X))')(ITEXT(N),N=NA,M) 
         WRITE(6,'( 17X,10(2X,A2,I3,4X))')(JTEXT(N),NATOM(N),N=NA,M) 
         WRITE (6,'(20A6)') (LINE(N),N=1,MA) 
         KK=4 
         LL=0 
  180    WRITE (6,'(1X,A7,1X,A2,I3,10F11.6)') 
     1   ITEXT(I),JTEXT(I),NATOM(I),(B(N),N=K,L) 
  190 CONTINUE 
      IF (L.GE.LIMIT) GO TO 200 
      KK=KK+LL+4 
      NA=M+1 
      IF ((KK+IPRT+1-NA).LE.50) GO TO 170 
      KK=4 
      WRITE (6,'(''1'')') 
      GO TO 170 
  200 RETURN 
      END 
      SUBROUTINE DENSIT( C,MDIM, NORBS,NDUBL, NSINGL, FRACT, P) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION P(*), C(MDIM,*) 
C*********************************************************************** 
C 
C   DENSIT COMPUTES THE DENSITY MATRIX GIVEN THE EIGENVECTOR MATRIX, AND 
C          INFORMATION ABOUT THE M.O. OCCUPANCY. 
C 
C  INPUT:  C     = SQUARE EIGENVECTOR MATRIX, C IS OF SIZE MDIM BY MDIM 
C                  AND THE EIGENVECTORS ARE STORED IN THE TOP LEFT-HAND 
C                  CORNER. 
C          NORBS = NUMBER OF ORBITALS 
C                  (MUST BE EQUAL TO MDIM IN THE CRAY VERSION) 
C          NDUBL = LABEL OF THE LAST DOUBLY-OCCUPIED M.O ( =0 IF UHF) 
C          NSINGL= LABEL OF THE LAST OCCUPIED M.O 
C 
C   ON EXIT: P   = DENSITY MATRIX, PACKED, CANONICAL 
C 
C*********************************************************************** 
C 
C SET UP LIMITS FOR SUMS 
C  NL1 = BEGINING OF ONE ELECTRON SUM 
C  NU1 = END OF SAME 
C  NL2 = BEGINING OF TWO ELECTRON SUM 
C  NU2 = END OF SAME 
C 
C    SCALAR VERSION 
C     L=0 
C     DO 40 I=1,NORBS 
C        DO 30 J=1,I 
C           L=L+1 
C           SUM2=0.D0 
C           DO 10 K=1,NDUBL 
C  10       SUM2=SUM2+C(I,K)*C(J,K) 
C           SUM1=0.D0 
C           DO 20 K=NDUBL+1,NSINGL 
C  20       SUM1=SUM1+C(I,K)*C(J,K) 
C  30    P(L)=(SUM2*2.D0+SUM1*FRACT) 
C  40 CONTINUE 
C 
C     CRAY VERSION 
      COMMON /SCRACH/ PSYM(MORB2),B(MORB2) 
       SAVE
      L=0 
      DO 20 J=1,NORBS 
      DO 10 I=1,NDUBL 
      L=L+1 
   10 B(L)=C(J,I)*2.D0 
      DO 20 I=NDUBL+1,NSINGL 
      L=L+1 
   20 B(L)=C(J,I)*FRACT 
      CALL MXM (C,NORBS,B,NSINGL,PSYM,NORBS) 
      L=0 
      DO 30 I=1,NORBS 
      DO 30 J=I,I+(I-1)*NORBS,NORBS 
      L=L+1 
   30 P(L)=PSYM(J) 
      RETURN 
      END 
      SUBROUTINE DEPVAR (A,I,W,L) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION A(3,*) 
C*********************************************************************** 
C 
C  IN SUBROUTINE HADDON WHEN M, THE SYMMETRY OPERATION, IS 18 DEPVAR IS 
C  CALLED. DEPVAR SHOULD THEN CONTAIN A USER-WRITTEN SYMMETRY OPERATION. 
C  SEE HADDON TO GET THE IDEA ON HOW TO WRITE DEPVAR. 
C 
C ON INPUT: 
C           A = ARRAY OF INTERNAL COORDINATES 
C           I = ADDRESS OF REFERENCE ATOM 
C ON OUTPUT: 
C           L = 1 (IF A BOND-LENGTH IS THE DEPENDENT FUNCTION) 
C             = 2 (IF AN ANGLE IS THE DEPENDENT FUNCTION) 
C             = 3 (IF A DIHEDRAL ANGLE IS THE DEPENDENT FUNCTION) 
C           W = VALUE OF THE FUNCTION 
C 
C  NOTE:  IT IS THE WRITER'S RESPONSIBILITY TO MAKE CERTAIN THAT THE 
C         SUBROUTINE DOES NOT CONTAIN ANY ERRORS] 
C*********************************************************************** 
      COMMON /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST 
      DATA FIRST/.TRUE./ 
       SAVE
      IF (FIRST) THEN 
         FIRST=.FALSE. 
         FACT=READA(KEYWRD,INDEX(KEYWRD,'DEPVAR=')) 
         WRITE(6,'(''  UNIT CELL LENGTH ='',F14.7, 
     1'' TIMES BOND LENGTH'')')FACT 
      ENDIF 
      W=A(1,I)*FACT 
      L=1 
      RETURN 
      END 
      SUBROUTINE DERI0 (C,CT,E,N) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     COMPUTE THE DIAGONAL DOMINANT PART OF THE SUPER-MATRIX AND 
C     DEFINE THE SCALAR COEFFICIENTS APPLIED ON EACH ROW OF THE 
C     SUPER LINEAR SYSTEM IN ORDER TO REDUCE THE EIGENVALUE SPECTRUM OF 
C     THE ELECTRONIC HESSIAN, 
C     THUS SPEEDING CONVERGENCE OF RELAXATION PROCESS IN 'DERI2'. 
C  INPUT 
C     C(N,N)           : M.O. COEFFICIENTS. 
C     E(N)             : EIGENVALUES OF FOCK MATRIX. 
C     N                : NUMBER OF M.O. 
C     NBO(3)           : OCCUPANCY BOUNDARIES. 
C     FRACT            : PARTIAL OCCUPANCY OF 'OPEN' SHELLS. 
C  OUTPUT 
C     CT               : TRANSPOSE OF C (OPEN,VIRTUAL PACKED). 
C  OUTPUT IN /SCRAH1/ 
C     SCALAR(MINEAR)   : SCALE APPLIED ON EACH COLUMN AND ROW OF THE 
C                        SYMMETRIC SUPER SYSTEM. 
C     DIAG  (MINEAR)   : DIAGONAL ELEMENTS * SCALAR. 
C 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA 
     2               ,NCLOSE,NOPEN,NDUMY,FDUM 
     3       /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT,NBO(3) 
      DIMENSION C(N,N),E(N),CT(*) 
       SAVE
      SHIFT=2.36D0 
C 
C     DOMINANT DIAGONAL PART OF THE SUPER-MATRIX. 
C     ------------------------------------------- 
      L=1 
      IF(NBO(2).GT.0 .AND. NBO(1).GT.0) THEN 
C        OPEN-CLOSED 
         CONST=1.D0/(2.D0-FRACT) 
         DO 10 J=1,NBO(1) 
         DO 10 I=NBO(1)+1,NOPEN 
         DIAG(L)=(E(I)-E(J))*CONST 
   10    L=L+1 
      ENDIF 
      IF(NBO(3).GT.0 .AND. NBO(1).GT.0) THEN 
C        VIRTUAL-CLOSED 
         DO 20 J=1,NBO(1) 
         DO 20 I=NOPEN+1,N 
         DIAG(L)=(E(I)-E(J))*0.5D0 
   20    L=L+1 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN 
C        VIRTUAL-OPEN 
         CONST=1.D0/FRACT 
         DO 30 J=NBO(1)+1,NOPEN 
         DO 30 I=NOPEN+1,N 
         DIAG(L)=(E(I)-E(J))*CONST 
   30    L=L+1 
      ENDIF 
C 
C     TAKE SCALE FACTORS AS (SHIFT-DIAG)**(-0.5) . 
C     ------------------------------------------ 
      DO 40 I=1,L-1 
      SCALAR(I)=SQRT(1.D0/MAX(0.3D0*DIAG(I),DIAG(I)-SHIFT)) 
   40 DIAG(I)=DIAG(I)*SCALAR(I) 
C 
C     STORE CT = C' FOR FURTHER USE IN DERI1 AND DERI22 
C     ------------------------------------------------- 
C     CLOSED 
CCC   L=0 
CCC   DO 50 I=1,N 
CCC   DO 50 J=1,NBO(1) 
CCC   L=L+1 
CCC50 CT(L)=C(I,J) 
      L=N*NBO(1) 
C     OPEN 
      DO 60 I=1,N 
      DO 60 J=NBO(1)+1,NOPEN 
      L=L+1 
   60 CT(L)=C(I,J) 
C     VIRTUAL 
      DO 70 I=1,N 
      DO 70 J=NOPEN+1,N 
      L=L+1 
   70 CT(L)=C(I,J) 
      RETURN 
      END 
      SUBROUTINE DERI1 (C,CT,N,COORD,STEP,NUMBER,WORK,GRAD,W2,H2,H3 
     .                 ,F,MINEAR,FD,NINEAR,PQKL,MPQKL,CIJRDY) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C******************************************************************** 
C 
C     DERI1 COMPUTE THE NON-RELAXED DERIVATIVE OF THE (1/2 ELECTRON OR 
C     CI)-ENERGY WITH RESPECT TO ONE CARTESIAN COORDINATE AT A TIME 
C                             AND 
C     COMPUTE THE NON-RELAXED FOCK MATRIX DERIVATIVE IN M.O BASIS AS 
C     REQUIRED IN THE RELAXATION SECTION (ROUTINE 'DERI2'). 
C 
C   INPUT 
C     C(N,N) : M.O. COEFFICIENTS. 
C     CT     : IDEM, TRANSPOSED AND ORDERED AS CLOSED,OPEN,VIRTUAL. 
C     COORD  : CARTESIAN COORDINATES ARRAY. 
C     STEP   : STEP SIZE OF THE FINITE DIFFERENCE METHOD USED FOR THE 
C              INTEGRAL DERIVATIVES. 
C     NUMBER : LOCATION OF THE REQUIRED VARIABLE IN COORD. 
C     WORK   : WORK ARRAY OF SIZE N*N. 
C     W2     : WORK ARRAYS FOR d<PQ!RS> (2-CENTERS  A.O) 
C     PQKL(MPQKL)           : WORK ARRAY  FOR d<IJ!KL> (C.I-ACTIVE M.O) 
C   OUTPUT 
C     C,CT,COORD,NUMBER : NOT MODIFIED. 
C     STEP   : DESTROYED. 
C     GRAD   : DERIVATIVE OF THE HEAT OF FORMATION WITH RESPECT TO 
C              COORD(NUMBER), WITHOUT RELAXATION CORRECTION. 
C     F(MINEAR) : NON-RELAXED FOCK MATRIX DERIVATIVE WITH RESPECT TO 
C              COORD(NUMBER), EXPRESSED IN M.O BASIS, SCALED AND 
C              PACKED, OFF-DIAGONAL BLOCKS ONLY. 
C     FD(NINEAR): IDEM BUT UNSCALED, DIAGONAL BLOCKS, C.I-ACTIVE ONLY. 
C 
C*********************************************************************** 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA 
     2               ,NCLOSE,NOPEN,NDUMY,FRACT 
     3       /VECTOR/ CDUM(MORB2),EIGS(MAXORB),WDUM(MORB2),EIGB(MAXORB) 
     4       /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
     5       /WMATRX/ WDUMMY(N2ELEC*3), NUMBW, NWDUM(NUMATM) 
     6       /HMATRX/ H(MPACK) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT 
     1       /ELECT / ELECT 
     2       /ENUCLR/ ENUCLR 
     3       /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
     4       /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
     5       /CIDATA/ VECTCI(NMECI**2),XXCI,NCI1,NCI2,NCI3 
     6       /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT2,NBO(3) 
     7       /KEYWRD/ KEYWRD 
     8       /SCRACH/ DIJKLD(NMECI*(NMECI+1)*NUMATM*5),BUF(MORB2) 
      DIMENSION COORD(*),C(N,N),WORK(N,N),F(*),FD(*),W2(*),H2(*),H3(*) 
      DIMENSION CT(*) 
      CHARACTER KEYWRD*80 
      LOGICAL DEBUG,CIJRDY 
       SAVE
C 
      DEBUG=INDEX(KEYWRD,'DERI1').NE.0 
      LINEAR=NORBS*(NORBS+1)/2 
      CALL SECOND (TIME1) 
C 
C     2 POINTS FINITE DIFFERENCE TO GET THE INTEGRAL DERIVATIVES 
C     ---------------------------------------------------------- 
C     STORED IN H2 AND W2, WITHOUT DIVIDING BY THE STEP SIZE. 
C 
      NATI=(NUMBER-1)/3+1 
      NATX=NUMBER-3*(NATI-1) 
      CALL DHCORE (COORD,H2,W2,ENUCL2,NATI,NATX,STEP) 
      STEP=0.5D0/STEP 
C 
C     NON-RELAXED FOCK MATRIX DERIVATIVE IN A.O BASIS. 
C     ------------------------------------------------ 
C     STORED IN H3, DIVIDED BY STEP. 
C 
      CALL SCOPY (LINEAR,H2,1,H3,1) 
      CALL DFOCK2 (H3,P,PA,W2,NUMAT,NFIRST,NMIDLE,NLAST,NATI) 
C 
C     DERIVATIVE OF THE SCF-ONLY ENERGY (I.E BEFORE C.I CORRECTION) 
C     ------------------------------------------------------------- 
C 
      GRAD=(HELECT(NORBS,P,H2,H3)+ENUCL2)*STEP 
C     TAKE STEP INTO ACCOUNT IN H3 
      DO 10 I=1,LINEAR 
   10 H3(I)=H3(I)*STEP 
C 
C     RIGHT-HAND SIDE SUPER-VECTOR F = C' H3 C USED IN RELAXATION 
C     ----------------------------------------------------------- 
C     STORED IN NON-STANDARD PACKED FORM IN F(MINEAR) AND FD(NINEAR). 
C     THE SUPERVECTOR IS THE NON-RELAXED FOCK MATRIX DERIVATIVE IN 
C     M.O BASIS: F(IJ)= ( (C' * FOCK * C)(I,J) )   WITH I.GT.J . 
C     F IS SCALED AND PACKED IN SUPERVECTOR FORM WITH 
C                THE CONSECUTIVE FOLLOWING OFF-DIAGONAL BLOCKS: 
C             1) OPEN-CLOSED  I.E. F(IJ)=F(I,J) WITH I OPEN & J CLOSED 
C                                  AND I RUNNING FASTER THAN J, 
C             2) VIRTUAL-CLOSED SAME RULE OF ORDERING, 
C             3) VIRTUAL-OPEN   SAME RULE OF ORDERING. 
C     FD IS PACKED AS FOLLOWS 
C        1) .... THE CONSECUTIVE DIAGONAL BLOCKS OVER C.I-ACTIVE M.O: 
C             1) CLOSED-CLOSED   IN CANONICAL ORDER, WITHOUT THE 
C                                DIAGONAL ELEMENTS, 
C             2) OPEN-OPEN       SAME RULE OF ORDERING, 
C             3) VIRTUAL-VIRTUAL SAME RULE OF ORDERING. 
C        2) .... OFF-DIAGONAL VIRTUAL-VIRTUAL-C.I-ACTIVE (IF ANY) 
C        3) .... DIAGONAL ELEMENTS OVER C.I-ACTIVE M.O 
C 
C     PART 1 : WORK(N,NEND) = H3(N,N) * C(N,NEND) 
      NEND=MAX(NOPEN,NCI1+NCI2) 
C     CRAY VERSION: UNPACK H3 IN BUF THEN CALL MXM. 
      K=0 
      DO 20 I=1,N 
      IJ=I 
CDIR$ IVDEP 
      DO 20 JI=N*(I-1)+1,N*(I-1)+I 
      K=K+1 
      BUF(JI)=H3(K) 
      BUF(IJ)=H3(K) 
   20 IJ=IJ+N 
      CALL MXM (BUF,N,C,N,WORK,NEND) 
C 
C     PART 2 : F(IJ) =  (C' * WORK)(I,J) ... OFF-DIAGONAL BLOCKS. 
      L=1 
      IF(NBO(2).NE.0 .AND. NBO(1).NE.0) THEN 
C        OPEN-CLOSED 
         CALL MXM (CT(NBO(1)*N+1),NBO(2),WORK,N,F(L),NBO(1)) 
         L=L+NBO(2)*NBO(1) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(1).NE.0) THEN 
C        VIRTUAL-CLOSED 
         CALL MXM (CT(NOPEN*N+1),NBO(3),WORK,N,F(L),NBO(1)) 
         L=L+NBO(3)*NBO(1) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN 
C        VIRTUAL-OPEN 
         CALL MXM (CT(NOPEN*N+1),NBO(3),WORK(1,NBO(1)+1),N,F(L),NBO(2)) 
      ENDIF 
C     SCALE F ACCORDING TO THE DIAGONAL METRIC TENSOR 'SCALAR '. 
      DO 30 I=1,MINEAR 
   30 F(I)=F(I)*SCALAR(I) 
C 
C     PART 3 : SUPER-VECTOR FD, C.I-ACTIVE DIAGONAL BLOCKS, UNSCALED. 
      L=1 
      NEND=0 
      DO 50 LOOP=1,3 
      NINIT=NEND+1 
      NEND =NEND+NBO(LOOP) 
      N1=MAX(NINIT,NCI1+1   ) 
      N2=MIN(NEND ,NCI1+NCI2) 
      IF(N2.LT.N1) GO TO 50 
      DO 40 I=N1,N2 
      IF(I.GT.NINIT) THEN 
         CALL MXM (C(1,I),1,WORK(1,NINIT),N,FD(L),I-NINIT) 
         L=L+I-NINIT 
      ENDIF 
   40 CONTINUE 
   50 CONTINUE 
      NCOL=N2-NINIT+1 
      IF (NCOL.GT.0.AND.N2.LT.N) THEN 
         CALL MTXM (C(1,N2+1),N-N2,WORK(1,NINIT),N,FD(L),NCOL) 
         L=L+NCOL*(N-N2) 
      ENDIF 
C 
C     NON-RELAXED C.I CORRECTION TO THE ENERGY DERIVATIVE. 
C     ---------------------------------------------------- 
C 
C     C.I-ACTIVE FOCK EIGENVALUES DERIVATIVES, STORED IN FD(CONTINUED). 
      LCUT=L 
      DO 60 I=NCI1+1,NCI1+NCI2 
      FD(L)=SDOT(N,C(1,I),1,WORK(1,I),1) 
   60 L=L+1 
C     NOW WORK IS RELEASED AND FD HAS BEEN COMPLETED. 
C 
C     C.I-ACTIVE 2-ELECTRONS INTEGRALS DERIVATIVES. STORED IN XY. 
      CALL DIJKL1 (C,N,NCI1+1,NCI2,W2,PQKL,MPQKL,XY,NMECI,NATI,CIJRDY) 
      CIJRDY=NATX.NE.3 
      DO 70 I=1,NCI2 
      DO 70 J=1,NCI2 
      DO 70 K=1,NCI2 
      DO 70 L=1,NCI2 
   70 XY(I,J,K,L)=XY(I,J,K,L)*STEP 
C 
C     BUILD THE C.I MATRIX DERIVATIVE, STORED IN W2. 
      CALL MECID (FD(LCUT-NCI1),GSE,EIGB,WORK) 
      CALL MECIH (WORK,W2) 
C 
C     NON-RELAXED C.I CONTRIBUTION TO THE ENERGY DERIVATIVE. 
      CALL SUPDOT (WORK,W2,VECTCI,NCI3,1) 
      GRAD=(GRAD+SDOT(NCI3,VECTCI,1,WORK,1))*23.061D0 
      IF(DEBUG.AND.INDEX(KEYWRD,' DEBU').NE.0) THEN 
         WRITE(IPRT,'('' * * * GRADIENT COMPONENT NUMBER'',I4)')NUMBER 
         WRITE(IPRT,'('' NON-RELAXED C.I-ACTIVE FOCK EIGENVALUES '', 
     .                ''DERIVATIVES (E.V.)'')') 
         WRITE(IPRT,'(8F10.4)')(FD(LCUT-1+I),I=1,NCI2) 
         WRITE(IPRT,'('' NON-RELAXED 2-ELECTRONS DERIVATIVES (E.V.)''/ 
     .''  I    J    K    L         d<I(1)J(1)!K(2)L(2)>'')') 
         DO 80 I=1,NCI2 
         DO 80 J=1,I 
         DO 80 K=1,I 
         LL=K 
         IF(K.EQ.I) LL=J 
         DO 80 L=1,LL 
   80    WRITE(IPRT,'(4I5,F20.10)') 
     .              NCI1+I,NCI1+J,NCI1+K,NCI1+L,XY(I,J,K,L) 
      ENDIF 
      IF (DEBUG) THEN 
         WRITE(IPRT,'('' NON-RELAXED CART. GRADIENT COMPONENT'', 
     .I3,'' : '',F10.4,'' KCAL/MOLE'')')NUMBER,GRAD 
         CALL SECOND (TFLY) 
         WRITE(IPRT,'('' ELAPSED TIME IN DERI1'',F10.4,'' SECOND'')') 
     .              TFLY-TIME1 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DHCORE (COORD,H,W,ENUCLR,NATI,NATX,STEP) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION COORD(3,*),H(*),W(*) 
C 
C  DHCORE GENERATES THE 1-ELECTRON  AND 2-ELECTRON INTEGRALS DERIVATIVES 
C         WITH RESPECT TO THE CARTESIAN COORDINATE COORD (NATX,NATI). 
C 
C  INPUT 
C      COORD     : CARTESIAN  COORDINATES OF THE MOLECULE. 
C      NATI,NATX : INDICES OF THE MOVING COORDINATE. 
C      STEP      : STEP SIZE OF THE 2-POINTS FINITE DIFFERENCE. 
C  OUTPUT 
C      H         : 1-ELECTRON INTEGRALS DERIVATIVES (PACKED CANONICAL). 
C      W         : 2-ELECTRON INTEGRALS DERIVATIVES (ORDERED AS REQUIRED 
C                             IN DFOCK2 AND DIJKL1). 
C      ENUCLR    : NUCLEAR ENERGY DERIVATIVE. 
C 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
     3       /MOLORB/ USPD(MAXORB),DUMY(MAXORB) 
     4       /KEYWRD/ KEYWRD 
     5       /WMATRX/ WDUMMY(N2ELEC*3),KR,NBAND(NUMATM) 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST,MINDO 
      DIMENSION E1B(10),DE1B(10),E2A(10),DE2A(10) 
     .         ,DI(9,9),DDI(9,9),WJD(100),DWJD(100) 
      DATA FIRST/.TRUE./ 
       SAVE
      IF (FIRST) THEN 
         IONE=1 
         CUTOFF=1.D10 
         FIRST=.FALSE. 
         MINDO=INDEX(KEYWRD,'MINDO') .NE. 0 
      ENDIF 
      DO 10 I=1,(NORBS*(NORBS+1))/2 
   10 H(I)=0.0D0 
      ENUCLR=0.D0 
      KR=1 
      NROW=0 
      I=NATI 
      SAVE=COORD(NATX,I) 
      IA=NFIRST(I) 
      IB=NLAST(I) 
      IC=NMIDLE(I) 
      NI=NAT(I) 
      NROW=-NBAND(I) 
      DO 20 J=1,NUMAT 
   20 NROW=NROW+NBAND(J) 
      NCOL=NBAND(I) 
      NBAND2=0 
      DO 110 J=1,NUMAT 
      IF (J.EQ.I) GO TO 110 
      JA=NFIRST(J) 
      JB=NLAST(J) 
      JC=NMIDLE(J) 
      NJ=NAT(J) 
      COORD(NATX,I)=SAVE+STEP 
      CALL H1ELEC(NI,NJ,COORD(1,I),COORD(1,J),DI) 
      COORD(NATX,I)=SAVE-STEP 
      CALL H1ELEC(NI,NJ,COORD(1,I),COORD(1,J),DDI) 
C 
C     FILL THE ATOM-OTHER ATOM ONE-ELECTRON MATRIX. 
C 
      I2=0 
      IF (IA.GT.JA) THEN 
         DO 30 I1=IA,IB 
         IJ=I1*(I1-1)/2+JA-1 
         I2=I2+1 
         J2=0 
         DO 30 J1=JA,JB 
         IJ=IJ+1 
         J2=J2+1 
   30    H(IJ)=H(IJ)+(DI(I2,J2)-DDI(I2,J2)) 
      ELSE 
         DO 40 I1=JA,JB 
         IJ=I1*(I1-1)/2+IA-1 
         I2=I2+1 
         J2=0 
         DO 40 J1=IA,IB 
         IJ=IJ+1 
         J2=J2+1 
   40    H(IJ)=H(IJ)+(DI(J2,I2)-DDI(J2,I2)) 
      ENDIF 
C 
C     CALCULATE THE TWO-ELECTRON INTEGRALS, W; THE ELECTRON NUCLEAR TERM 
C     E1B AND E2A; AND THE NUCLEAR-NUCLEAR TERM ENUC. 
C 
      KRO=KR 
      NBAND1=NBAND2+1 
      NBAND2=NBAND2+NBAND(J) 
      IF (MINDO) THEN 
         COORD(NATX,I)=SAVE+STEP 
         CALL ROTATE (NI,NJ,COORD(1,I),COORD(1,J) 
     .               ,WJD,KR,E1B,E2A,ENUC,CUTOFF) 
         KR=KRO 
         COORD(NATX,I)=SAVE-STEP 
         CALL ROTATE (NI,NJ,COORD(1,I),COORD(1,J) 
     .               ,DWJD,KR,DE1B,DE2A,DENUC,CUTOFF) 
         IF (KR.GT.KRO) THEN 
            DO 50 K=1,KR-KRO+1
   50       W(KRO+K-1)=WJD(K)-DWJD(K) 
         ENDIF 
      ELSE 
         COORD(NATX,I)=SAVE+STEP 
         CALL ROTATE (NI,NJ,COORD(1,I),COORD(1,J) 
     .               ,WJD,KR,E1B,E2A,ENUC,CUTOFF) 
         KR=KRO 
         COORD(NATX,I)=SAVE-STEP 
         CALL ROTATE (NI,NJ,COORD(1,I),COORD(1,J) 
     .               ,DWJD,KR,DE1B,DE2A,DENUC,CUTOFF) 
         IF (KR.GT.KRO) THEN 
            DO 60 K=1,KR-KRO 
   60       WJD(K)=WJD(K)-DWJD(K) 
C#       write(6,'(''  e1b, de1b'',2f10.4)')e1b(1),de1b(1)
C#       write(6,'('' after wjd difference, k='',i4)')K
            CALL WCANON (WJD,W,NROW,NCOL,NBAND1,NBAND2) 
         ENDIF 
      ENDIF 
      COORD(NATX,I)=SAVE 
      ENUCLR = ENUCLR + ENUC-DENUC 
C 
C   ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM I. 
C 
      I2=0 
      DO 70 I1=IA,IC 
      II=I1*(I1-1)/2+IA-1 
      DO 70 J1=IA,I1 
      II=II+1 
      I2=I2+1 
   70 H(II)=H(II)+E1B(I2)-DE1B(I2) 
C     CONTRIB D, CNDO. 
      DO 80 I1=IC+1,IB 
      II=(I1*(I1+1))/2 
   80 H(II)=H(II)+E1B(1)-DE1B(1) 
C 
C   ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM J. 
C 
      I2=0 
      DO 90 I1=JA,JC 
      II=I1*(I1-1)/2+JA-1 
      DO 90 J1=JA,I1 
      II=II+1 
      I2=I2+1 
   90 H(II)=H(II)+E2A(I2)-DE2A(I2) 
C     CONTRIB D, CNDO. 
      DO 100 I1=JC+1,JB 
      II=(I1*(I1+1))/2 
  100 H(II)=H(II)+E2A(1)-DE2A(1) 
  110 CONTINUE 
      RETURN 
      END 
      SUBROUTINE DFOCK2 (F,PTOT,P,W,NUMAT,NFIRST,NMIDLE,NLAST,NATI) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     DFOCK2 ADDS THE 2-ELECTRON 2-CENTER REPULSION CONTRIB. TO THE FOCK 
C     MATRIX DERIVATIVE WITHIN * MNDO * OR * MINDO * FORMALISMS. 
C  INPUT 
C     F    : 1-ELECTRON CONTRIBUTIONS DERIVATIVES. 
C     PTOT : TOTAL DENSITY MATRIX. 
C     P    : ALPHA OR BETA DENSITY MATRIX. = 0.5 * PTOT 
C     W    : NON VANISHING TWO-ELECTRON INTEGRAL DERIVATIVES 
C            (ORDERED AS DEFINED IN DHCORE). 
C     NATI : # OF THE ATOM SUPPORTING THE VARYING CARTESIAN COORDINATE. 
C  OUPUT 
C     F    : FOCK MATRIX DERIVATIVE WITH RESPECT TO THE CART. COORD. 
C 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION F(*),PTOT(*),NFIRST(*),NMIDLE(*),NLAST(*),P(*),W(*) 
      DIMENSION IFACT(MAXORB),I1FACT(MAXORB) 
      CHARACTER*80 KEYWRD 
      LOGICAL SWAP,IEQJ 
      DATA ITYPE /1/ 
       SAVE
   10 GOTO (20,80,40) ITYPE 
C 
C     INITIALISATION (DONE ONLY ONCE) 
C 
C     SET UP ARRAY OF (I*(I-1))/2 AND (I*(I+1))/2 
   20 DO 30 I=1,NLAST(NUMAT) 
      IFACT(I)=(I*(I-1))/2 
   30 I1FACT(I)=IFACT(I)+I 
      IONE=1 
      IF(INDEX(KEYWRD,'MINDO') .NE. 0) THEN 
         ITYPE=2 
      ELSE 
         ITYPE=3 
      ENDIF 
      GOTO 10 
C 
C     * MNDO * OR * AM1 * 
C       ----        --- 
C 
   40 KK=0 
      II=NATI 
      IA=NFIRST(II) 
      IC=NLAST(II) 
         DO 70 I=IA,IC 
            KA=IFACT(I) 
            DO 70 J=IA,I 
            KB=IFACT(J) 
            IJ=KA+J 
            IEQJ=I.EQ.J 
            PTOIJ2=2.D0*PTOT(IJ) 
            DO 70 JJ=1,NUMAT 
               IF (II.EQ.JJ) GO TO 70 
               SWAP=JJ.GT.II 
               JA=NFIRST(JJ) 
               JC=NLAST(JJ) 
               FIJ=0.D0 
               DO 60 K=JA,JC 
                  KC=IFACT(K) 
                  IF (SWAP) THEN 
                     IK=KC+I 
                     JK=KC+J 
                  ELSE 
                     IK=KA+K 
                     JK=KB+K 
                  ENDIF 
                  DO 50 L=JA,K-1 
                     IF (SWAP) THEN 
                        KD=IFACT(L) 
                        IL=KD+I 
                        JL=KD+J 
                     ELSE 
                        IL=KA+L 
                        JL=KB+L 
                     ENDIF 
                     KL=KC+L 
                     KK=KK+1 
                     A=W(KK) 
C THIS FORMS THE TWO-ELECTRON TWO-CENTER REPULSION PART OF THE FOCK 
C MATRIX DERIVATIVE FOR MOLECULE. 
                     FIJ=FIJ+A*PTOT(KL) 
                     F(KL)=F(KL)+A*PTOIJ2 
                     F(IK)=F(IK)-A*P(JL) 
                     F(IL)=F(IL)-A*P(JK) 
                     F(JK)=F(JK)-A*P(IL) 
                     F(JL)=F(JL)-A*P(IK) 
   50             CONTINUE 
                  KK=KK+1 
                  A=W(KK) 
                  KL=KC+L 
                  FIJ=FIJ+A*PTOT(KL) 
                  A=A+A 
                  F(KL)=F(KL)+A*PTOIJ2 
                  F(IK)=F(IK)-A*P(JK) 
                  F(JK)=F(JK)-A*P(IK) 
   60          CONTINUE 
               IF (IEQJ) THEN 
                  F(IJ)=F(IJ)+4.D0*FIJ 
               ELSE 
                  F(IJ)=F(IJ)+2.D0*FIJ 
               ENDIF 
   70 CONTINUE 
C 
      RETURN 
C 
C     * MINDO * 
C       ----- 
C 
   80 KR=0 
      II=NATI 
      IA=NFIRST(II) 
      IB=NLAST(II) 
      DO 100 JJ=1,NUMAT 
         IF (JJ.EQ.II) GO TO 100 
         KR=KR+1 
         ELREP=4.D0*W(KR) 
         JA=NFIRST(JJ) 
         JB=NLAST(JJ) 
         DO 90 I=IA,IB 
            KA=IFACT(I) 
            KK=KA+I 
            DO 90 K=JA,JB 
               LL=I1FACT(K) 
               IF (JA.LT.IA) THEN 
                  IK=KA+K 
               ELSE 
                  IK=LL+I 
               ENDIF 
               F(KK)=F(KK)+PTOT(LL)*ELREP 
               F(LL)=F(LL)+PTOT(KK)*ELREP 
   90    F(IK)=F(IK)-P(IK)*ELREP 
  100 CONTINUE 
      RETURN 
      END 
      SUBROUTINE DERI2 (C,CT,E,N,MINEAR,THROLD,F,FD,FCI,NINEAR,NVAR 
     .                 ,MAXITE,WORK,B,NBSIZE,GRAD,FAIL,AB,FB,MAXFB) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C******************************************************************** 
C 
C     DERI2 COMPUTE THE RELAXATION PART OF THE DERIVATIVES OF THE 
C     (1/2 ELECTRON OR CI)-ENERGY WITH RESPECT TO NVAR OPTIMIZED 
C     COORDINATES AT A TIME. THIS IS DONE IN THREE STEPS. 
C 
C==>  THE M.O DERIVATIVES ARE SOLUTION {X} OF A LINEAR SYSTEM 
C                        (D-A) * X = F 
C     WHERE D IS A DIAGONAL SUPER-MATRIX OF FOCK'EIGENVALUE DIFFERENCES 
C     AND A IS A SUPER-MATRIX OF 2-ELECTRONS INTEGRALS IN M.O BASIS. 
C==>  SUCH A SYSTEM IS TOO LARGE TO BE INVERTED DIRECTLY THUS ONE MUST 
C     USES A RELAXATION METHOD TO GET A REASONABLE ESTIMATE OF {X}. 
C==>  THIS REQUIRES A BASIS SET {B} TO BE GENERATED ITERATIVELY. THEN 
C     ONE SOLVES BY DIRECT INVERSION THE LINEAR SYSTEM PROJECTED IN THIS 
C     BASIS {B}. IT WORKS QUICKLY BUT REQUIRE A LARGE CORE MEMORY. 
C==>  USE A FORMALISM WITH FOCK OPERATOR THUS AVOIDING THE EXPLICIT 
C     COMPUTATION (AND STORAGE) OF THE SUPER-MATRIX A. 
C==>  NDDO METHOD DONT NEED LARGE C.I CALCULATION. THEREFORE FOR EACH 
C     GRADIENT COMPONENT ONE BUILDS THE C.I MATRIX DERIVATIVE FROM THE 
C     <IJ!KL> AND FOCK EIGENVALUES DERIVATIVES, THUS PROVIDING THE 
C     RELAXATION CONTRIBUTION TO THE GRADIENT WITHOUT COMPUTATION AND 
C     STORAGE OF THE 2ND ORDER DENSITY MATRIX. 
C 
C   STEP 1) 
C     USE THE PREVIOUS B AND THE NEW F VECTORS TO BUILD AN INITIAL 
C     BASIS SET B. 
C   STEP 2) 
C     OWING THAT THE ELECTRONIC HESSIAN (D-A) IS THE SAME FOR EACH 
C     DERIVATIVE, ENLARGE ITERATIVELY THE ORTHONORMAL BASIS SET {B} 
C     USED TO INVERT THE PROJECTED HESSIAN. 
C     ( DRIVED BY THE LARGEST RESIDUAL VECTOR ). 
C     THIS SECTION IS CARRIED OUT IN THE DIAGONAL METRIC 'SCALAR'. 
C   STEP 3) ... LOOP ON THE GEOMETRIC VARIABLE : 
C 3.1 FOR EACH GEOMETRIC VARIABLE , GET THE M.O DERIVATIVES IN A.O. 
C 3.2 COMPUTE THE FOCK EIGENVALUES AND 2-ELECT INTEGRALS RELAXATION. 
C 3.3 BUILD THE ELECTRONIC RELAXATION CONTRIBUTION TO THE C.I MATRIX 
C     AND GET THE ASSOCIATED EIGENSTATE DERIVATIVE WITH RESPECT TO 
C     THE GEOMETRIC VARIABLE. 
C 
C   INPUT 
C     C(N,N) : M.O. COEFFICIENTS, IN COLUMN. 
C     CT     : IDEM, TRANSPOSED, ORDERED CLOSED,OPEN,VIRTUAL. 
C     E(N)   : EIGENVALUES OF THE FOCK MATRIX. 
C     MINEAR : NUMBER OF NON REDUNDANT ROTATION OF THE M.O. 
C     THROLD : THRESHOLD OF CONVERGENCE (LARGEST ALLOWED RESIDUE). 
C     F(MINEAR,NVAR)   : NON-RELAXED FOCK MATRICES DERIVATIVES 
C                        IN M.O BASIS, OFF-DIAGONAL BLOCKS. 
C     FD(NINEAR,NVAR)  : IDEM, DIAGONAL BLOCKS, C.I-ACTIVE ONLY. 
C     MAXITE           : MAXIMUM SIZE OF THE BASIS {B}. 
C     WORK             : WORK ARRAY OF SIZE N*N. 
C     B(MINEAR,NBSIZE) : INITIAL ORTHONORMALIZED BASIS SET {B}. 
C     GRAD(NVAR)  : GRADIENT VECTOR BEFORE RELAXATION CORRECTION. 
C     FAIL        : LOGICAL, NOT DEFINED. 
C     AB(MINEAR,MAXITE): STORAGE FOR THE (D-A) * B VECTORS. 
C     FB(NVAR,MAXITE)  : STORAGE FOR THE MATRIX PRODUCT F' * B. 
C   OUTPUT 
C     GRAD   : DERIVATIVE OF THE HEAT OF FORMATION WITH RESPECT TO 
C              THE NVAR OPTIMIZED VARIABLES. 
C     FAIL   : .FALSE. IF RELAXATION CONVERGED, 
C              .TRUE.  OTHERWISE. IN SUCH A CASE, THE REQUIRED DATA 
C                      TO RESTART WITH A SMALLER VALUE OF NVAR 
C                      ARE AVAILABLE IN /SCRAH2/. 
C 
C*********************************************************************** 
      COMMON /SCRACH/ BABINV(3600),BCOEF(MPACK*2-3600) 
     1       /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT,NBO(3) 
     2       /SCRAH2/ DIJKL(NRELAX*MORB2) 
     3       /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
     4       /CIDATA/ VECTCI(NMECI**2),XXCI,NCI1,NCI2,NCI3 
     5       /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NBAND(NUMATM+1) 
     6       /OPTIM / IMP,IMP0,LEC,IPRT 
     7       /KEYWRD/ KEYWRD 
C     NOTE.../SCRACH/ IS ALSO USED AS A TEMPORARY WORK ARRAY IN ROUTINES 
C                     DERI21 , DERI22  , HQRII , DIAGIV 
C                     THE LENGTH AGREES WITH 'DERI1' FOR COHERENCY. 
      DIMENSION BAB(60,60),LCONV(60) 
     1         ,C(N,N),CT(*),E(N),WORK(N,N),F(MINEAR,*),FD(NINEAR,*) 
     2         ,FCI(NINEAR,*),B(MINEAR,*),AB(MINEAR,*),FB(NVAR,*),W(1) 
     3         ,GRAD(NVAR) 
      LOGICAL FAIL,LCONV,DEBUG,LBAB 
      CHARACTER KEYWRD*80 
      EQUIVALENCE (W,WJ) 
       SAVE
C 
C     * * * STEP 1 * * * 
C     BUILD UP THE INITIAL ORTHONORMALIZED BASIS. 
C     ------------------------------------------- 
C 
C     READ KEYWORDS, INITIALIZE AND CHECK SIZE OF BLOCKS 
      FAIL=.FALSE. 
      DEBUG=INDEX(KEYWRD,' DERI2').NE.0 
      LINEAR=N*(N+1)/2 
      NOPEN =NBO(1)+NBO(2) 
      MAXITE=MIN(MAXITE,60,(MPACK*2-3600)/NVAR,MAXFB/NVAR) 
      CUTOFF=0.85D0 
      NFIST=MIN(NVAR,1+MAXITE/4) 
      CALL SECOND (TIME1) 
      NBSZE=NBSIZE 
      IF(NBSZE.NE.0) THEN 
C 
C        RESTART CASE. USE BOTH OLD B AND F. 
C 
C        NORM OF F. 
         RNORM=1.D0/SDOT(MINEAR*NVAR,F,1,F,1) 
C        SCALED SQUARE OVERLAP OF F ONTO B, STORED IN BCOEF. 
         SUM=0.D0 
         DO 10 I=1,NBSZE 
         LCONV(I)=.FALSE. 
         BCOEF(I)=SDOT(NVAR,FB(1,I),1,FB(1,I),1)*RNORM 
   10    SUM=SUM+BCOEF(I) 
C        SELECT THE BEST SUBSET OF B OVERLAPPING WITH F. 
         SUM2=0.D0 
         SUM=SUM*0.8D0 
   20    TEST=0.D0 
         DO 30 J=1,NBSZE 
         IF(.NOT.LCONV(J).AND.BCOEF(J).GT.TEST) THEN 
            TEST=BCOEF(J) 
            K=J 
         ENDIF 
   30    CONTINUE 
         SUM2=SUM2+TEST 
         LCONV(K)=.TRUE. 
         IF(SUM2.LT.SUM) GO TO 20 
         NBSIZE=0 
         DO 50 J=1,NBSZE 
         IF(LCONV(J)) THEN 
            NBSIZE=NBSIZE+1 
            IF(NBSIZE.LT.J) THEN 
               CALL SCOPY(MINEAR,B(1,J),1,B(1,NBSIZE),1) 
C              UPDATE ALSO THE ROW OF BAB AND THE FB MATRIX. 
               DO 40 I=1,NBSZE 
   40          BAB(NBSIZE,I)=BAB(J,I) 
               CALL SCOPY(NVAR,FB(1,J),1,FB(1,NBSIZE),1) 
            ENDIF 
         ENDIF 
   50    CONTINUE 
C        NOW TO COMPLETE THE BASIS FROM THE ORTHOGONAL SUBSET OF F. 
C        ORTHOGONALIZE {F} WITH {B #1}. STORE IN AB. 
         CALL MXMT(B,MINEAR,FB,NBSIZE,AB,NVAR) 
         DO 60 I=1,MINEAR*NVAR 
   60    AB(I,1)=F(I,1)-AB(I,1) 
C        EXTRACT OPTIMUM ORTHONORMALIZED SUBSET FROM AB, 
C        THUS PROVIDING A NEW SUBSET #2 TO THE INITIAL BASIS. 
         CALL DERI21 (AB,NVAR,MINEAR,CUTOFF,SUM2,NFIST,WORK 
     .               ,WORK(NVAR*NVAR+1,1),B(1,NBSIZE+1),NLAST) 
C        UPDATE SUBSET #1 OF AB AND BAB (WITH NO CALL TO DERI22). 
         K=0 
         DO 80 J=1,NBSZE 
         IF(LCONV(J)) THEN 
            K=K+1 
            CALL SCOPY (MINEAR,B(1,NBSZE+J),1,AB(1,K),1) 
            DO 70 I=1,NBSIZE 
   70       BAB(I,K)=BAB(I,J) 
         ENDIF 
   80    CONTINUE 
      ELSE 
C 
C        NORMAL CASE. USE F ONLY. 
C 
         SUM2=0.D0 
         CALL DERI21 (F,NVAR,MINEAR,CUTOFF,SUM2,NFIST,WORK 
     .               ,WORK(NVAR*NVAR+1,1),B,NLAST) 
         NBSIZE=0 
      ENDIF 
      LBAB=.FALSE. 
      NFIST=NBSIZE+1 
      NLAST=NBSIZE+NLAST 
      DO 90 I=1,NVAR 
   90 LCONV(I)=.FALSE. 
C 
C     * * * STEP 2 * * * 
C     RELAXATION METHOD WITH OPTIMUM INCREASE OF THE BASIS SET. 
C     --------------------------------------------------------- 
C 
C     UPDATE AB ,FCI AND BAB. (BAB IS SYMMETRIC) 
  100 DO 110 J=NFIST,NLAST 
      CALL DERI22 (C,CT,B(1,J),WORK,N,WORK,AB(1,J),MINEAR,FCI(1,J) 
     .            ,NCI1,NCI2) 
      CALL MXM(AB(1,J),1,B,MINEAR,BAB(1,J),NLAST) 
CDIR$ IVDEP 
      DO 110 I=1,NFIST-1 
  110 BAB(J,I)=BAB(I,J) 
C     INVERT BAB, STORE IN BABINV. 
  115 L=0 
      DO 120 J=1,NLAST 
      DO 120 I=1,NLAST 
      L=L+1 
  120 BABINV(L)=BAB(I,J) 
      CALL OSINV (BABINV,NLAST,DETER) 
      IF (DETER.EQ.0) THEN 
         WRITE(IPRT,'('' THE BAB MATRIX OF ORDER'',I3, 
     .   '' IS SINGULAR IN DERI2''/ 
     .   '' THE RELAXATION IS STOPPED AT THIS POINT.'')')NLAST 
         LBAB=.TRUE. 
         NLAST=NLAST-1 
         GO TO 115 
      ENDIF 
      IF (.NOT.LBAB) THEN 
C        UPDATE F * B' 
         CALL MTXM (F,NVAR,B(1,NFIST),MINEAR,FB(1,NFIST),NLAST-NFIST+1) 
      ENDIF 
C     NEW SOLUTIONS IN BASIS B , STORED IN BCOEF(NVAR,*). 
C     BCOEF = BABINV * FB' 
      CALL MXMT (BABINV,NLAST,FB,NLAST,BCOEF,NVAR) 
      IF(LBAB) GO TO 200 
C 
C     SELECT THE NEXT BASIS VECTOR AS THE LARGEST RESIDUAL VECTOR. 
C     AND TEST FOR CONVERGENCE ON THE LARGEST RESIDUE. 
      NRES=0 
      TEST2=0.D0 
      DO 140 IVAR=1,NVAR 
      IF(LCONV(IVAR)) GO TO 140 
C     GET ONE NOT-CONVERGED RESIDUAL VECTOR (# IVAR), 
C     STORED IN WORK. 
      CALL MXM  (AB,MINEAR,BCOEF(NLAST*(IVAR-1)+1),NLAST,WORK,1) 
      DO 130 I=1,MINEAR 
  130 WORK(I,1)=F(I,IVAR)-WORK(I,1) 
      TEST=ABS(WORK(ISMAX(MINEAR,WORK,1),1)) 
      TEST2=MAX(TEST2,TEST) 
      IF (TEST.LE.THROLD) THEN 
         LCONV(IVAR)=.TRUE. 
         GO TO 140 
      ELSE IF (NLAST+NRES.EQ.MAXITE) THEN 
C        NO MORE STORAGE... 
         FAIL=NRES.EQ.0 
         GO TO 150 
      ELSE 
C        STORE THE FOLLOWING RESIDUE IN AB(CONTINUED). 
         NRES=NRES+1 
         CALL SCOPY (MINEAR,WORK,1,AB(1,NLAST+NRES),1) 
      ENDIF 
  140 CONTINUE 
  150 IF (NRES.EQ.0) GO TO 200 
C     FIND OPTIMUM FOLLOWING SUBSET, ADD TO B AND LOOP. 
      SUM2=0.D0 
      NFIST=NLAST+1 
      CALL DERI21(AB(1,NFIST),NRES,MINEAR,CUTOFF,SUM2,NRES,WORK 
     .           ,WORK(NRES*NRES+1,1),B(1,NFIST),NADD) 
      NLAST=NLAST+NADD 
      GO TO 100 
C 
C     CONVERGENCE ACHIEVED OR HALTED. 
C     ------------------------------- 
C 
  200 NBSZE=NBSIZE 
      IF(DEBUG.OR.LBAB) THEN 
         WRITE(IPRT,'('' RELAXATION ENDED IN DERI2 AFTER'',I3, 
     .   '' CYCLES''/'' REQUIRED CONVERGENCE THRESHOLD ON RESIDUALS ='' 
     .   ,F12.9/'' HIGHEST RESIDUAL ON'',I3,'' GRADIENT COMPONENTS = '' 
     .   ,F12.9)')NLAST-NBSZE,THROLD,NVAR,TEST2 
         CALL SECOND (TIME2) 
         WRITE(IPRT,'('' ELAPSED TIME IN RELAXATION'',F15.3,'' SECOND'') 
     .              ')TIME2-TIME1 
      ENDIF 
      IF(FAIL) THEN 
C        KEEP MOST OF DATA FOR FURTHER REUSE,AB IS STORED IN END OF B. 
         NBSIZE=NLAST/2 
         CALL SCOPY (NBSIZE*MINEAR,AB,1,B(1,NBSIZE+1),1) 
         RETURN 
      ELSE 
         NBSIZE=0 
C        UNSCALED SOLUTION SUPERVECTORS, STORED IN F. 
         CALL MXM (B,MINEAR,BCOEF,NLAST,F,NVAR) 
         DO 210 J=1,NVAR 
         DO 210 I=1,MINEAR 
  210    F(I,J)=F(I,J)*SCALAR(I) 
C        FOCK MATRIX DIAGONAL BLOCKS OVER C.I-ACTIVE M.O. 
C        STORED IN FB. 
         CALL MXM (FCI,NINEAR,BCOEF,NLAST,FB,NVAR) 
      ENDIF 
C 
C     * * * STEP 3 * * * 
C     FINAL LOOP (390) ON THE GEOMETRIC VARIABLES. 
C     -------------------------------------------- 
C 
      DO 390 IVAR=1,NVAR 
C 
C     C.I-ACTIVE M.O DERIVATIVES INTO THE M.O BASIS, 
C         RETURNED IN AB (N,NCI1+1,...,NCI1+NCI2). 
C     C.I-ACTIVE EIGENVALUES DERIVATIVES, 
C         RETURNED IN BCOEF(NCI1+1,...,NCI1+NCI2). 
      CALL DERI23 (F(1,IVAR),MINEAR,FD(1,IVAR),NINEAR,E 
     .            ,FB(NINEAR*(IVAR-1)+1,1),AB,BCOEF,N,NCI1,NCI2) 
C 
C     DERIVATIVES OF THE 2-ELECTRONS INTEGRALS OVER C.I-ACTIVE M.O. 
C     STORED IN /XYIJKL/. 
      CALL DIJKL2 (AB(N*NCI1+1,1),N,NCI2,DIJKL,XY,NMECI) 
      IF(DEBUG.AND.INDEX(KEYWRD,'DEBU').NE.0) THEN 
         WRITE(IPRT,'('' * * * CART. GRADIENT COMPONENT'',I4)')IVAR 
         WRITE(IPRT,'('' C.I-ACTIVE M.O. DERIVATIVES IN M.O BASIS'', 
     .                '', IN ROW.'')') 
         L=N*NCI1+1 
         DO 320 I=NCI1+1,NCI1+NCI2 
         WRITE(IPRT,'(8F10.4)')(AB(K,1),K=L,L+N-1) 
 320     L=L+N 
         WRITE(IPRT,'('' C.I-ACTIVE FOCK EIGENVALUES RELAXATION (E.V.)'' 
     .               )') 
         WRITE(IPRT,'(8F10.4)')(BCOEF(I),I=NCI1+1,NCI1+NCI2) 
         WRITE(IPRT,'('' 2-ELECTRON INTEGRALS RELAXATION (E.V.)''/ 
     .''  I    J    K    L       d<I(1)J(1)!K(2)L(2)> RELAXATION ONLY'') 
     .') 
         DO 330 I=1,NCI2 
         DO 330 J=1,I 
         DO 330 K=1,I 
         LL=K 
         IF(K.EQ.I) LL=J 
         DO 330 L=1,LL 
 330     WRITE(IPRT,'(4I5,F20.10)') 
     .              NCI1+I,NCI1+J,NCI1+K,NCI1+L,XY(I,J,K,L) 
      ENDIF 
C 
C     BUILD THE C.I MATRIX DERIVATIVE, STORED IN AB. 
      CALL MECID (BCOEF,GSE,WORK(NCI3+1,1),WORK) 
      CALL MECIH (WORK,AB) 
C     RELAXATION CORRECTION TO THE C.I ENERGY DERIVATIVE. 
      CALL SUPDOT (WORK,AB,VECTCI,NCI3,1) 
      GRAD(IVAR)=GRAD(IVAR)+SDOT(NCI3,VECTCI,1,WORK,1)*23.061D0 
      IF (DEBUG) WRITE(IPRT,'('' RELAXATION OF CART. GRAD. COMPONENT'', 
     .I3,'' : '',F10.4,'' KCAL/MOLE'')') 
     .IVAR,SDOT(NCI3,VECTCI,1,WORK,1)*23.061D0 
C 
C     THE END . 
  390 CONTINUE 
      IF(DEBUG) THEN 
        CALL SECOND(TFLY) 
        WRITE(IPRT,'('' ELAPSED TIME IN C.I-ENERGY RELAXATION'',F15.3, 
     .                '' SECOND'')')TFLY-TIME2 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DERI21 (A,NT,MINEAR,CUTOFF,SUM2,MAXITE,VNERT,PNERT 
     .                  ,B,NCUT) 
      IMPLICIT REAL(A-H,O-Z) 
C 
C     LEAST-SQUARE ANALYSIS OF A SET OF NT POINTS {A} : 
C 
C     PRODUCE A SUBSET OF NCUT ORTHONORMALIZED VECTORS B, OPTIMUM IN A 
C     LEAST-SQUARE SENSE WITH RESPECT TO THE INITIAL SPACE {A}. 
C     EACH NEW HIERARCHIZED VECTOR B EXTRACTS A MAXIMUM PERCENTAGE FROM 
C     THE REMAINING DISPERSION OF THE SET {A} OUT OF THE PREVIOUS 
C     {B} SUBSPACE. 
C   INPUT 
C     A(MINEAR,NT)  : ORIGINAL SET {A}. 
C     CUTOFF        : LEAST-SQUARE CUTOFF TO BE APPLIED. 
C     SUM2          : INITIAL VALUE OF THE PERCENTAGE OF EXTRACTION. 
C     MAXITE        : MAXIMUM ALLOWED SIZE OF THE BASIS B. 
C   OUTPUT 
C     SUM2          : FINAL VALUE OF THE PERCENTAGE OF EXTRACTION. 
C     VNERT(NT,NT)  : EIGENVECTORS OF A'* A. 
C     PNERT(NT)     : SQUARE ROOT OF THE ASSOCIATED EIGENVALUES 
C                     IN DECREASING ORDER. 
C     B(MINEAR,NCUT): OPTIMUM ORTHONORMALIZED SUBSET {B}. 
C 
      COMMON /SCRACH/ WORK(1) 
      DIMENSION A(MINEAR,NT),VNERT(NT,NT),PNERT(NT),B(MINEAR,*) 
       SAVE
C 
C     VNERT = A' * A 
      DO 10 J=1,NT 
      L=J 
      DO 10 I=1,MINEAR 
      B(L,1)=-A(I,J) 
   10 L=L+NT 
      CALL MXM (B,NT,A,MINEAR,VNERT,NT) 
C     DIAGONALIZE IN DECREASING ORDER OF EIGENVALUES 
      CALL DIAGIV (VNERT,NT,NT,PNERT,EPS1) 
C     FIND NCUT ACCORDING TO CUTOFF, BUILD WORK = VNERT * (PNERT)**-0.5 
      SUM=0.D0 
      DO 20 I=1,NT 
   20 SUM=SUM-PNERT(I) 
      L=1 
      DO 40 I=1,MAXITE 
      SUM2=SUM2-PNERT(I)/SUM 
      PNERT(I)=SQRT(-PNERT(I)) 
      DO 30 J=1,NT 
      WORK(L)=VNERT(L,1)/PNERT(I) 
   30 L=L+1 
      IF(SUM2.GE.CUTOFF) THEN 
         NCUT=I 
         GO TO 50 
      ENDIF 
   40 CONTINUE 
      NCUT=MAXITE 
C     ORTHONORMALIZED BASIS B(MINEAR,NCUT) = A(MINEAR,NT)*WORK(NT,NCUT) 
   50 CALL MXM (A,MINEAR,WORK,NT,B,NCUT) 
      RETURN 
      END 
      SUBROUTINE DERI22 (C,CT,B,WORK,N,FOC2,AB,MINEAR,FCI,NCI1,NCI2) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C 
C  1) BUILD THE 2-ELECTRON FOCK MATRIX DEPENDING ON B AS FOLLOWS : 
C     DP = C * SCALE*B * C' ...  DP DENSITY MATRIX 'DERIVATIVE', 
C     FOC2 = 0.5 * TRACE ( DP * (2<J>-<K>) ) DONE IN FOCK2 & FOCK1. 
C  2) HALF-TRANSFORM ONTO M.O. BASIS : DP =  FOC2 * C 
C     AND COMPUTE DIAGONAL BLOCKS ELEMENTS OF C' * FOC2, EXTRACTING 
C     IN FCI ELEMENTS OVER C.I-ACTIVE M.O ONLY. 
C  3) COMPUTE SUPERVECTOR AB = (DIAG + A) * B DEFINED BY THE MATRIX : 
C     AB(I,J)= ( DIAG(I,J)*B(I,J)+DP(I,J) )*SCALAR(I,J)  WITH I.GT.J, 
C     DIAG(I,J)=(EIGS(I)-EIGS(J))/(O(J)-O(I)) >0, O OCCUPANCY NUMBERS, 
C     EIGS EIGENVALUES OF FOCK OPERATOR WITH EIGENVECTORS C IN A.O. 
C 
C   INPUT 
C     C(N,N)   : M.O. EIGENVECTORS (COLUMNWISE). 
C     CT       : IDEM, TRANSPOSED, ORDERED CLOSED,OPEN,VIRTUAL. 
C     B(*)     : B SUPERVECTOR PACKED BY OFF-DIAGONAL BLOCKS, SCALED. 
C     WORK(*)  : WORK AREA OF SIZE N*N. 
C     N        : NUMBER OF M.O. 
C     NCI1,NCI2: LAST FROZEN CORE M.O. , C.I-ACTIVE BAND LENGTH. 
C   IN COMMON 
C     DIAG,SCALAR AS DEFINED IN 'DERI0'. 
C   OUTPUT 
C     FOC2(*)  : 2-ELECTRON FOCK MATRIX, PACKED CANONICAL. 
C     AB(*)    : ANTISYMMETRIC MATRIX PACKED IN SUPERVECTOR FORM WITH 
C                THE CONSECUTIVE FOLLOWING BLOCKS: 
C             1) OPEN-CLOSED  I.E. B(IJ)=B(I,J) WITH I OPEN & J CLOSED 
C                                  AND I RUNNING FASTER THAN J, 
C             2) VIRTUAL-CLOSED SAME RULE OF ORDERING, 
C             3) VIRTUAL-OPEN   SAME RULE OF ORDERING. 
C     FCI(*)   : FOCK DIAGONAL BLOCKS ELEMENTS OVER C.I-ACTIVE M.O. 
C                ORDERED AS DEFINED IN 'DERI1'. 
C     FOC2 CAN BE EQUIVALENCED WITH WORK IN THE CALLING SEQUENCE. 
C 
C     CRAY VERSION WITH EXTENSIVE CALLS TO MXM INSTEAD OF MTXM ETC. 
C 
      DIMENSION C(N,N),CT(*),B(*),WORK(N,N),FOC2(*),AB(*),FCI(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA 
     2               ,NCLOSE,NOPEN,NDUMY,FRACT 
     3       /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NWDUM(NUMATM+1) 
     4       /SCRACH/ DP(MORB2) 
     5       /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT2,NBO(3) 
      DIMENSION W(1) 
      EQUIVALENCE (W(1),WJ(1)) 
       SAVE
C 
      N2=N*N 
      LINEAR=(N2+N)/2 
C 
C     DERIVATIVE OF THE DENSITY MATRIX IN DP (N,N). 
C     --------------------------------------------- 
C     DP = C * B * C' . 
C 
C     STEP 1 : WORK = B * C'   .  DP TEMPORARY ARRAY. 
C     STEP 1.1 UNPACK B (UNSCALED) INTO WORK. 
      L=0 
      IF(NBO(2).NE.0 .AND. NBO(1).NE.0) THEN 
C        OPEN-CLOSED 
         DO 20 J=1,NBO(1) 
CDIR$ IVDEP 
         DO 20 I=NBO(1)+1,NOPEN 
         L=L+1 
         WORK(J,I)=B(L)*SCALAR(L) 
   20    WORK(I,J)=B(L)*SCALAR(L) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(1).NE.0) THEN 
C        VIRTUAL-CLOSED 
         DO 30 J=1,NBO(1) 
CDIR$ IVDEP 
         DO 30 I=NOPEN+1,N 
         L=L+1 
         WORK(J,I)=B(L)*SCALAR(L) 
   30    WORK(I,J)=B(L)*SCALAR(L) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN 
C        VIRTUAL-OPEN 
         DO 40 J=NBO(1)+1,NOPEN 
CDIR$ IVDEP 
         DO 40 I=NOPEN+1,N 
         L=L+1 
         WORK(J,I)=B(L)*SCALAR(L) 
   40    WORK(I,J)=B(L)*SCALAR(L) 
      ENDIF 
C     FULFILL DIAGONAL BLOCKS WITH ZEROES. 
      NEND=0 
      DO 50 NLOOP=1,3 
      NINIT=NEND+1 
      NEND=NEND+NBO(NLOOP) 
      DO 50 I=NINIT,NEND 
      DO 50 J=NINIT,NEND 
   50 WORK(J,I)=0.D0 
C     STEP 1.2  DP = C * WORK 
      CALL MXM (C,N,WORK,N,DP,N) 
C     STEP 1.3  TRANSPOSE DP ONTO WORK 
      L=0 
      DO 60 J=1,N 
      DO 60 I=1,N 
      L=L+1 
   60 WORK(J,I)=DP(L) 
C 
C     STEP 2 : DP= C * WORK 
      CALL MXM (C,N,WORK,N,DP,N) 
C 
C     2-ELECTRON FOCK MATRIX BUILD WITH THE DENSITY MATRIX DERIVATIVE. 
C     ---------------------------------------------------------------- 
C     RETURNED IN FOC2 (N,N). 
      CALL FOCK (FOC2,DP,N) 
C 
C     BUILD DP = FOC2 * C  AND EXTRACT FCI = C' * DP. 
C     ----------------------------------------------- 
C 
C     DP(N,NEND) = FOC2(N,N) * C(N,NEND). 
      NEND=MAX(NOPEN,NCI1+NCI2) 
      CALL MXM (FOC2,N,C,N,DP,NEND) 
C     EXTRACT FCI 
      L=1 
      NEND=0 
      DO 90 LOOP=1,3 
      NINIT=NEND+1 
      NEND =NEND+NBO(LOOP) 
      N1=MAX(NINIT,NCI1+1   ) 
      N2=MIN(NEND ,NCI1+NCI2) 
      IF(N2.LT.N1) GO TO 90 
      DO 80 I=N1,N2 
      IF(I.GT.NINIT) THEN 
         CALL MXM (C(1,I),1,DP(N*(NINIT-1)+1),N,FCI(L),I-NINIT) 
         L=L+I-NINIT 
      ENDIF 
   80 CONTINUE 
   90 CONTINUE 
      NCOL=N2-NINIT+1 
      IF (NCOL.GT.0.AND.N2.LT.N) THEN 
         CALL MTXM (C(1,N2+1),N-N2,DP(N*(NINIT-1)+1),N,FCI(L),NCOL) 
         L=L+NCOL*(N-N2) 
      ENDIF 
      DO 100 I=NCI1+1,NCI1+NCI2 
      FCI(L)=-SDOT(N,C(1,I),1,DP(N*(I-1)+1),1) 
  100 L=L+1 
C 
C     NEW SUPERVECTOR AB = (DIAG + C'* FOC2 * C) * B , SCALED. 
C     -------------------------------------------------------- 
C 
C     PART 1 : AB(I,J) = (C' * DP)(I,J) DONE BY BLOCKS. 
      L=1 
      IF(NBO(2).NE.0 .AND. NBO(1).NE.0) THEN 
         CALL MXM (CT(NBO(1)*N+1),NBO(2),DP,N,AB(L),NBO(1)) 
         L=L+NBO(2)*NBO(1) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(1).NE.0) THEN 
         CALL MXM (CT(NOPEN*N+1),NBO(3),DP,N,AB(L),NBO(1)) 
         L=L+NBO(3)*NBO(1) 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN 
         CALL MXM (CT(NOPEN*N+1),NBO(3),DP(N*NBO(1)+1),N,AB(L),NBO(2)) 
      ENDIF 
C 
C     PART 2 : AB = SCALE * (D * B + AB) . 
      DO 110 I=1,MINEAR 
  110 AB(I)=(DIAG(I)*B(I)+AB(I))*SCALAR(I) 
      RETURN 
      END 
      SUBROUTINE DERI23 (F,MINEAR,FD,NINEAR,E,FCI,CMO,EMO,N,NCI1,NCI2) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C  1) UNPACK THE C.I-ACTIVE M.O. DERIVATIVES IN M.O. BASIS, 
C     DIAGONAL BLOCKS        INCLUDED. 
C  2) EXTRACT THE FOCK EIGENVALUES RELAXATION OVER C.I-ACTIVE M.O. 
C   INPUT 
C     F(MINEAR)   : UNSCALED SOLUTIONS VECTOR IN M.O. BASIS, 
C                   OFF-DIAGONAL BLOCKS PACKED AS DEFINED IN 'DERI21'. 
C     FD(NINEAR)  : DIAGONAL BLOCKS OF NON-RELAXED FOCK MATRIX 
C                   AS DEFINED IN 'DERI1'. 
C     E(N)        : FOCK EIGENVALUES. 
C     FCI(NINEAR) : DIAGONAL BLOCKS OF RELAXATION OF THE FOCK MATRIX, 
C                   ORDERED AS FD. 
C     N           : NUMBER OF M.O 
C     NCI1,NCI2   : # OF LAST FROZEN CORE M.O , C.I-ACTIVE BAND LENGTH. 
C   OUTPUT 
C     CMO(N,NCI1+1,...,NCI1+NCI2): C.I-ACTIVE M.O DERIVATIVES 
C                                  IN M.O BASIS. 
C     EMO(  NCI1+1,...,NCI1+NCI2): C.I-ACTIVE FOCK EIGENVALUE RELAXATION 
C 
      COMMON /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT,NBO(3) 
      DIMENSION F(*),FD(*),E(*),FCI(*),CMO(N,*),EMO(*) 
       SAVE
C 
      NOPEN  =NBO(1)+NBO(2) 
C 
C     PART 1. 
C     ------- 
C     COMPUTE AND UNPACK DIAGONAL BLOCKS, DIAGONAL TERMS        INCLUDED, 
C     ACCORDING TO CMO(I,J) = (FD(I,J)-FCI(I,J))/(E(I)-E(J)) 
C     AND TAKING   CMO(I,J)=0 IF E(I)=E(J) (THRESHOLD 1D-4 EV), 
C                             I.E WHEN M.O. DEGENERACY OCCURS. 
      L=1 
      NEND=0 
      DO 30 LOOP=1,3 
      NINIT=NEND+1 
      NEND =NEND+NBO(LOOP) 
      N1=MAX(NINIT,NCI1+1   ) 
      N2=MIN(NEND ,NCI1+NCI2) 
      IF(N2.LT.N1) GO TO 30 
      DO 20 I=N1,N2 
      IF(I.GT.NINIT) THEN 
         DO 10 J=NINIT,I-1 
         DIFFE=E(I)-E(J) 
         IF(ABS(DIFFE).GT.1.D-4) THEN 
            COM=(FD(L)-FCI(L))/DIFFE 
         ELSE 
            COM=0.D0 
         ENDIF 
         CMO(I,J)=-COM 
         CMO(J,I)= COM 
   10    L=L+1 
      ENDIF 
   20 CMO(I,I)= 0.D0 
   30 CONTINUE 
      NCOL=N2-NINIT+1 
      IF (NCOL.GT.0.AND.N2.LT.N) THEN 
         DO 40 J=NINIT,N2 
         DO 40 I=N2+1,N 
         DIFFE=E(I)-E(J) 
         IF(ABS(DIFFE).GT.1.D-4) THEN 
            COM=(FD(L)-FCI(L))/DIFFE 
         ELSE 
            COM=0.D0 
         ENDIF 
         CMO(I,J)=-COM 
         CMO(J,I)= COM 
   40    L=L+1 
      ENDIF 
C 
C     C.I-ACTIVE EIGENVALUES RELAXATION. 
      CALL SCOPY(NCI2,FCI(L),1,EMO(NCI1+1),1) 
C 
C     PART 2. 
C     ------- 
C     UNPACK THE ANTISYMMETRIC MATRIX F IN CMO, (OFF-DIAGONAL BLOCKS). 
C 
      L=1 
      IF(NBO(2).GT.0 .AND. NBO(1).GT.0) THEN 
C        OPEN-CLOSED 
         SCAL=1.D0/(2.D0-FRACT) 
         DO 50 J=1       ,NBO(1) 
CDIR$ IVDEP 
         DO 50 I=NBO(1)+1,NOPEN 
         COM=F(L)*SCAL 
         CMO(I,J)=-COM 
         CMO(J,I)= COM 
   50    L=L+1 
      ENDIF 
      IF(NBO(3).GT.0 .AND. NBO(1).GT.0) THEN 
C        VIRTUAL-CLOSED 
         SCAL=0.5D0 
         DO 60 J=1     ,NBO(1) 
CDIR$ IVDEP 
         DO 60 I=NOPEN+1,N 
         COM=F(L)*SCAL 
         CMO(I,J)=-COM 
         CMO(J,I)= COM 
   60    L=L+1 
      ENDIF 
      IF(NBO(3).NE.0 .AND. NBO(2).NE.0) THEN 
C        VIRTUAL-OPEN 
         SCAL=1.D0/FRACT 
         DO 70 J=NBO(1)+1,NOPEN 
CDIR$ IVDEP 
         DO 70 I=NOPEN+1  ,N 
         COM=F(L)*SCAL 
         CMO(I,J)=-COM 
         CMO(J,I)= COM 
   70    L=L+1 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DERIV(GRAD,FAIL) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      PARAMETER (MFBWO=9*MAXPAR) 
C---------------------------------------------------------------------- 
C 
C    DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE 
C          OPTIMIZED PARAMETERS XPARAM(NVAR). 
C 
C    IMPLEMENTATION OF ANALYTICAL FORMULATION FOR OPEN SHELL OR CI, 
C                      VARIABLES FINITE DIFFERENCE METHODS, 
C                      STATISTICAL ESTIMATE OF THE ERRORS, 
C                   BY D. LIOTARD (MJS DEWAR GROUP, FEB-SEPTEMBER 1986) 
C 
C                * * * WHAT CAN BE DONE: * * * 
C 
C==> IF THE WAVE FUNCTION IS A RHF CLOSED SHELL DETERMINANT OR UHF,THE 
C    DERIVATIVES OF THE CORE-CORE REPULSION,CORE HAMILTONIAN AND FOCK 
C    MATRIX ARE EVALUATED IN CARTESIAN BY A 1 OR 2 POINTS FINITE 
C    DIFFERENCE FORMULA AND THE ENERGY GRADIENT IS COMPUTED USING 
C    THE SCF-CONVERGED DENSITY MATRIX (SUBROUTINE DCART). 
C 
C==> IF THE WAVE FUNCTION IS NOT SO SIMPLE, I.E. HALF-ELECTRON OR CI, 
C    THE DERIVATIVES OF THE 1 AND 2-ELECTRON INTEGRALS IN A.O. BASIS 
C    ARE EVALUATED IN CARTESIAN COORDINATES BY A 1 OR 2 POINTS FINITE 
C    DIFFERENCE FORMULA AND STORED. THUS ONE GETS THE NON-RELAXED 
C    (I.E. WITH FROZEN ELECTRONIC CLOUD) CONTRIBUTION TO THE FOCK 
C    EIGENVALUES AND 2-ELECTRON INTEGRALS IN M.O. BASIS. 
C    THE NON-RELAXED GRADIENT ISSUES FROM THE NON-RELAXED C.I. MATRIX 
C    DERIVATIVE (SUBROUTINE DERI1). 
C    THEN THE DERIVATIVES OF THE M.O. COEFFICIENTS ARE WORKED OUT 
C    ITERATIVELY (OK FOR BOTH CLOSED SHELLS AND HALF-ELECTRON CASES) 
C    AND STORED. THUS ONE GETS THE ELECTRONIC RELAXATION CONTRIBUTION TO 
C    THE FOCK EIGENVALUES AND 2-ELECTRON INTEGRALS IN M.O. BASIS. 
C    FINALLY THE RELAXATION CONTRIBUTION TO THE C.I. MATRIX DERIVATIVE 
C    GIVES THE RELAXATION CONTRIBUTION TO THE GRADIENT (ROUTINE DERI2). 
C 
C 
C    THE GRADIENT IS THEN BACK TRANSFORMED INTO THE INTERNAL COORDINATES 
C    via A JACOBIAN MATRIX WORKED OUT BY A 1 OR 2 POINTS FINITE 
C    DIFFERENCE FORMULA (SUBROUTINE JCARIN). 
C 
C==> IF THE MYSTERIOUS KEYWORD 'DERINU' IS SWITCHED ON, THE GRADIENT IN 
C    INTERNAL COORDINATES IS COMPUTED CRUDELY BY A 1 OR 2 POINTS FINITE 
C    DIFFERENCE ON THE TOTAL ENERGY (SUBROUTINE DERIV). 
C    THIS OPTION CAN BE USED AS A CHECK OF ACCURACY AND SPEED OF THE 
C    TWO PREVIOUS OPTIONS AND ALLOWS FOR ANY CHANGE IN THE FORMALISM. 
C    IT IS ALSO USED IF THE LACK OF CORE MEMORY INHIBIT THE COMPUTATION 
C    OF THE DERIVATIVES OF THE M.O. COEFFICIENTS IN 'DERI2'. 
C 
C NOTE ... THE FINITE DIFFERENCE METHOD IS SELECTED ACCORDING TO THE 
C          KEYWORDS 'PRECISE' OR ONE OF THOSE IMPLYING THE COMPUTATION 
C          OF AN ACCURATE MOLECULAR HESSIAN. 
C 
C    THE MAIN ARRAYS IN DERIV ARE: 
C        LOC    LOC(1,I),LOC(2,I) GIVE THE ADDRESS (ROW,COLUMN) OF THE 
C               INTERNAL COORDINATE #I TO BE USED IN THE GRADIENT 
C               CALCULATION. 
C        GEO    HOLDS THE INTERNAL  COORDINATES. 
C        COORD  HOLDS THE CARTESIAN COORDINATES. 
C    INPUT 
C        GRAD   NOT DEFINED. 
C        FAIL   LOGICAL, NOT DEFINED. 
C    EXIT 
C        GRAD   GRADIENT VECTOR (KCAL/RD,ANGSTROM), LENGTH NVAR. 
C        FAIL   .TRUE. IF GRADIENT ACCURACY NOT ASCERTAINED, 
C               .FALSE. OTHERWISE. 
C 
C---------------------------------------------------------------------- 
      COMMON / EULER/ TVEC(3,3), ID 
     1       /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMMY(MAXPAR) 
     2       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     3               ,NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA 
     4               ,NCLOSE,NOPEN,NDUMY,FRACT 
     5       /GEOKST/ NATOMS,LABELS(NUMATM) 
     6               ,NA(NUMATM),NB(NUMATM),NC(NUMATM) 
     7       /GEOSYM/ NDEP, IDUMYS(MAXPAR,3) 
     8       /GEOM  / GEO(3,NUMATM) 
     9       /UCELL / L1L,L2L,L3L,L1U,L2U,L3U,KDUM(6) 
      COMMON /NUMCAL/ NUMCAL 
     1       /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
     2       /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NUMBW,NBAND(NUMATM) 
     3       /HMATRX/ H(MPACK) 
     4       /ELECT / ELECT 
     5       /ENUCLR/ ENUCLR 
     6       /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
     7       /MESAGE/ IFLEPO,IITER 
     8       /KEYWRD/ KEYWRD 
     9       /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT 
     1       /SCRACH/ COLD(3,NUMATM*27),DXYZ(3,NUMATM*27) 
     2       /SCRAH2/ BWO(NRELAX*MORB2) 
     3       /SCRAH1/ SCALAR(MPACK/2),DIAG(MPACK/2),FRACT2,NBO(3),IDUM 
     4               ,FBWO(MFBWO) 
     5       /CIDATA/ VECTCI(NMECI**2),XXCI,NCI1,NCI2,NCI3 
     6       /LAST  / LAST 
      CHARACTER*80 KEYWRD 
      DIMENSION CHANGE(3),COORD(3,NUMATM),XPARAM(MAXPAR),XJUC(3) 
      DIMENSION W(1),GRAD(*),CT(MORB2) 
      LOGICAL DEBUG, TIMES, HALFE, FAST, SCF1, CI, FAIL, PRECI, DCAR 
     .       ,CLSD,NUM,ADJUST,CIJRDY 
      EQUIVALENCE (W,WJ) 
      DATA ICALCN /0/ 
C 
C     SELECT THE REQUIRED OPTION AND READ KEYWORDS 
C     -------------------------------------------- 
C 
C#    1 IF(ICALCN.EQ.NUMCAL) GO TO 10 
       SAVE
   1  CONTINUE
      DEBUG = (INDEX(KEYWRD,'DERIV') .NE. 0) 
      TIMES = (INDEX(KEYWRD,'TIME') .NE. 0) 
      PRECI = (INDEX(KEYWRD,'PREC') .NE. 0) 
      DCAR  = (INDEX(KEYWRD,'LTRD') + 
     .         INDEX(KEYWRD,'NEWT') + 
     .         INDEX(KEYWRD,'FORC') + 
     .         INDEX(KEYWRD,'PREC') .NE. 0) 
      CI    = (INDEX(KEYWRD,'C.I.') .NE. 0) 
      HALFE = (NOPEN.GT.NCLOSE) 
      CLSD=.NOT.(HALFE.OR.CI) 
      FAST=INDEX(KEYWRD,'DERINU').EQ.0 .AND. ICALCN.NE.-1 
C#      ICALCN=NUMCAL 
      IF(.NOT.CLSD) THEN 
C        ACTUAL SIZES FOR C.I. GRADIENT CALCULATION. 
         NBO(1)=NCLOSE 
         NBO(2)=NOPEN-NCLOSE 
         NBO(3)=NORBS-NOPEN 
         LINEAR=NORBS*(NORBS+1)/2 
         MINEAR=NBO(2)*NBO(1)+NBO(3)*NOPEN 
         NINEAR=NCI2 
         NEND=0 
         DO 2 LOOP=1,3 
         NINIT=NEND+1 
         NEND =NEND+NBO(LOOP) 
         N1=MAX(0,NCI1-NINIT) 
         N2=MIN(NEND ,NCI1+NCI2)-NINIT 
         IF(N2.GT.N1) NINEAR=NINEAR+(N2*(N2+1)-N1*(N1+1))/2 
    2    CONTINUE 
         NCOL=N2+1 
         N2=N2+NINIT 
         IF (NCOL.GT.0.AND.N2.LT.NORBS) THEN 
            NINEAR=NINEAR+NCOL*(NORBS-N2) 
         ELSE IF (NINEAR.LE.0) THEN 
            NINEAR=1 
         ENDIF 
         J=0 
         NUMBW=0 
         DO 3 I=1,NUMAT 
         J=MAX(J,NBAND(I)) 
    3    NUMBW=NUMBW+MAX(0,NBAND(I)) 
         NUMBW=J*(NUMBW-J)+1 
         LINF=NINEAR+MINEAR 
         LINB=NINEAR+MINEAR*2 
         FRACT2=FRACT 
C        THE ANALYTICAL COMPUTATION OF THE GRADIENT OF A C.I. FUNCTION, 
C        WITHOUT I/O ON A SCRATCH FILE, REQUIRES A LARGE CORE MEMORY 
C        PROVIDED BY /SCRAH2/. 
C        /SCRAH1/ CONTAINS DATA TO SPEED UP CONVERGENCE, 
C        /SCRACH/ IS USED AS A WORK AREA OF SIZE ROUGHLY = MORB2. 
C        UP TO 30% OF THE CPU TIME IS SAVED IF ONE CAN COMPUTE THE 
C        RELAXATION OF MBAND GRADIENT COMPONENTS AT A TIME: 
C        MBAND=9 GIVES USUALLY OPTIMUM RESULTS IN SPEED AND MBAND SHOULD 
C        BE A MULTIPLE OF 3 FOR BEST ACCURACY IN CARTESIAN COORD. 
C        TAKING INTO ACCOUNT THE LIMIT DUE TO FBW AND BAB IN DERI2, 
C        MBAND SHOULD BE GIVEN BY (J IS THE LIMIT DUE TO 'OSINV' ) 
         J=60 
         MBAND=MIN(9,J/3,MFBWO/MAX(NVAR,NINEAR),NVAR) 
C        AND THE d<IJ!KL> TRANSFORMATION REQUIRE 
         NIJKL=NORBS*NCI2*NCI2*(NCI2+1)/2 
         NFREE=NRELAX*MORB2-NIJKL 
C        THEREFORE /SCRAH2/ BEEING USED IN DERI2 AS: 
C        //DIJKL(NIJKL),F(MBAND*LINF),B(MAXITE*LINB) 
C        MAXITE CANNOT EXCEED 
         MAXITE=(NFREE-MBAND*LINF)/LINB 
C        ELSEWHERE, THE DIMENSION OF THE BASIS SET WHEN THE RELAXATION 
C        IS CONVERGED IN 'DERI2' TURNS OUT TO BE ROUGHLY GIVEN BY: 
C                      MAXITE = 5 + 2*MBAND , 
C        FOR CALCULATIONS WITH REASONABLE ACCURACY, AND SAFETY FACTOR 
C        OF 30%        INCLUDED. 
C        THUS THE FINAL VALUES OF MBAND (AS N*3) AND MAXITE BECOME 
         IF (MAXITE.LT.5+2*MBAND) THEN 
            MBAND= (NFREE-5*LINB)/(LINF+2*LINB) 
            MBAND=(MBAND/3)*3 
            MAXITE=(NFREE-MBAND*LINF)/LINB 
         ENDIF 
C        ELSEWHERE /SCRAH2/ IS USED IN DERI1 AS: 
C        //DIJKL(NIJKL),F(MBAND*LINF),WORK(NUMBW+LINEAR*2) 
C        THUS CHECKING SIZES .... 
         NUM=MBAND.LT.1.OR.MAXITE.LT.7.OR. 
     .       MINEAR.GT.MPACK/2.OR.NFREE.LT.NUMBW+LINEAR*2 
         IF (NUM.AND.FAST) THEN 
           WRITE(IPRT,'('' INSUFFICIENT SIZE IN COMMON /SCRAH2/ TO GET'' 
     .     ,'' THE GRADIENT BY ANALYTICAL METHOD''/ 
     .     ,'' THUS USE NUMERICAL PROCEDURE WITH LOWER ACCURACY...'' 
     .     ,'' AND HIGHER TIMING.'')') 
           FAST=.FALSE. 
         ELSE IF (ID.NE.0) THEN 
           WRITE(IPRT,'('' THIS VERSION DOES NOT ALLOW N-DIMENSIONAL '' 
     .               ,''POLYMER WITH C.I ... SORRY'')') 
           STOP 
         ELSE 
C          DEFINE ADDRESSES (ENTRY POINTS) IN /SCRAH2/. 
C          1) TO BE USED IN DERI2 
           ADJUST=.FALSE. 
           IPOSF =NIJKL +1 
           IPOSFD=IPOSF +MINEAR*MBAND 
           IPOSFC=IPOSFD+NINEAR*MBAND 
           IPOSB =IPOSFC+NINEAR*MAXITE 
           IPOSAB=IPOSB +MINEAR*MAXITE 
C          AND AB IS     MINEAR*MAXITE LONG. 
C          2) TO BE USED IN DERI1 
           IPOSW2=IPOSB 
           IPOSH2=IPOSW2+NUMBW 
           IPOSH3=IPOSH2+LINEAR 
           MPQKL =NRELAX*MORB2-IPOSH2+1 
         ENDIF 
      ENDIF 
C 
C     CHANGE(I) IS THE STEP SIZE OF THE FINITE DIFFERENCE FORMULA. 
C     CHANGE(1) FOR BOND LENGTH OR CARTESIAN, (2) ANGLE, (3) DIHEDRAL. 
      ESTIM(1)=700.D0 
      ESTIM(2)=150.D0 
      ESTIM(3)= 80.D0 
      PMAX(1)=0.01D0 
      PMAX(2)=0.1D0 
      PMAX(3)=0.12D0 
      NLOOP=1 
      IF(PRECI)NLOOP=2 
      IF(.NOT.FAST) THEN 
C 
C           - - - PURE NUMERICAL METHODS - - - 
C    A LARGE STEP IS NEEDED AS FULL SCF CALCULATIONS ARE NEEDED, 
C    AND THE DIFFERENCE BETWEEN THE TOTAL ENERGY IS USED. 
C    THE STEP CANNOT BE VERY LARGE, AS THE SECOND DERIVATIVES ARE 
C    NOT ALWAYS SMALL (UP TO 1000 KCAL/ANGSTROM**2 ). 
C    THEREFORE - GIVEN SCFCV,THE STANDARD DEVIATION ON THE ENERGY AND 
C    ESTIM(I),A MEAN VALUE OF DIAGONAL SECOND DERIVATIVES - 
C    CHANGE(I) IS ADJUSTED IN ORDER TO ROUGHLY MINIMIZE THE ERROR EG(I) 
C    ON THE FIRST DERIVATIVES . 
C 
C    IF PRECI=.T. AN ESTIMATE OF THIRD DERIVATIVES SHOULD BE REQUIRED 
C                 TO OPTIMIZE THE STEP LENGTH... BUT WE HAVE NOT. 
C    SO, IN THE PRESENT VERSION, MULTIPLYING THE STEP BY 10, WE ONLY 
C    ENSURE THE ROUND-OFF OR SCF COMPONENT OF THE ERROR TO BE DECREASED 
C    BY ONE ORDER OF MAGNITUDE. 
C 
         DO 4 I=1,3 
         CHANGE(I)=2.D0*SQRT(SCFCV/ESTIM(I)) 
    4    EG(I)=2.D0*SCFCV/CHANGE(I)+ESTIM(I)*CHANGE(I)/2.D0 
         IF (INDEX(KEYWRD,' FORC').NE.0) THEN 
            DO 5 I=2,3 
            CHANGE(I)=CHANGE(1) 
    5       EG(I)=EG(1) 
         ENDIF 
         DO 6 I=1,3 
         IF(PRECI) CHANGE(I)=CHANGE(I)*1.D1 
    6    CHANGE(I)=MIN(CHANGE(I),PMAX(I)) 
      ELSE 
C 
C          - - - QUASI-ANALYTICAL BRANCHES - - - 
C    A REASONABLE ESTIMATE OF THE ERROR ON THE GRADIENT IS GIVEN BY A 
C    LEAST SQUARE FIT USING A LAW SIMILAR TO THOSE USED IN 'ITER': 
            EG(1)=1.D1**(0.80355D0*LOG10(SCFCV)+0.45782D0) 
C    AND ONES MUST ADD THE LOWER BOUND DUE TO ROUND-OFF : 
            EG(1)=EG(1)+2.D-4 
C 
C    NOTE ... USING A 1-POINT FINITE DIFFERENCE FORMULA IN 'DCART', ONE 
C             SAVES 1/3 OF THE CPU TIME, BUT THE ACCURACY IS BOUNDED 
C             BELOW BY THE VALUE 0.05 KCAL/MOLE. 
         IF (.NOT.DCAR) EG(1)=EG(1)+0.05D0 
         IF(CLSD) THEN 
C           WILL CALL 'DCART' . STEP SIZE: 
            STEP=1.D-4 
         ELSE 
C           WILL CALL 'DERI1' AND 'DERI2'. STEP SIZE AND CV THRESHOLD 
C           NOTE ... THE ROUND-OFF ERROR IS 1.D-8 IN ROTATE... 
            STEP=1.D-3 
C           THE LAW RELATING SCFCRT AND EG(I) BEEING CHOSEN AS: 
C  SCFCRT(EV)  :     1D-3      1D-5       1D-7       1D-9       1D-11 
C  EG(I)(KCAL) :     1.0       0.1        0.01       0.001      0.0001 
C           AND A LEAST SQUARE FIT OF EG(I) VS THROLD GIVING: 
C           LOG(EG(I)) = 1.06129 * LOG(THROLD) + 0.17161 
C           ONE GET THE FOLLOWING VALUE FOR THROLD, THE CONVERGENCE 
C           CRITERION IN THE RELAXATION PROCEDURE (CF 'DERI2') : 
            BAL=MAX(LOG(EG(1)),0.76585D0*LOG(SCFCV)+3.88582D0) 
            THROLD=EXP(0.9422D0*BAL-0.1617D0) 
C           WITH THE RESULTING OVERALL ERROR ON THE GRADIENT: 
            EG(1)=EG(1)+EXP(1.06129D0*LOG(THROLD)+0.17161D0) 
         ENDIF 
         DO 7 I=1,3 
    7    CHANGE(I)=STEP 
         EG(2)=EG(1) 
         EG(3)=EG(1) 
C        JACOBIAN STEP SIZE : 
         IF(DCAR)THEN 
            JLOOP=2 
            STEPJA=1.D-6 
         ELSE 
            JLOOP=1 
            STEPJA=1.D-7 
         ENDIF 
      ENDIF 
       IF(ICALCN .NE. NUMCAL) THEN
      WRITE(IPRT,FMT='( 
     .   '' STANDARD DEVIATION ON ENERGY (KCAL)        '', F11.8/ 
     .   '' STEP LENGTH FOR FIRST DERIVATIVES          '',3F11.8/ 
     .   '' STANDARD DEVIATION OF GRADIENT (KCAL/A,RD) '',3F11.8)') 
     .      SCFCV,(CHANGE(I),I=1,3),(EG(I),I=1,3) 
      IF(DCAR) THEN 
         WRITE(IPRT,FMT='( 
     .   '' USE 2-POINTS CENTRAL FINITE DIFFERENCES IN'', 
     .   '' INTEGRAL DERIVATIVES AND JACOBIAN'')') 
      ELSE 
         WRITE(IPRT,FMT='( 
     .   '' USE 1-POINT FORWARD FINITE DIFFERENCE IN'', 
     .   '' INTEGRAL DERIVATIVES AND JACOBIAN'')') 
      ENDIF 
      ICALCN = NUMCAL
      ENDIF
C 
C---------------------------------------------------------------------- 
C 
C     RESTORE THE GEOMETRIC PARAMETERS AND INITIALIZE 
C     ----------------------------------------------- 
C 
   10 FAIL=.FALSE. 
      IF(NVAR.EQ.0) RETURN 
      IF(DEBUG) 
     .WRITE(IPRT,'('' INTERNAL COORDINATES AT START OF DERIV''/ 
     .(F19.5,2F12.5))')((GEO(J,I),J=1,3),I=1,NATOMS) 
      DO 20 I=1,NVAR 
      GRAD(I)=0.D0 
   20 XPARAM(I)=GEO(LOC(2,I),LOC(1,I)) 
      CALL SECOND (TIME1) 
      IF(NDEP.NE.0) CALL SYMTRY 
      CALL GMETRY(GEO,COORD) 
      AA=ELECT+ENUCLR 
C 
C     CRUDE FINITE DIFFERENCE ON THE ENERGY 
C     ------------------------------------- 
C 
      IF (FAST) GO TO 200 
C     1 OR 2 POINTS FINITE DIFFERENCE 
  100 BAL=-1.D0 
      DO 130 IBAL=1,NLOOP 
      BAL=-BAL 
C     LOOP ON THE VARIABLES ( ONE STEP=CHANGE(LOC(2,*))*BAL ) 
         DO 120 I=1,NVAR 
         IF(FAIL) GO TO 140 
         DO 110 J=1,NVAR 
  110    GEO(LOC(2,J),LOC(1,J))=XPARAM(J) 
         STEP=CHANGE(LOC(2,I))*BAL 
         GEO(LOC(2,I),LOC(1,I))=XPARAM(I)+STEP 
         IF(NDEP.NE.0) CALL SYMTRY 
         CALL GMETRY(GEO,COORD) 
         CALL HCORE(COORD,H,W, WJ, WK,ENUCLR) 
         CALL ITER(H,W, WJ, WK,EE,.FALSE.,.FALSE.) 
         FAIL=IITER.NE.1 
         EE=(EE+ENUCLR) 
         TOTL=(EE-AA)*23.061D0/STEP 
  120    GRAD(I)=(TOTL+GRAD(I))/IBAL 
  130 CONTINUE 
C      RESTORE GEOMETRICAL DATA, INTEGRALS AND M.O. 
  140  DO 150 I=1,NVAR 
  150  GEO(LOC(2,I),LOC(1,I))=XPARAM(I) 
       IF(NDEP.NE.0) CALL SYMTRY 
       CALL GMETRY(GEO,COORD) 
       CALL HCORE(COORD,H,W, WJ, WK,ENUCLR) 
       CALL ITER(H,W, WJ, WK,EE,.FALSE.,.FALSE.) 
       FAIL=IITER.NE.1 .OR. FAIL 
       GO TO 500 
C 
C     HALF-ELECTRON OR C.I. 
C     --------------------- 
C 
  200 IF (.NOT.CLSD) THEN 
C        SCALING ROW FACTORS TO SPEED CV OF RELAXATION PROCEDURE. 
         CALL DERI0 (C,CT,EIGS,NORBS) 
         NBSIZE=0 
         NVAX=3*NUMAT 
         ILAST=0 
  210    IFIST=ILAST+1 
         ILAST=MIN(NVAX,ILAST+MBAND) 
C        NON-RELAXED CONTRIBUTION (FROZEN ELECTRONIC CLOUD) IN GRAD 
C        AND NON-RLXED FOCK MATRICES IN BWO(IPOSF) & BWO(IPOSFD). 
         CIJRDY=.FALSE. 
         DO 220 I=IFIST,ILAST 
         STEP=CHANGE(1) 
  220    CALL DERI1 (C,CT,NORBS,COORD,STEP,I,CBETA,GRAD(I) 
     .              ,BWO(IPOSW2),BWO(IPOSH2),BWO(IPOSH3) 
     .              ,BWO(IPOSF +MINEAR*(I-IFIST)),MINEAR 
     .              ,BWO(IPOSFD+NINEAR*(I-IFIST)),NINEAR 
     .              ,BWO(IPOSH2),MPQKL,CIJRDY) 
C        COMPUTE THE ELECTRONIC RELAXATION CONTRIBUTION. 
  230    CALL DERI2 (C,CT,EIGS,NORBS,MINEAR,THROLD,BWO(IPOSF) 
     .              ,BWO(IPOSFD),BWO(IPOSFC),NINEAR,ILAST-IFIST+1 
     .              ,MAXITE,CBETA,BWO(IPOSB),NBSIZE,GRAD(IFIST) 
     .              ,FAIL,BWO(IPOSAB),FBWO,MFBWO) 
         IF (FAIL.AND.ILAST.EQ.IFIST) THEN 
C           CONVERGENCE NOT ACHIEVED IN DERI2 (LACK OF CORE MEMORY... 
C           OR ILL-BEHAVED SYSTEM). GO TO CRUDE FINITE DIFFERENCE 
C           SECTION FOR THE REMAINING PART OF THE JOB ]]] 
            FAIL=.FALSE. 
            WRITE(IPRT,'('' REQUIRED ACCURACY NOT ACHIEVED IN DERI2''/ 
     .'' USE CRUDE FINITE DIFFERENCE METHOD IN GRADIENT COMPUTATION'')') 
            ICALCN=-1 
            GO TO 1 
         ELSE IF(FAIL) THEN 
C           DECREASE MBAND (BY 3) AND TRY AGAIN. 
            ILAST =ILAST-3 
            FAIL  =.FALSE. 
            ADJUST=.TRUE. 
            GO TO 230 
         ELSE IF(ADJUST) THEN 
C          REDUCE MBAND AND UPDATE ADDRESSES 
C          1) TO BE USED IN DERI2, 
           MBAND=MBAND-3 
           MAXITE=(NFREE-MBAND*LINF)/LINB 
           ADJUST=.FALSE. 
           IPOSFD=IPOSF +MINEAR*MBAND 
           IPOSFC=IPOSFD+NINEAR*MBAND 
           IPOSB =IPOSFC+NINEAR*MAXITE 
           IPOSAB=IPOSB +MINEAR*MAXITE 
C          2) TO BE USED IN DERI1 
           IPOSW2=IPOSB 
           IPOSH2=IPOSW2+NUMBW 
           IPOSH3=IPOSH2+LINEAR 
           MPQKL =NRELAX*MORB2-IPOSH2+1 
         ENDIF 
         IF (ILAST.LT.NVAX) GO TO 210 
C        GRADIENT AS BEEN COMPUTED IN 3*N CARTESIAN. 
         IF (INDEX(KEYWRD,' FORC').EQ.0) THEN 
C           CONVERT IN INTERNAL 
            CALL SCOPY (NVAX,GRAD,1,DXYZ,1) 
            GO TO 300 
         ELSE 
            GO TO 500 
         ENDIF 
      ENDIF 
C 
C     RHF CLOSED SHELLS WITHOUT C.I. OR UHF 
C     ------------------------------------- 
C 
      IF (CLSD) THEN 
C        GRADIENT IN 3*NATOM CARTESIAN 
         CALL DCART (COORD,DXYZ,CHANGE(1)) 
      ENDIF 
C 
C     JACOBIAN dCARTESIAN/dINTERNAL 
C     ----------------------------- 
C     STORED IN BWO. 
  300 CALL JCARIN (COORD,XPARAM,STEPJA,DCAR,BWO,NCOL) 
C     GRADIENT IN INTERNAL, STORED IN GRAD. 
      CALL MXM (BWO,NVAR,DXYZ,NCOL,GRAD,1) 
      IF (DCAR) THEN 
         STEP=0.5D0/STEPJA 
      ELSE 
         STEP=1.0D0/STEPJA 
      ENDIF 
      DO 310 I=1,NVAR 
  310 GRAD(I)=GRAD(I)*STEP 
C 
C     SOME PRINTOUT IF NEEDED 
C     ----------------------- 
C 
  500 IF(DEBUG) THEN 
         WRITE(IPRT,'('' GRADIENTS (KCAL)'')') 
         WRITE(IPRT,'(10F8.3)')(GRAD(I),I=1,NVAR) 
      ENDIF 
      IF (TIMES)THEN 
         CALL SECOND (TFLY) 
         WRITE(IPRT,'('' TIME FOR DERIVATIVES'',F12.6)')TFLY-TIME1 
      ENDIF 
C 
C     C.I CORRECTION ON THE DENSITY MATRIX. 
C     ------------------------------------- 
      IF (LAST.EQ.1.AND..NOT.CLSD) CALL MECIP (P,C,CBETA,NORBS,BWO,NCI2) 
      RETURN 
      END 
      SUBROUTINE JCARIN (COORD,XPARAM,STEP,PRECI,B,NCOL) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     JACOBIAN dCARTESIAN/dINTERNAL, WORKED OUT BY FINITE DIFFERENCE. 
C  INPUT 
C     XPARAM(*) : INTERNAL COORDINATES 
C     STEP      : STEP SIZE FOR FINITE DIFFERENCE METHOD 
C     PRECI     : .TRUE. IF 2-POINTS FINITE DIFFERENCES TO BE USED, 
C                 .FALSE. OTHERWISE. 
C  OUTPUT 
C     B(NVAR,NCOL) : JACOBIAN, STEP TIME TOO LARGE. 
C 
      COMMON /SCRACH/ COOLD(3,NUMATM*27) 
     1       /GEOSYM/ NDEP 
     2       /MOLKST/ NUMAT 
     3       /GEOVAR/ NVAR,LOC(2,MAXPAR) 
     4       /EULER / TVEC(3,3),ID 
     5       /UCELL / L1L,L2L,L3L,L1U,L2U,L3U,KDUM(6) 
     6       /GEOM  / GEO(3,NUMATM) 
      DIMENSION COORD(3,*),XPARAM(*),B(NVAR,*) 
      LOGICAL PRECI 
       SAVE
C 
      NCOL=3*NUMAT 
      IF(ID.NE.0) 
     . NCOL=NCOL*(L1U-L1L+1)*(L2U-L2L+1)*(L3U-L3L+1) 
C 
C     INTERNAL OF CENTRAL POINT 
      DO 10 IVAR=1,NVAR 
   10 GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR) 
C 
      IF (ID.EQ.0) THEN 
C 
C        MOLECULAR SYSTEM 
C        ---------------- 
         DO 30 IVAR=1,NVAR 
C        STEP FORWARD 
         GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR)+STEP 
         IF(NDEP.NE.0) CALL SYMTRY 
         CALL GMETRY (GEO,COORD) 
         DO 20 J=1,NCOL 
   20    B(IVAR,J)=COORD(J,1) 
   30    GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR) 
         IF (PRECI) THEN 
            DO 50 IVAR=1,NVAR 
C           STEP BACKWARD 
            GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR)-STEP 
            IF(NDEP.NE.0) CALL SYMTRY 
            CALL GMETRY (GEO,COORD) 
            DO 40 J=1,NCOL 
   40       B(IVAR,J)=B(IVAR,J)-COORD(J,1) 
   50       GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR) 
         ELSE 
C           CENTRAL POINT 
            IF(NDEP.NE.0) CALL SYMTRY 
            CALL GMETRY (GEO,COORD) 
            DO 60 IVAR=1,NVAR 
            DO 60 J=1,NCOL 
   60       B(IVAR,J)=B(IVAR,J)-COORD(J,1) 
         ENDIF 
      ELSE 
C 
C        SOLID STATE 
C        ----------- 
         DO 130 IVAR=1,NVAR 
C        STEP FORWARD 
         GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR)+STEP 
         IF(NDEP.NE.0) CALL SYMTRY 
         CALL GMETRY (GEO,COORD) 
         IJ=0 
         DO 120 II=1,NUMAT 
         DO 120 IL=L1L,L1U 
         DO 120 JL=L2L,L2U 
         DO 120 KL=L3L,L3U 
         DO 120 LL=1,3 
         IJ=IJ+1 
  120    B(IVAR,IJ)=COORD(LL,II) 
     .            +TVEC(LL,1)*IL+TVEC(LL,2)*JL+TVEC(LL,3)*KL 
  130    GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR) 
         IF (PRECI) THEN 
            DO 150 IVAR=1,NVAR 
C           STEP BACKWARD 
            GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR)-STEP 
            IF(NDEP.NE.0) CALL SYMTRY 
            CALL GMETRY (GEO,COORD) 
            IJ=0 
            DO 140 II=1,NUMAT 
            DO 140 IL=L1L,L1U 
            DO 140 JL=L2L,L2U 
            DO 140 KL=L3L,L3U 
            DO 140 LL=1,3 
            IJ=IJ+1 
  140       B(IVAR,IJ)=B(IVAR,IJ)-COORD(LL,II) 
     .                -TVEC(LL,1)*IL-TVEC(LL,2)*JL-TVEC(LL,3)*KL 
  150       GEO(LOC(2,IVAR),LOC(1,IVAR))=XPARAM(IVAR) 
         ELSE 
C           CENTRAL POINT 
            IF(NDEP.NE.0) CALL SYMTRY 
            CALL GMETRY (GEO,COORD) 
            IJ=0 
            DO 160 II=1,NUMAT 
            DO 160 IL=L1L,L1U 
            DO 160 JL=L2L,L2U 
            DO 160 KL=L3L,L3U 
            IJ=IJ+1 
            DO 160 LL=1,3 
  160       COOLD(LL,IJ)=COORD(LL,II) 
     .                  +TVEC(LL,1)*IL+TVEC(LL,2)*JL+TVEC(LL,3)*KL 
            DO 170 IVAR=1,NVAR 
            DO 170 IJ=1,NCOL 
  170       B(IVAR,IJ)=B(IVAR,IJ)-COOLD(IJ,1) 
         ENDIF 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
********************************************************************** 
* 
* DFPSAV STORES AND RESTORES DATA USED IN THE D-F-P GEOMETRY 
*        OPTIMISATION. 
* 
*  ON INPUT TOTIME = TOTAL CPU TIME ELAPSED DURING THE CALCULATION. 
*           XPARAM = CURRENT VALUE OF PARAMETERS. 
*           GD     = OLD GRADIENT. 
*           XLAST  = OLD VALUE OF PARAMETERS. 
*           FUNCT1 = CURRENT VALUE OF HEAT OF FORMATION. 
*           MDFP   = INTEGER CONSTANTS USED IN D-F-P. 
*           XDFP   = REAL CONSTANTS USED IN D-F-P. 
*           MDFP(9)= 1 FOR DUMP, 0 FOR RESTORE. 
********************************************************************** 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TITLES/ KOMENT,TITLE 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMY(MAXPAR) 
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
      COMMON /ALPARM/ ALPARM(3,MAXPAR),X0, X1, X2, ILOOP 
      COMMON /REACTN/ STEP, GEOA(3,NUMATM), GEOVEC(3,NUMATM),CALCST 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /ELEMTS/ ELEMNT(107) 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /OPTIM / HESINV(MAXHES) 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR), 
     1                     LOCDEP(MAXPAR) 
      COMMON /ERRFN / ERRFN(MAXPAR) 
      DIMENSION XPARAM(*), GD(*), XLAST(*), MDFP(9),XDFP(9) 
      DIMENSION IEL1(3),Q(3), COORD(3,NUMATM) 
      CHARACTER ELEMNT*2, KEYWRD*80,KOMENT*80, TITLE*80 
      LOGICAL FIRST, INTXYZ , DEBUG
      DATA FIRST /.TRUE./ 
       SAVE
      DEBUG=INDEX(KEYWRD,'DFPSAV').NE.0
      OPEN(UNIT=9,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 9 
      OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 10 
      DEGREE=57.29577951D0 
      IR=9 
      IF(MDFP(9) .EQ. 1) THEN 
         WRITE(6,'(//10X,''- - - - - - - TIME UP - - - - - - -'',//)') 
         IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN 
            WRITE(6,'(//10X,'' NO RESTART EXISTS FOR SADDLE'',// 
     1  10X,'' HERE IS A DATA-FILE FILES THAT MIGHT BE SUITABLE'',/ 
     2  10X,'' FOR RESTARTING THE CALCULATION'',///)') 
            WRITE(6,'(1X,A)')KEYWRD,KOMENT,TITLE 
            INTXYZ=(NA(1).EQ.0) 
            DO 60 ILOOP=1,2 
               IF(INTXYZ)THEN 
                  GEO(2,1)=0.D0 
                  GEO(3,1)=0.D0 
                  GEO(1,1)=0.D0 
                  GEO(2,2)=0.D0 
                  GEO(3,2)=0.D0 
                  GEO(3,3)=0.D0 
                  DO 10 I=1,NATOMS 
                     DO 10 J=1,3 
   10             COORD(J,I)=GEO(J,I) 
               ELSE 
                  CALL XYZINT(GEO,NUMAT,NA,NB,NC,1.D0,COORD) 
               ENDIF 
               IVAR=1 
               NA(1)=0 
               DO 40 I=1,NATOMS 
                  DO 20 J=1,3 
   20             IEL1(J)=0 
   30             CONTINUE 
                  IF(LOC(1,IVAR).EQ.I) THEN 
                     IEL1(LOC(2,IVAR))=1 
                     IVAR=IVAR+1 
                     GOTO 30 
                  ENDIF 
                  IF(I.LT.4) THEN 
                     IEL1(3)=0 
                     IF(I.LT.3) THEN 
                        IEL1(2)=0 
                        IF(I.LT.2) THEN 
                           IEL1(1)=0 
                        ENDIF 
                     ENDIF 
                  ENDIF 
                  IF(I.EQ.LATOM)IEL1(LPARAM)=-1 
                  Q(1)=COORD(1,I) 
                  Q(2)=COORD(2,I)*DEGREE 
                  Q(3)=COORD(3,I)*DEGREE 
   40          WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)') 
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I) 
               I=0 
               X=0.D0 
               WRITE(6,'(I4,3(F12.6,I3),I4,2I3)') 
     1    I,X,I,X,I,X,I,I,I,I 
               DO 50 I=1,NATOMS 
                  DO 50 J=1,3 
   50          GEO(J,I)=GEOA(J,I) 
               NA(1)=99 
   60       CONTINUE 
            WRITE(6,'(///10X,''CALCULATION TERMINATED HERE'')') 
            STOP 
         ENDIF 
         WRITE(6,'(//10X,'' - THE CALCULATION IS BEING DUMPED TO DISK'', 
     1  /10X,''   RESTART IT USING THE MAGIC WORD "RESTART"'')') 
         WRITE(6,'(//10X,''CURRENT VALUE OF HEAT OF FORMATION ='' 
     1  ,F12.6)')FUNCT1 
         IF(NA(1) .EQ. 99) THEN 
C 
C  CONVERT FROM CARTESIAN COORDINATES TO INTERNAL 
C 
            DO 70 I=1,NATOMS 
               DO 70 J=1,3 
   70       COORD(J,I)=GEO(J,I) 
            CALL XYZINT(COORD,NUMAT,NA,NB,NC,1.D0,GEO) 
         ENDIF 
         GEO(2,1)=0.D0 
         GEO(3,1)=0.D0 
         GEO(1,1)=0.D0 
         GEO(2,2)=0.D0 
         GEO(3,2)=0.D0 
         GEO(3,3)=0.D0 
         IVAR=1 
         NA(1)=0 
         WRITE(6,'(A)')KEYWRD,KOMENT,TITLE 
         DO 100 I=1,NATOMS 
            DO 80 J=1,3 
   80       IEL1(J)=0 
   90       CONTINUE 
            IF(LOC(1,IVAR).EQ.I) THEN 
               IEL1(LOC(2,IVAR))=1 
               IVAR=IVAR+1 
               GOTO 90 
            ENDIF 
            IF(I.LT.4) THEN 
               IEL1(3)=0 
               IF(I.LT.3) THEN 
                  IEL1(2)=0 
                  IF(I.LT.2) THEN 
                     IEL1(1)=0 
                  ENDIF 
               ENDIF 
            ENDIF 
            IF(I.EQ.LATOM)IEL1(LPARAM)=-1 
            Q(1)=GEO(1,I) 
            Q(2)=GEO(2,I)*DEGREE 
            Q(3)=GEO(3,I)*DEGREE 
  100    WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)') 
     1ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I) 
         I=0 
         X=0.D0 
         WRITE(6,'(I4,3(F12.6,I3),I4,2I3)') 
     1I,X,I,X,I,X,I,I,I,I 
         IF(NDEP.NE.0)THEN 
            DO 110 I=1,NDEP 
  110       WRITE(6,'(3(I4,'',''))')LOCPAR(I),IDEPFN(I),LOCDEP(I) 
            WRITE(6,*) 
         ENDIF 
         WRITE(IR)MDFP,XDFP,TOTIME,FUNCT1 
         WRITE(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR) 
         WRITE(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR) 
         LINEAR=(NVAR*(NVAR+1))/2 
         WRITE(IR)(HESINV(I),I=1,LINEAR) 
         LINEAR=(NORBS*(NORBS+1))/2 
         WRITE(10)(PA(I),I=1,LINEAR) 
         IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR) 
         IF(LATOM .NE. 0) THEN 
            WRITE(IR)((ALPARM(J,I),J=1,3),I=1,NVAR) 
            WRITE(IR)ILOOP,X0, X1, X2 
         ENDIF 
         WRITE(IR)(ERRFN(I),I=1,NVAR) 
         IF(DEBUG)THEN
           CALL VECPRT(PA,NORBS )
         ENDIF
         STOP 
      ELSE 
         IF (FIRST) WRITE(6,'(//10X,'' RESTORING DATA FROM DISK''/)') 
         READ(IR)MDFP,XDFP,TOTIME,FUNCT1 
         IF (FIRST) WRITE(6,'(10X,''FUNCTION ='',F13.6//)')FUNCT1 
         READ(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR) 
         READ(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR) 
         LINEAR=(NVAR*(NVAR+1))/2 
         READ(IR)(HESINV(I),I=1,LINEAR) 
         LINEAR=(NORBS*(NORBS+1))/2 
         READ(10)(PA(I),I=1,LINEAR) 
         IF(NALPHA.NE.0)READ(10)(PB(I),I=1,LINEAR) 
         IF(LATOM.NE.0) THEN 
            READ(IR)((ALPARM(J,I),J=1,3),I=1,NVAR) 
            READ(IR)ILOOP,X0, X1, X2 
         ENDIF 
         READ(IR)(ERRFN(I),I=1,NVAR) 
         IF(FIRST.AND.DEBUG)THEN
           CALL VECPRT(PA,NORBS )
         ENDIF
  120    FIRST=.FALSE. 
         RETURN 
      ENDIF 
      END 
      SUBROUTINE DIAG(FAO,VECTOR,NOCC,EIG,MDIM,N) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C*********************************************************************** 
C 
C   "FAST" DIAGONALISATION PROCEDURE. 
C 
C    ON INPUT FAO CONTAINS THE LOWER HALF TRIANGLE OF THE MATRIX TO BE 
C                         DIAGONALISED, PACKED. 
C             VECTOR  CONTAINS THE OLD EIGENVECTORS ON INPUT, THE NEW 
C             VECTORS ON EXITING. 
C             NOCC = NUMBER OF OCCUPIED MOLECULAR ORBITALS. 
C             EIG  = EIGENVALUES FROM AN EXACT DIAGONALISATION 
C             MDIM = DECLARED SIZE OF MATRIX "VECTOR". 
C                    (MUST EQUAL N IN THE CRAY VERSION) 
C             N = NUMBER OF ATOMIC ORBITALS IN BASIS SET 
C 
C  DIAG IS A PSEUDO-DIAGONALISATION PROCEDURE, IN THAT THE VECTORS THAT 
C       ARE GENERATED BY IT ARE MORE NEARLY ABLE TO BLOCK-DIAGONALISE 
C       THE FOCK MATRIX OVER MOLECULAR ORBITALS THAN THE STARTING 
C       VECTORS. IT MUST BE CONSIDERED PSEUDO FOR SEVERAL REASONS: 
C       (A) IT DOES NOT GENERATE EIGENVECTORS - THE SECULAR DETERMINANT 
C           IS NOT DIAGONALISED, ONLY THE OCCUPIED-VIRTUAL INTERSECTION. 
C       (B) MANY SMALL ELEMENTS IN THE SEC.DET. ARE IGNORED AS BEING TOO 
C           SMALL COMPARED WITH THE LARGEST ELEMENT. 
C       (C) WHEN ELEMENTS ARE ELIMINATED BY ROTATION, THE REST OF THE 
C           SEC. DET. IS ASSUMED NOT TO CHANGE, I.E. ELEMENTS CREATED 
C           ARE IGNORED. 
C       (D) THE ROTATION REQUIRED TO ELIMINATE THOSE ELEMENTS CONSIDERED 
C           SIGNIFICANT IS APPROXIMATED TO USING THE EIGENVALUES OF THE 
C           EXACT DIAGONALISATION THROUGHOUT THE REST OF THE ITERATIVE 
C           PROCEDURE. 
C 
C  (NOTE:- IN AN ITERATIVE PROCEDURE ALL THE APPROXIMATIONS PRESENT IN 
C          DIAG BECOME VALID AT SELF-CONSISTENCY, SELF-CONSISTENCY IS 
C          NOT SLOWED DOWN BY USE OF THESE APPROXIMATIONS) 
C 
C    REFERENCE: 
C             "FAST SEMIEMPIRICAL CALCULATIONS", 
C             STEWART. J.J.P., CSASZAR, P., PULAY, P., J. COMP. CHEM., 
C             3, 227, (1982) 
C 
C*********************************************************************** 
      DIMENSION FAO(*),VECTOR(N,*),EIG(*) 
      COMMON /SCRACH/ FMO(MPACK/2),WS(MORB2),BUF(MORB2) 
C     FMO  IS A WORK-SPACE OF SIZE NOCC*(N-NOCC), IT WILL HOLD 
C          THE FOCK MOLECULAR ORBITAL INTERACTION MATRIX. 
C          ARRAY OF SIZE N*(N-NOCC). 
C     WS AND BUF ARE WORK SPACE OF SIZE N*N (CRAY VERSION). 
C 
C     FIRST, CONSTRUCT FMO, THAT PART OF A SECULAR DETERMINANT OVER 
C     MOLECULAR ORBITALS WHICH CONNECTS THE OCCUPIED AND VIRTUAL SETS. 
C     ---------------------------------------------------------------- 
       SAVE
      K=0 
      DO 10 I=1,N 
      IJ=I 
CDIR$ IVDEP 
      DO 10 JI=N*(I-1)+1,N*(I-1)+I 
      K=K+1 
      BUF(JI)=FAO(K) 
      BUF(IJ)=FAO(K) 
   10 IJ=IJ+N 
      LUMO=NOCC+1 
      NVIRT=N-NOCC 
      CALL MXM (BUF,N,VECTOR(1,LUMO),N,WS,NVIRT) 
      CALL MTXM(VECTOR,NOCC,WS,N,FMO,NVIRT) 
      TINY=0.04D0*ABS(FMO(ISMAX(NVIRT*NOCC,FMO,1))) 
C 
C     NOW DO A CRUDE 2 BY 2 ROTATION TO "ELIMINATE" SIGNIFICANT ELEMENTS 
C     ------------------------------------------------------------------ 
C 
      IJ=0 
      DO 120 I=LUMO,N 
         EIGI=EIG(I) 
         DO 110 J=1,NOCC 
            IJ=IJ+1 
            C=FMO(IJ) 
            IF(ABS(C).LT.TINY) GOTO 110 
C 
C      BEGIN 2 X 2 ROTATIONS 
C 
            D=EIGI-EIG(J) 
            E=MIN(1.D0,0.5D0*(1.D0+D/SQRT(4.D0*C*C+D*D))) 
            ALPHA=SQRT(E) 
            BETA=SIGN(SQRT(1.D0-E),C) 
C 
C      ROTATION OF PSEUDO-EIGENVECTORS 
            DO 100 M=1,N 
               A=VECTOR(M,J) 
               B=VECTOR(M,I) 
               VECTOR(M,J)=ALPHA*A-BETA*B 
  100          VECTOR(M,I)=ALPHA*B+BETA*A 
  110    CONTINUE 
  120 CONTINUE 
      RETURN 
      END 
      SUBROUTINE DIAT(NI,NJ,XI,XJ,DI) 
      IMPLICIT REAL (A-H,O-Z) 
************************************************************************ 
* 
*   DIAT CALCULATES THE DI-ATOMIC OVERLAP INTEGRALS BETWEEN ATOMS 
*        CENTERED AT XI AND XJ. 
* 
*   ON INPUT NI  = ATOMIC NUMBER OF THE FIRST ATOM. 
*            NJ  = ATOMIC NUMBER OF THE SECOND ATOM. 
*            XI  = CARTESIAN COORDINATES OF THE FIRST ATOM. 
*            XJ  = CARTESIAN COORDINATES OF THE SECOND ATOM. 
* 
*  ON OUTPUT DI  = DIATOMIC OVERLAP, IN A 9 * 9 MATRIX. LAYOUT OF 
*                  ATOMIC ORBITALS IN DI IS 
*                  1   2   3   4   5            6     7       8     9 
*                  S   PX  PY  PZ  D(X**2-Y**2) D(XZ) D(Z**2) D(YZ)D(XY) 
* 
*   LIMITATIONS:  IN THIS FORMULATION, NI AND NJ MUST BE LESS THAN 107 
*         EXPONENTS ARE ASSUMED TO BE PRESENT IN COMMON BLOCK EXPONT. 
* 
************************************************************************ 
      INTEGER A,PQ2,B,PQ1,AA,BB,YETA 
      LOGICAL FIRST 
      COMMON /EXPONT/ EMUS(107),EMUP(107),EMUD(107) 
      COMMON /ALPTM / ALPTM(30), EMUDTM(30) 
      DIMENSION DI(9,9),S(3,3,3),UL1(3),UL2(3),C(3,5,5),NPQ(107) 
     1          ,XI(3),XJ(3), SLIN(27), IVAL(3,5) 
     2, C1(3,5), C2(3,5), C3(3,5), C4(3,5), C5(3,5) 
     3, S1(3,3), S2(3,3), S3(3,3) 
      EQUIVALENCE(SLIN(1),S(1,1,1)) 
      EQUIVALENCE (C1(1,1),C(1,1,1)), (C2(1,1),C(1,1,2)), 
     1            (C3(1,1),C(1,1,3)), (C4(1,1),C(1,1,4)), 
     2            (C5(1,1),C(1,1,5)), (S1(1,1),S(1,1,1)), 
     3            (S2(1,1),S(1,1,2)), (S3(1,1),S(1,1,3)) 
      DATA NPQ/1,0, 2,2,2,2,2,2,2,0, 3,3,3,3,3,3,3,0, 4,4,4,4,4,4,4,4, 
     14,4,4,4,4,4,4,4,4,0, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5 
     1,32*6,21*0/ 
      DATA IVAL/1,0,9,1,3,8,1,4,7,1,2,6,0,0,5/ 
      DATA FIRST /.TRUE./ 
       SAVE
      X1=XI(1) 
      X2=XJ(1) 
      Y1=XI(2) 
      Y2=XJ(2) 
      Z1=XI(3) 
      Z2=XJ(3) 
      PQ1=NPQ(NI) 
      PQ2=NPQ(NJ) 
      DO 20 I=1,9 
         DO 10 J=1,9 
            DI(I,J)=0.0D0 
   10    CONTINUE 
   20 CONTINUE 
      CALL COE(X1,Y1,Z1,X2,Y2,Z2,PQ1,PQ2,C,R) 
      IF(PQ1.EQ.0.OR.PQ2.EQ.0.OR.R.GE.10.D0) RETURN 
      IF(R.LT.0.1)THEN 
         RETURN 
      ENDIF 
      IA=MIN(PQ1,3) 
      IB=MIN(PQ2,3) 
      A=IA-1 
      B=IB-1 
      IF(PQ1.LT.3.AND.PQ2.LT.3) THEN 
         CALL DIAT2(NI,EMUS(NI),EMUP(NI),R,NJ,EMUS(NJ),EMUP(NJ),S) 
      ELSE 
         UL1(1)=EMUS(NI) 
         UL2(1)=EMUS(NJ) 
         UL1(2)=EMUP(NI) 
         UL2(2)=EMUP(NJ) 
         UL1(3)=EMUD(NI) 
         UL2(3)=EMUD(NJ) 
C 
      IF (NI.EQ.24.AND.NJ.EQ.24) THEN 
         UL1(3)=EMUDTM(24) 
         UL2(3)=EMUDTM(24) 
      ENDIF 
C 
         DO 30 I=1,27 
   30    SLIN(I)=0.0D0 
         NEWK=MIN(A,B) 
         NK1=NEWK+1 
         YETA=PQ1+PQ2+3 
         DO 40 I=1,IA 
            ISS=I 
            IB=B+1 
            DO 40 J=1,IB 
               JSS=J 
               DO 40 K=1,NK1 
                  IF(K.GT.I.OR.K.GT.J) GOTO 40 
                  KSS=K 
                  S(I,J,K)=SS(PQ1,PQ2,ISS,JSS,KSS,UL1(I),UL2(J),R,YETA,F 
     1IRST) 
   40    CONTINUE 
      ENDIF 
      DO 50 I=1,IA 
         KMIN=4-I 
         KMAX=2+I 
         DO 50 J=1,IB 
            IF(J.EQ.2)THEN 
               AA=-1 
               BB=1 
            ELSE 
               AA=1 
               IF(J.EQ.3) THEN 
                  BB=-1 
               ELSE 
                  BB=1 
               ENDIF 
            ENDIF 
            LMIN=4-J 
            LMAX=2+J 
            DO 50 K=KMIN,KMAX 
               DO 50 L=LMIN,LMAX 
                  II=IVAL(I,K) 
                  JJ=IVAL(J,L) 
                  DI(II,JJ)=S1(I,J)*C3(I,K)*C3(J,L)*AA+ 
     1(C4(I,K)*C4(J,L)+C2(I,K)*C2(J,L))*BB*S2(I,J)+(C5(I,K)*C5(J,L) 
     2+C1(I,K)*C1(J,L))*S3(I,J) 
   50 CONTINUE 
      RETURN 
      END 
      FUNCTION SS(NA,NB,LA,LB,M,UC,UD,R1,YETA,FIRST) 
      IMPLICIT REAL (A-H,O-Z) 
      LOGICAL FIRST 
      INTEGER A,PP,B,Q,YETA 
      DIMENSION FA(14),BI(13,13),AFF(3,3,3),AF(20),BF(20) 
      DATA AFF/27*0. D0/ 
      DATA FA/1.D0,1.D0,2.D0,6.D0,24.D0,120.D0,720.D0,5040.D0,40320.D0, 
     1362880.D0,3628800.D0,39916800.D0,479001600.D0,6227020800.D0/ 
       SAVE
      R=R1 
      UA=UC 
      UB=UD 
      R=R/0.529167D0 
      ER=R 
      IF(FIRST) THEN 
         FIRST=.FALSE. 
         DO 10 I=1,13 
            BI(I,1)=1.D0 
            BI(I,I)=1.D0 
   10    CONTINUE 
         DO 20 I=1,12 
            I1=I-1 
            DO 20 J=1,I1 
               BI(I+1,J+1)=BI(I,J+1)+BI(I,J) 
   20    CONTINUE 
         AFF(1,1,1)=1.D0 
         AFF(2,1,1)=1.D0 
         AFF(2,2,1)=1.D0 
         AFF(3,1,1)=1.5D0 
         AFF(3,2,1)=1.73205D0 
         AFF(3,3,1)=1.224745D0 
         AFF(3,1,3)=-0.5D0 
      ENDIF 
      P=(UA+UB)*ER*0.5D0 
      BA=(UA-UB)*ER*0.5D0 
      EX=EXP(BA) 
      QUO=1/P 
      AF(1)=QUO*EXP(-P) 
      NANB=NA+NB 
      DO 30 N=1,19 
         AF(N+1)=N*QUO*AF(N)+AF(1) 
   30 CONTINUE 
      NANB1=NANB+1 
      CALL BFN(BA,BF) 
      SUM=0.D0 
      LAM1=LA-M+1 
      LBM1=LB-M+1 
      DO 50 I=1,LAM1,2 
         A=NA+I-LA 
         IC=LA+2-I-M 
         DO 50 J=1,LBM1,2 
            B=NB+J-LB 
            ID=LB-J-M+2 
            SUM1=0.D0 
            IA=A+1 
            IB=B+1 
            AB=A+B-1 
            DO 40 K1=1,IA 
               PART1=BI(IA,K1) 
               DO 40 K2=1,IB 
                  PART2=PART1*BI(IB,K2) 
                  DO 40 K3=1,IC 
                     PART3=PART2*BI(IC,K3) 
                     DO 40 K4=1,ID 
                        PART4=PART3*BI(ID,K4) 
                        DO 40 K5=1,M 
                           PART5=PART4*BI(M,K5) 
                           Q=AB-K1-K2+K3+K4+2*K5 
                           DO 40 K6=1,M 
                              PART6=PART5*BI(M,K6) 
                              PP=K1+K2+K3+K4+2*K6-5 
                              JX=M+K2+K4+K5+K6-5 
                              IX=JX/2 
                              SUM1=SUM1+PART6*(IX*2-JX+0.5D0)*AF(Q)*BF(P 
     1P) 
   40       CONTINUE 
            SUM=SUM+SUM1*AFF(LA,M,I)*AFF(LB,M,J)*2.D0 
   50 CONTINUE 
      X=R**(NA+NB+1)*UA**NA*UB**NB 
      SA=SUM*X*SQRT(UA*UB/(FA(NA+NA+1)*FA(NB+NB+1))*((LA+LA-1 
     1)*(LB+LB-1)))/(2.D0**M) 
   60 CONTINUE 
      SS=SA 
      RETURN 
      END 
      SUBROUTINE COE(X1,Y1,Z1,X2,Y2,Z2,PQ1,PQ2,C,R) 
      IMPLICIT REAL (A-H,O-Z) 
      INTEGER PQ1,PQ2,PQ,CO 
      DIMENSION C(75) 
       SAVE
      XY=(X2-X1)**2+(Y2-Y1)**2 
      R=SQRT(XY+(Z2-Z1)**2) 
      XY=SQRT(XY) 
      IF (XY.LT.1.D-10) GO TO 10 
      CA=(X2-X1)/XY 
      CB=(Z2-Z1)/R 
      SA=(Y2-Y1)/XY 
      SB=XY/R 
      GO TO 50 
   10 IF (Z2-Z1) 20,30,40 
   20 CA=-1.D0 
      CB=-1.D0 
      SA=0.D0 
      SB=0.D0 
      GO TO 50 
   30 CA=0.D0 
      CB=0.D0 
      SA=0.D0 
      SB=0.D0 
      GO TO 50 
   40 CA=1.D0 
      CB=1.D0 
      SA=0.D0 
      SB=0.D0 
   50 CONTINUE 
      CO=0 
      DO 60 I=1,75 
   60 C(I)=0.D0 
      IF (PQ1.GT.PQ2) GO TO 70 
      PQ=PQ2 
      GO TO 80 
   70 PQ=PQ1 
   80 CONTINUE 
      C(37)=1.D0 
      IF (PQ.LT.2) GO TO 90 
      C(56)=CA*CB 
      C(41)=CA*SB 
      C(26)=-SA 
      C(53)=-SB 
      C(38)=CB 
      C(23)=0.D0 
      C(50)=SA*CB 
      C(35)=SA*SB 
      C(20)=CA 
      IF (PQ.LT.3) GO TO 90 
      C2A=2*CA*CA-1.D0 
      C2B=2*CB*CB-1.D0 
      S2A=2*SA*CA 
      S2B=2*SB*CB 
      C(75)=C2A*CB*CB+0.5D0*C2A*SB*SB 
      C(60)=0.5D0*C2A*S2B 
      C(45)=0.8660254037841D0*C2A*SB*SB 
      C(30)=-S2A*SB 
      C(15)=-S2A*CB 
      C(72)=-0.5D0*CA*S2B 
      C(57)=CA*C2B 
      C(42)=0.8660254037841D0*CA*S2B 
      C(27)=-SA*CB 
      C(12)=SA*SB 
      C(69)=0.5773502691894D0*SB*SB*1.5D0 
      C(54)=-0.8660254037841D0*S2B 
      C(39)=CB*CB-0.5D0*SB*SB 
      C(66)=-0.5D0*SA*S2B 
      C(51)=SA*C2B 
      C(36)=0.8660254037841D0*SA*S2B 
      C(21)=CA*CB 
      C(6)=-CA*SB 
      C(63)=S2A*CB*CB+0.5D0*S2A*SB*SB 
      C(48)=0.5D0*S2A*S2B 
      C(33)=0.8660254037841D0*S2A*SB*SB 
      C(18)=C2A*SB 
      C(3)=C2A*CB 
   90 CONTINUE 
      RETURN 
      END 
      SUBROUTINE BFN(X,B) 
      IMPLICIT REAL (A-H,O-Z) 
C********************************************************************** 
C 
C     BFN FORMS THE "B" INTEGRALS FOR THE OVERLAP CALCULATION. 
C 
C********************************************************************** 
      DIMENSION B(13),FACT(17),COEF(30),WORK(17) 
      DATA IPASS/0/ 
C     INITIALIZE (DONE ONLY ONCE) 
       SAVE
      IF (IPASS.EQ.0) THEN 
         IPASS=1 
         FACT(1)=1.D0 
         Y=1.D0 
         DO 10 I=2,17 
         Y=Y*FLOAT(I) 
   10    FACT(I)=1.D0/Y 
CDIR$ IVDEP 
         DO 20 I=1,29,2 
         COEF(I)=2.D0/FLOAT(I) 
   20    COEF(I+1)=0.D0 
      ENDIF 
      ABSX = ABS(X) 
      IF (ABSX.GT.3.D0) THEN 
         EXPX=EXP(X) 
         EXPMX=1.D0/EXPX 
         Y=1.D0/X 
         B(1)=(EXPX-EXPMX)*Y 
         DO 30 I=1,12 
         EXPX=-EXPX 
   30    B(I+1)=(FLOAT(I)*B(I)+EXPX-EXPMX)*Y 
      ELSE 
         DO 40 I=1,13 
   40    B(I)=COEF(I) 
         IF (ABSX.LE.1.D-6) RETURN 
         LAST=5+4*ABSX 
         DO 50 M=1,LAST 
   50    WORK(M)=FACT(M)*(-X)**M 
         DO 60 I=1,13 
         J=MOD(I,2)+1 
         DO 60 M=J,LAST,2 
   60    B(I)=WORK(M)*COEF(M+I)+B(I) 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DIAT2(NA,ESA,EPA,R12,NB,ESB,EPB,S) 
      IMPLICIT REAL (A-H,O-Z) 
C*********************************************************************** 
C 
C DIAT2  CALCULATES OVERLAPS BETWEEN ATOMIC ORBITALS FOR PAIRS OF ATOMS 
C        IT CAN HANDLE THE ORBITALS 1S, 2S, 3S, 2P, AND 3P. 
C 
C*********************************************************************** 
      COMMON /SETC/ A(7),B(7),SA,SB,FACTOR,ISP,IPS 
      DIMENSION S(3,3,3) 
      DIMENSION INMB(17),III(78) 
      DATA INMB/1,0,2,2,3,4,5,6,7,0,8,8,8,9,10,11,12/ 
      DATA IPASS/0/ 
       SAVE
      IF (IPASS.EQ.0) THEN 
         IPASS=1 
         RT3=1.D0/SQRT(3.D0) 
      ENDIF 
C     NUMBERING CORRESPONDS TO BOND TYPE MATRIX GIVEN ABOVE 
C      THE CODE IS 
C 
C     III=1      FIRST - FIRST  ROW ELEMENTS 
C        =2      FIRST - SECOND 
C        =3      FIRST - THIRD 
C        =4      SECOND - SECOND 
C        =5      SECOND - THIRD 
C        =6      THIRD - THIRD 
      DATA III/1,2,4,   2,4,4,   2,4,4,4,   2,4,4,4,4, 
     1 2,4,4,4,4,4,   2,4,4,4,4,4,4,   3,5,5,5,5,5,5,6, 
     2 3,5,5,5,5,5,5,6,6,   3,5,5,5,5,5,5,6,6,6,   3,5,5,5,5,5,5,6,6,6,6 
     3, 3,5,5,5,5,5,5,6,6,6,6,6/ 
C 
C      ASSIGN BOND NUMBER 
C 
      JMAX=MAX0(INMB(NA),INMB(NB)) 
      JMIN=MIN0(INMB(NA),INMB(NB)) 
      NBOND=(JMAX*(JMAX-1))/2+JMIN 
      II=III(NBOND) 
      DO 10 I=1,27 
   10 S(I,1,1)=0.D0 
      RAB=R12/0.529167D0 
      GOTO (20,30,40,50,60,70), II 
C 
C     ------------------------------------------------------------------ 
C *** THE ORDERING OF THE ELEMENTS WITHIN S IS 
C *** S(1,1,1)=(S(B)/S(A)) 
C *** S(1,2,1)=(P-SIGMA(B)/S(A)) 
C *** S(2,1,1)=(S(B)/P-SIGMA(A)) 
C *** S(2,2,1)=(P-SIGMA(B)/P-SIGMA(A)) 
C *** S(2,2,2)=(P-PI(B)/P-PI(A)) 
C     ------------------------------------------------------------------ 
C *** FIRST ROW - FIRST ROW OVERLAPS 
C 
   20 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      S(1,1,1)=.25D00*SQRT((SA*SB*RAB*RAB)**3)*(A(3)*B(1)-B(3)*A(1)) 
      RETURN 
C 
C *** FIRST ROW - SECOND ROW OVERLAPS 
C 
   30 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA**3)*(SB**5))*(RAB**4)*0.125D00 
      S(1,1,1)=W*RT3*(A(4)*B(1)-B(4)*A(1)+A(3)*B(2)-B(3)*A(2)) 
      IF (NB.GT.1) THEN 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA**3)*(SB**5))*(RAB**4)*0.125D00 
      S(ISP,IPS,1)=W*(A(3)*B(1)-B(3)*A(1)+A(4)*B(2)-B(4)*A(2)) 
      RETURN 
C 
C *** FIRST ROW - THIRD ROW OVERLAPS 
C 
   40 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA**3)*(SB**7)/7.5D00)*(RAB**5)*0.0625D00 
      S(1,1,1)=W*(A(5)*B(1)-B(5)*A(1)+ 
     12.D00*(A(4)*B(2)-B(4)*A(2)))*RT3 
      IF (NB.GT.1) THEN 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA**3)*(SB**7)/7.5D00)*(RAB**5)*0.0625D00 
      S(ISP,IPS,1)=W*(A(4)*(B(1)+B(3))-B(4)*(A(1)+A(3))+ 
     1B(2)*(A(3)+A(5))-A(2)*(B(3)+B(5))) 
      RETURN 
C 
C *** SECOND ROW - SECOND ROW OVERLAPS 
C 
   50 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA*SB)**5)*(RAB**5)*0.0625D00 
      S(1,1,1)=W*(A(5)*B(1)+B(5)*A(1)-2.0D00*A(3)*B(3))/3.0D00 
      IF (NA.LE.NB) THEN 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA*SB)**5)*(RAB**5)*0.0625D00 
      D=A(4)*(B(1)-B(3))-A(2)*(B(3)-B(5)) 
      E=B(4)*(A(1)-A(3))-B(2)*(A(3)-A(5)) 
      S(ISP,IPS,1)=W*RT3*(D+E) 
      IF (NA.LE.NB) THEN 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA*SB)**5)*(RAB**5)*0.0625D00 
      D=A(4)*(B(1)-B(3))-A(2)*(B(3)-B(5)) 
      E=B(4)*(A(1)-A(3))-B(2)*(A(3)-A(5)) 
      S(IPS,ISP,1)=-W*RT3*(E-D) 
      CALL SET (EPA,EPB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA*SB)**5)*(RAB**5)*0.0625D00 
      S(2,2,1)=-W*(B(3)*(A(5)+A(1))-A(3)*(B(5)+B(1))) 
      S(2,2,2)=0.5D0*W*(A(5)*(B(1)-B(3))-B(5)*(A(1)-A(3)) 
     1-A(3)*B(1)+B(3)*A(1)) 
      RETURN 
C 
C *** SECOND ROW - THIRD ROW OVERLAPS 
C 
   60 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA**5)*(SB**7)/7.5D00)*(RAB**6)*0.03125D00 
      S(1,1,1)=W*(A(6)*B(1)+A(5)*B(2)-2.D0*(A(4)*B(3)+ 
     1A(3)*B(4))+A(2)*B(5)+A(1)*B(6))/3.D0 
      IF (NA.LE.NB) THEN 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA**5)*(SB**7)/7.5D00)*(RAB**6)*0.03125D00 
      S(ISP,IPS,1)=W*RT3*(A(6)*B(2)+A(5)*B(1)-2.D0*(A(4)*B(4)+A(3)*B(3)) 
     1+A(2)*B(6)+A(1)*B(5)) 
      IF (NA.LE.NB) THEN 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA**5)*SB**7/7.5D00)*(RAB**6)*0.03125D00 
      S(IPS,ISP,1)=-W*RT3*(A(5)*(2.D0*B(3)-B(1))-B(5)*(2.D0*A(3)-A(1)) 
     1-A(2)*(B(6)-2.D0*B(4))+B(2)*(A(6)-2.D0*A(4))) 
      CALL SET (EPA,EPB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA**5)*SB**7/7.5D00)*(RAB**6)*0.03125D00 
      S(2,2,1)=-W*(B(4)*(A(1)+A(5))-A(4)*(B(1)+B(5)) 
     1+B(3)*(A(2)+A(6))-A(3)*(B(2)+B(6))) 
      S(2,2,2)=0.5D0*W*(A(6)*(B(1)-B(3))-B(6)*(A(1)- 
     1A(3))+A(5)*(B(2)-B(4))-B(5 
     2)*(A(2)-A(4))-A(4)*B(1)+B(4)*A(1)-A(3)*B(2)+B(3)*A(2)) 
      RETURN 
C 
C *** THIRD ROW - THIRD ROW OVERLAPS 
C 
   70 CALL SET (ESA,ESB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA*SB*RAB*RAB)**7)/480.D00 
      S(1,1,1)=W*(A(7)*B(1)-3.D00*(A(5)*B(3)-A(3)*B(5))-A(1)*B(7))/3.D00 
      IF (NA.LE.NB) THEN 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA*SB*RAB*RAB)**7)/480.D00 
      D=A(6)*(B(1)-B(3))-2.D00*A(4)*(B(3)-B(5))+A(2)*(B(5)-B(7)) 
      E=B(6)*(A(1)-A(3))-2.D00*B(4)*(A(3)-A(5))+B(2)*(A(5)-A(7)) 
      S(ISP,IPS,1)=W*RT3*(D-E) 
      IF (NA.LE.NB) THEN 
         CALL SET (EPA,ESB,NA,NB,RAB,NBOND,II) 
      ELSE 
         CALL SET (ESA,EPB,NA,NB,RAB,NBOND,II) 
      ENDIF 
      W=SQRT((SA*SB*RAB*RAB)**7)/480.D00 
      D=A(6)*(B(1)-B(3))-2.D00*A(4)*(B(3)-B(5))+A(2)*(B(5)-B(7)) 
      E=B(6)*(A(1)-A(3))-2.D00*B(4)*(A(3)-A(5))+B(2)*(A(5)-A(7)) 
      S(IPS,ISP,1)=-W*RT3*(-D-E) 
      CALL SET (EPA,EPB,NA,NB,RAB,NBOND,II) 
      W=SQRT((SA*SB*RAB*RAB)**7)/480.D00 
      S(2,2,1)=-W*(A(3)*(B(7)+2.D0*B(3))-A(5)*(B(1)+ 
     12.D0*B(5))-B(5)*A(1)+A(7)*B(3)) 
      S(2,2,2)=0.5D0*W*(A(7)*(B(1)-B(3))+B(7)*(A(1)- 
     1A(3))+A(5)*(B(5)-B(3)-B(1) 
     2)+B(5)*(A(5)-A(3)-A(1))+2.D00*A(3)*B(3)) 
      RETURN 
C 
      END 
      SUBROUTINE SET (S1,S2,NA,NB,RAB,NBOND,II) 
      IMPLICIT REAL (A-H,O-Z) 
      COMMON /SETC/ A(7),B(7),SA,SB,FACTOR,ISP,IPS 
C*********************************************************************** 
C 
C     SET IS PART OF THE OVERLAP CALCULATION, CALLED BY DIAT2. 
C         IT BUILD THE "A" AND "B" INTEGRALS. 
C 
C*********************************************************************** 
      DIMENSION FACT(17),WORK(17),COEF(24) 
      DATA IPASS/0/ 
      SAVE
C     INITIALIZE (DONE ONLY ONCE) 
      IF (IPASS.EQ.0) THEN 
         IPASS=1 
         FACT(1)=1.D0 
         Y=1.D0 
         DO 10 I=2,17 
         Y=Y*FLOAT(I) 
   10    FACT(I)=1.D0/Y 
CDIR$ IVDEP 
         DO 20 I=1,23,2 
         COEF(I)=2.D0/FLOAT(I) 
   20    COEF(I+1)=0.D0 
      ENDIF 
C 
      IF (NA.LE.NB) THEN 
         ISP=1 
         IPS=2 
         SA=S1 
         SB=S2 
      ELSE 
         ISP=2 
         IPS=1 
         SA=S2 
         SB=S1 
      ENDIF 
      IF (II.GT.3) THEN 
         K=II 
      ELSE 
         K=II+1 
      ENDIF 
C 
C     "A" INTEGRALS 
C 
      X=0.5D0*RAB*(SA+SB) 
      Y=1.D0/X 
      EXPMX=EXP(-X) 
      A(1)=EXPMX*Y 
      DO 30 I=1,K 
   30 A(I+1)=(A(I)*FLOAT(I)+EXPMX)*Y 
C 
C     "B" INTEGRALS 
C 
      X=0.5D0*RAB*(SB-SA) 
      ABSX = ABS(X) 
      IF (ABSX.GT.3.D0) THEN 
         EXPX=EXP(X) 
         EXPMX=1.D0/EXPX 
         Y=1.D0/X 
         B(1)=(EXPX-EXPMX)*Y 
         DO 40 I=1,K 
         EXPX=-EXPX 
   40    B(I+1)=(FLOAT(I)*B(I)+EXPX-EXPMX)*Y 
      ELSE 
         DO 50 I=1,K+1 
   50    B(I)=COEF(I) 
         IF (ABSX.LE.1.D-6) RETURN 
         LAST=5+4*ABSX 
         DO 60 M=1,LAST 
   60    WORK(M)=FACT(M)*(-X)**M 
         DO 70 I=1,K+1 
         J=MOD(I,2)+1 
         DO 70 M=J,LAST,2 
   70    B(I)=WORK(M)*COEF(M+I)+B(I) 
      ENDIF 
      RETURN 
      END 
      FUNCTION DIPOLE (P,Q,COORD,DIPVEC) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM), NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /MULTIP/ DD(107), QQ(107), AM(107), AD(107), AQ(107) 
      DIMENSION P(*),Q(*),COORD(3,*),DIPVEC(3) 
      CHARACTER*80 KEYWRD 
C*********************************************************************** 
C     DIPOLE CALCULATES DIPOLE MOMENTS 
C 
C  ON INPUT P     = DENSITY MATRIX 
C           Q     = TOTAL ATOMIC CHARGES, (NUCLEAR + ELECTRONIC) 
C           NUMAT = NUMBER OF ATOMS IN MOLECULE 
C           NAT   = ATOMIC NUMBERS OF ATOMS 
C           NFIRST= START OF ATOM ORBITAL COUNTERS 
C           COORD = COORDINATES OF ATOMS 
C 
C  OUTPUT  DIPOLE = DIPOLE MOMENT 
C*********************************************************************** 
C 
C     IN THE ZDO APPROXIMATION, ONLY TWO TERMS ARE RETAINED IN THE 
C     CALCULATION OF DIPOLE MOMENTS. 
C     1. THE POINT CHARGE TERM (INDEPENDENT OF PARAMETERIZATION). 
C     2. THE ONE-CENTER HYBRIDIZATION TERM, WHICH ARISES FROM MATRIX 
C     ELEMENTS OF THE FORM <NS/R/NP>. THIS TERM IS A FUNCTION OF 
C     THE SLATER EXPONENTS (ZS,ZP) AND IS THUS DEPENDENT ON PARAMETER- 
C     IZATION. THE HYBRIDIZATION FACTORS (HYF(I)) USED IN THIS SUB- 
C     ROUTINE ARE CALCULATED FROM THE FOLLOWING FORMULAE. 
C     FOR SECOND ROW ELEMENTS <2S/R/2P> 
C     HYF(I)= 469.56193322*(SQRT(((ZS(I)**5)*(ZP(I)**5)))/ 
C           ((ZS(I) + ZP(I))**6)) 
C     FOR THIRD ROW ELEMENTS <3S/R/3P> 
C     HYF(I)=2629.107682607*(SQRT(((ZS(I)**7)*(ZP(I)**7)))/ 
C           ((ZS(I) + ZP(I))**8)) 
C     FOR FOURTH ROW ELEMENTS AND UP : 
C     HYF(I)=2*(2.10716)*DD(I) 
C     WHERE DD(I) IS THE CHARGE SEPARATION IN ATOMIC UNITS 
C 
C 
C     REFERENCES: 
C     J.A.POPLE & D.L.BEVERIDGE: APPROXIMATE M.O. THEORY 
C     S.P.MCGLYNN, ET AL: APPLIED QUANTUM CHEMISTRY 
C 
      DIMENSION DIP(4,3) 
      DIMENSION HYF(107,2) 
      LOGICAL FIRST, FORCE 
      DATA HYF(1,1)     / 0.0D00           / 
      DATA   HYF(1,2) /0.0D0     / 
      DATA   HYF(5,2) /6.520587D0/ 
      DATA   HYF(6,2) /4.253676D0/ 
      DATA   HYF(7,2) /2.947501D0/ 
      DATA   HYF(8,2) /2.139793D0/ 
      DATA   HYF(9,2) /2.2210719D0/ 
      DATA   HYF(14,2)/6.663059D0/ 
      DATA   HYF(15,2)/5.657623D0/ 
      DATA   HYF(16,2)/6.345552D0/ 
      DATA   HYF(17,2)/2.522964D0/ 
      DATA FIRST /.TRUE./ 
       SAVE
      IF (FIRST) THEN 
         DO 10 I=4,107 
            HYF(I,1)= 5.0832*DD(I) 
   10    CONTINUE 
         FIRST=.FALSE. 
         FORCE=(INDEX(KEYWRD,'FORCE') .NE. 0) 
         ITYPE=1 
         IF(INDEX(KEYWRD,'MINDO') .NE. 0)ITYPE=2 
      ENDIF 
      DO 20 I=1,4 
         DO 20 J=1,3 
   20 DIP(I,J)=0.0D00 
      DO 30 I=1,NUMAT 
         NI=NAT(I) 
         IA=NFIRST(I) 
         DO 30 J=1,3 
            K=((IA+J)*(IA+J-1))/2+IA 
            DIP(J,2)=DIP(J,2)-HYF(NI,ITYPE)*P(K) 
   30 DIP(J,1)=DIP(J,1)+4.803D00*Q(I)*COORD(J,I) 
      DO 40 J=1,3 
   40 DIP(J,3)=DIP(J,2)+DIP(J,1) 
      DO 50 J=1,3 
   50 DIP(4,J)=SQRT(DIP(1,J)**2+DIP(2,J)**2+DIP(3,J)**2) 
      IF( FORCE) THEN 
         DIPVEC(1)=DIP(1,3) 
         DIPVEC(2)=DIP(2,3) 
         DIPVEC(3)=DIP(3,3) 
      ELSE 
         WRITE (6,60) ((DIP(I,J),I=1,4),J=1,3) 
      ENDIF 
      DIPOLE = DIP(4,3) 
      RETURN 
C 
   60 FORMAT (' DIPOLE',11X,2HX ,8X,2HY ,8X,2HZ ,6X,'TOTAL',/, 
     1' POINT-CHG.',4F10.3/,' HYBRID',4X,4F10.3/,' SUM',7X,4F10.3) 
C 
      END 
      SUBROUTINE DRC 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
*                                                                      * 
*    DRC IS DESIGNED TO FOLLOW A REACTION PATH FROM THE TRANSITION     * 
*    STATE.  TWO MODES ARE SUPPORTED, FIRST: GAS PHASE:- AS THE SYSTEM * 
*    MOVES FROM THE T/S THE MOMENTUM OF THE ATOMS IS STORED AND THE    * 
*    POSITION OF THE ATOMS IS RELATED TO THE OLD POSITION BY (A) THE   * 
*    CURRENT VELOCITY OF THE ATOM, AND (B) THE FORCES ACTING ON THAT   * 
*    ATOM.  THE SECOND MODE IS CONDENSED PHASE, IN WHICH THE ATOMS MOVE* 
*    IN RESPONSE TO THE FORCES ACTING ON THEM. I.E. INFINITELY DAMPED  * 
*                                                                      * 
************************************************************************ 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TITLES/ KOMENT,TITLE 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR) 
      COMMON /ELEMTS/ ELEMNT(107) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /CORE  / CORE(107) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 
      DIMENSION Q(3), COORDS(3,NUMATM), IEL1(3), Q2(NUMATM) 
      CHARACTER KEYWRD*80, KOMENT*80, TITLE*80, ELEMNT*2, ALPHA*2 
      CHARACTER SPACE*1, CHDOT*1, ZERO*1, NINE*1, CH*1 
      DIMENSION VELO0(MAXPAR), VELO1(MAXPAR), VELO2(MAXPAR), 
     1VELO3(MAXPAR), 
     2VOLD(MAXPAR), COORD(3,NUMATM), GROLD2(MAXPAR), 
     3GROLD(MAXPAR), PAROLD(MAXPAR), PARREF(MAXPAR), 
     4 SQRTMS(MAXPAR) 
      LOGICAL INT, ADDK,FAIL 
      EQUIVALENCE (COORD,VOLD) 
      DATA VELO0/MAXPAR*0.D0/, INT/.TRUE./, VOLD/MAXPAR*0.D0/ 
      DATA ADDK/.TRUE./ 
      DATA SPACE,CHDOT,ZERO,NINE /' ','.','0','9'/ 
       SAVE
      CALL SECOND (TNOW) 
      IF(INDEX(KEYWRD,' PREC').NE.0)THEN 
         ACCU=1.D0 
      ELSE 
         ACCU=0.1D0 
      ENDIF 
      LPOINT=0 
      STEPT=0.D0 
      STEPH=0.D0 
      STEPX=0.D0 
      IF(INDEX(KEYWRD,' T-PRIO').NE.0)THEN 
         IF(INDEX(KEYWRD,' T-PRIORITY=').NE.0)THEN 
            STEPT=READA(KEYWRD,INDEX(KEYWRD,'T-PRIO')+5) 
         ELSE 
            STEPT=0.1D0 
         ENDIF 
         WRITE(6,'(/,'' TIME PRIORITY, INTERVAL ='',F4.1, 
     1'' FEMTOSECONDS'',/)')STEPT 
         STEPT=STEPT*1.D-15 
      ELSEIF(INDEX(KEYWRD,' H-PRIO').NE.0)THEN 
         IF(INDEX(KEYWRD,' H-PRIORITY=').NE.0)THEN 
            STEPH=READA(KEYWRD,INDEX(KEYWRD,'H-PRIO')+5) 
         ELSE 
            STEPH=0.1D0 
         ENDIF 
         WRITE(6,'(/,'' KINETIC ENERGY PRIORITY, STEP ='',F4.1, 
     1'' KCAL/MOLE'',/)')STEPH 
      ELSEIF(INDEX(KEYWRD,' X-PRIO').NE.0)THEN 
         IF(INDEX(KEYWRD,' X-PRIORITY=').NE.0)THEN 
            STEPX=READA(KEYWRD,INDEX(KEYWRD,'X-PRIO')+5) 
         ELSE 
            STEPX=0.05D0 
         ENDIF 
         WRITE(6,'(/,'' GEOMETRY PRIORITY, STEP ='',F5.2, 
     1'' ANGSTROMS'',/)')STEPX 
      ENDIF 
      IF(INDEX(KEYWRD,' SYMME').NE.0)THEN 
         WRITE(6,*)'  SYMMETRY SPECIFIED, BUT CANNOT BE USED IN DRC' 
         NDEP=0 
      ENDIF 
      IF(INDEX(KEYWRD,' XYZ').EQ.0)THEN 
         CALL GMETRY(GEO,COORD) 
         L=0 
         DO 10 I=1,NUMAT 
            LABELS(I)=NAT(I) 
            SUM=SQRT(ATMASS(NAT(I))) 
            DO 10 J=1,3 
               L=L+1 
               SQRTMS(L)=SUM 
   10    GEO(J,I)=COORD(J,I) 
         NA(1)=99 
      ENDIF 
      L=0 
      DO 20 I=1,NUMAT 
         DO 20 J=1,3 
            L=L+1 
            LOC(1,L)=I 
            LOC(2,L)=J 
   20 XPARAM(L)=GEO(J,I) 
      NVAR=NUMAT*3 
C 
C DETERMINE DAMPING FACTOR 
C 
      IF(INDEX(KEYWRD,'DRC=').NE.0) THEN 
         HALF=READA(KEYWRD,INDEX(KEYWRD,'DRC=')) 
         WRITE(6,'(//10X,'' DAMPING FACTOR FOR KINETIC ENERGY ='',F12.6) 
     1')HALF 
      ELSE 
         HALF=1.D6 
      ENDIF 
      HALF=MAX(0.0001D0,HALF) 
C 
C DETERMINE EXCESS KINETIC ENERGY 
C 
      IF(INDEX(KEYWRD,'KINE').NE.0) THEN 
         ADDONK=READA(KEYWRD,INDEX(KEYWRD,'KINE')) 
         WRITE(6,'(//10X,'' EXCESS KINETIC ENERGY ENTERED INTO SYSTEM =' 
     1',F12.6)')ADDONK 
      ELSE 
         ADDONK=0.D0 
      ENDIF 
C 
C   LOOP OVER TIME-INTERVALS OF DELTAT SECOND 
C 
      DELTAT=1.D-16 
      QUADR=1.D0 
      TOTIME=0.D0 
      ETOT=0.D0 
      ESCF=0.D0 
      CONST=1.D0 
         I=INDEX(KEYWRD,' T=') 
         IF(I.NE.0) THEN 
            TIM=READA(KEYWRD,I) 
            DO 11 J=I+3,80 
               CH=KEYWRD(J:J) 
               IF( CH .NE. CHDOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) 
     1 THEN 
                  IF( CH .EQ. 'M') TIM=TIM*60 
                  GOTO 21 
               ENDIF 
   11       CONTINUE 
C             4 SECONDS TO LOAD IN EXECUTABLE] 
   21       TLEFT=TIM-4 
         ELSE 
         TLEFT=3596 
         ENDIF 
      IF( INDEX(KEYWRD,'REST').NE.0)THEN 
C 
C  RESTART FROM A PREVIOUS RUN 
C 
      OPEN(UNIT=9,STATUS='UNKNOWN',FORM='FORMATTED') 
      REWIND 9 
      READ(9,'(A)')ALPHA 
      READ(9,'(8F10.6)')(XPARAM(I),I=1,NVAR) 
      READ(9,'(A)')ALPHA 
      READ(9,'(8F10.1)')(VELO0(I),I=1,NVAR) 
      READ(9,'(A)')ALPHA 
      READ(9,*)(GRAD(I),I=1,NVAR) 
      READ(9,*)(GROLD(I),I=1,NVAR) 
      READ(9,*)(GROLD2(I),I=1,NVAR) 
      READ(9,*)(PARREF(I),I=1,NVAR) 
      READ(9,*)ETOT,ESCF,EKIN,DELOLD,DELTAT,DLOLD2,ILOOP, 
     +TOTIME,OLDT,TREF,OLDH,OLDT,REFSCF 
      WRITE(6,'(//10X,''CALCULATION RESTARTED, CURRENT'', 
     +'' KINETIC ENERGY='',F10.5,//)')EKIN 
      ELSE 
      ILOOP=1 
      ENDIF 
      IUPPER=ILOOP+399 
      DO 230 ILOOP=ILOOP,IUPPER 
C 
C  MOVEMENT OF ATOMS WILL BE PROPORTIONAL TO THE AVERAGE VELOCITIES 
C  OF THE ATOMS BEFORE AND AFTER TIME INTERVAL 
C 
         DO 30 I=1,NVAR 
   30    VOLD(I)=VELO0(I) 
C 
C   KINETIC ENERGY = 1/2 * M * V * V 
C                  = 0.5 / (4.184D10) * M * V * V 
C   NEW VELOCITY = OLD VELOCITY + GRADIENT * TIME / MASS 
C                = KCAL/ANGSTROM*SECOND/(ATOMIC WEIGHT) 
C                =4.184*10**10(ERGS)*10**8(PER CM)*DELTAT(SECONDS) 
C   NEW POSITION = OLD POSITION - AVERAGE VELOCITY * TIME INTERVAL 
C 
C 
C   ESTABLISH REFERENCE TOTAL ENERGY 
C 
         ERROR=(ETOT-(EKIN+ESCF)) 
         IF(ILOOP.GT.2)THEN 
            QUADR = 1.D0+ERROR/(EKIN*CONST+0.001D0)*0.5D0 
C#      WRITE(6,'(''   QUADR'',3F13.6)')QUADR,ERROR,EKIN 
            QUADR = MIN(1.3D0,MAX(0.8D0,QUADR)) 
         ELSE 
            QUADR=1.D0 
         ENDIF 
         IF(EKIN.GT.0.2.AND.ADDK)THEN 
            ETOT=ETOT+ADDONK 
            ADDK=.FALSE. 
         ENDIF 
         EKOLD=EKIN 
         IF(EKIN.GT.0.2.AND.ADDK)THEN 
C 
C   DUMP IN EXCESS KINETIC ENERGY 
C 
            ETOT=ETOT+ADDONK 
            ADDK=.FALSE. 
         ENDIF 
         DLOLD2=DELOLD 
         DELOLD=DELTAT 
C 
C  CALCULATE THE DURATION OF THE NEXT STEP. 
C 
         IF(CONST.GT.0.99D0) THEN 
            DELTAT= MAX(DELTAT*(MIN(1.5D0,0.0005D0*ACCU/ABS(ERROR+1.D-11 
     1))),1.D-16) 
         ELSE 
            DELTAT=ACCU*1.D-15 
         ENDIF 
         EROLD=ERROR 
C 
C  IF DAMPING IS USED, CALCULATE THE NEW TOTAL ENERGY AND 
C  THE RATIO FOR REDUCING THE KINETIC ENERGY 
C 
         CONST=0.5D0**(DELTAT*1.D14/HALF) 
         ETOT=ETOT-EKIN*(1-CONST) 
         CONST=SQRT(CONST) 
C 
         VELVEC=0.D0 
         EKIN=0.D0 
C#      WRITE(6,*)' VELOCITY, FIRST DERIV AND SECOND DERIV' 
C#      WRITE(6,'(6E13.4)')(VELO0(J),J=1,NVAR) 
         DELTA1=DELTAT+DELOLD 
         DELTA2=DELTA1+DLOLD2 
         DO 40 I=1,NVAR 
C 
C   CALCULATE COMPONENTS OF VELOCITY AS 
C   V = V(0) + V'*T + V"*T*T 
C   WE NEED ALL THREE TERMS, V(0), V' AND V" 
C 
            VELO1(I) = 1.D0/ATMASS(LOC(1,I))*GRAD(I) 
            VELO2(I) = 1.D0/ATMASS(LOC(1,I))* 
     1                 (GRAD(I)-GROLD(I))/DELOLD 
            IF(ILOOP.GT.3) VELO3(I) = 2.D0/ATMASS(LOC(1,I))* 
     1      ((DELTAT-DELTA2)*(GRAD(I)-GROLD(I)) 
     2      -(DELTAT-DELTA1)*(GRAD(I)-GROLD2(I)))/ 
     3      ((1.D30*DELTAT**2-1.D30*DELTA1**2)*(DELTAT-DELTA2) 
     4      -(1.D30*DELTAT**2-1.D30*DELTA2**2)*(DELTAT-DELTA1)) 
C 
C  MOVE ATOMS THROUGH DISTANCE EQUAL TO VELOCITY * DELTA-TIME, NOTE 
C  VELOCITY CHANGES FROM START TO FINISH, THEREFORE AVERAGE. 
C 
            PAROLD(I)=XPARAM(I) 
            XPARAM(I)=XPARAM(I) 
     1             -1.D8*(DELTAT*VELO0(I) 
     2             +0.5D0*DELTAT**2*VELO1(I) 
     3             +0.3333333D0*DELTAT**3*VELO2(I) 
     4             +0.25D0*DELTAT**2*(1.D30*DELTAT**2)*VELO3(I)) 
C 
C   CORRECT ERRORS DUE TO CUBIC COMPONENTS IN ENERGY GRADIENT, 
C   ALSO TO ADD ON EXCESS ENERGY, IF NECESSARY. 
C 
            VELO0(I)=VELO0(I) *  QUADR 
            VELVEC=VELVEC+VELO0(I)**2 
C 
C   MODIFY VELOCITY IN LIGHT OF CURRENT ENERGY GRADIENTS. 
C 
C   VELOCITY = OLD VELOCITY + (DELTA-T / ATOMIC MASS) * CURRENT GRADIENT 
C                           + 1/2 *(DELTA-T * DELTA-T /ATOMIC MASS) * 
C                             (SLOPE OF GRADIENT) 
C              SLOPE OF GRADIENT = (GRAD(I)-GROLD(I))/DELOLD 
C 
C 
C   THIS EXPRESSION IS ACCURATE TO SECOND ORDER IN TIME. 
C 
            VELO0(I) = VELO0(I) + DELTAT*VELO1(I) + 0.5D0*DELTAT**2*VELO 
     12(I)                 + 0.3333333D0*DELTAT*(1.D30*DELTAT**2)*VELO3( 
     2I) 
C 
C  CALCULATE KINETIC ENERGY (IN 2*ERGS AT THIS POINT) 
C 
            EKIN=EKIN+VELO0(I)**2*ATMASS(LOC(1,I)) 
   40    CONTINUE 
C 
C  CONVERT ENERGY INTO KCAL/MOLE 
C 
         EKIN=0.5*EKIN/4.184D10 
C 
C STORE OLD GRADIENTS FOR DELTA - VELOCITY CALCULATION 
C 
         DO 50 I=1,NVAR 
            GROLD2(I)=GROLD(I) 
            GROLD(I)=GRAD(I) 
   50    GRAD(I)=0.D0 
C 
C   CALCULATE ENERGY AND GRADIENTS 
C 
         CALL COMPFG(XPARAM,ESCF,FAIL,GRAD,.TRUE.) 
         IF(FAIL) STOP 
C 
C   CONVERT GRADIENTS INTO ERGS/CM 
C 
         DO 60 I=1,NVAR 
   60    GRAD(I)=GRAD(I)*4.184D18 
C 
C   SPECIAL TREATMENT FOR FIRST POINT - SET "OLD" GRADIENTS EQUAL TO 
C   CURRENT GRADIENTS. 
C 
         IF(ILOOP.EQ.1) THEN 
            DO 70 I=1,NVAR 
   70       GROLD(I)=GRAD(I) 
         ENDIF 
C 
C   GO THROUGH THE CRITERIA FOR DECIDING WHETHER OR NOT TO PRINT THIS 
C   POINT.  IF YES, THEN ALSO CALCULATE THE EXACT POINT AS A FRACTION 
C   BETWEEN THE LAST POINT AND THE CURRENT POINT 
C 
         FRACT=-1.D-4 
         NFRACT=1 
         IF(OLDH.EQ.0)OLDH=ESCF 
         IF(STEPH.EQ.0)GOTO 80 
C 
C   CRITERION FOR PRINTING RESULTS  IS A CHANGE IN HEAT OF FORMATION = 
C   -CHANGE IN KINETIC ENERGY 
C 
         IF(REFSCF.EQ.0.D0) THEN 
            I=ESCF/STEPH 
            REFSCF=I*STEPH 
         ENDIF 
         IF(ABS(ESCF-REFSCF).GT.STEPH)THEN 
C 
C   FRACT IS THE FRACTIONAL DISTANCE FROM THE OLD TO THE NEW POINT 
C   FOR THE FIRST POINT TO BE PRINTED 
C 
C   FINCR IS THE DISTANCE BETWEEN ANY TWO POINTS TO BE PRINTED 
C 
C   NFRACT IS THE NUMBER OF POINTS TO BE PRINTED IN THE CURRENT DOMAIN 
C 
            FRACT=(REFSCF+SIGN(STEPH,ESCF-OLDH)-OLDH)/(ESCF-OLDH) 
            FINCR=STEPH/ABS(ESCF-OLDH) 
            NFRACT=(ESCF-REFSCF)/STEPH 
            REFSCF=REFSCF+STEPH*NFRACT 
            NFRACT=ABS(NFRACT) 
         ENDIF 
         GOTO 140 
   80    IF(STEPT.EQ.0.D0) GOTO 90 
C 
C   CRITERION FOR PRINTING RESULTS IS A CHANGE IN TIME. 
C 
         IF(ABS(TOTIME-TREF).GT.STEPT)THEN 
            FRACT = (TREF+STEPT-OLDT) / (TOTIME-OLDT) 
            FINCR=STEPT/(TOTIME-OLDT) 
            NFRACT= (TOTIME-TREF)/STEPT 
            TREF=TREF+NFRACT*STEPT 
         ENDIF 
         GOTO 140 
   90    IF(STEPX.EQ.0.D0)GOTO 130 
C 
C   CRITERION FOR PRINTING RESULTS IS A CHANGE IN GEOMETRY. 
C 
         XOLD=XNOW 
         XNOW=0.D0 
         L=0 
         DO 110 I=1,NUMAT 
            SUM=0.D0 
            DO 100 J=1,3 
               L=L+1 
  100       SUM=SUM+(PARREF(L)-XPARAM(L))**2 
  110    XNOW=XNOW+SQRT(SUM) 
         IF(XNOW.GT.STEPX)THEN 
            NFRACT=XNOW/STEPX 
            SHIFT = STEPX*NFRACT 
            DO 120 J=1,NVAR 
  120       PARREF(J)=PARREF(J)+(XPARAM(J)-PARREF(J))/XNOW*NFRACT*STEPX 
            FRACT = (STEPX-XOLD)/(XNOW-XOLD) 
            FINCR=STEPX/(XNOW-XOLD) 
            XNOW=XNOW-NFRACT*STEPX 
            IF(ILOOP.EQ.1)NFRACT=1 
         ENDIF 
         GOTO 140 
C 
C   PRINT EVERY POINT. 
C 
  130    FRACT=1.0 
  140    IF(ILOOP.NE.1.AND.FRACT.LT.0.D0)GOTO 221 
         FRACT=FRACT-FINCR 
C 
C  LOOP OVER ALL POINTS IN CURRENT DOMAIN 
C 
         DO 220 II=1,NFRACT 
            FRACT=FRACT+FINCR 
            TPOINT = (1.D0-FRACT)*OLDT + FRACT*TOTIME 
            HPOINT = (1.D0-FRACT)*OLDH + FRACT*ESCF 
            POINTK = (1.D0-FRACT)*OLDK + FRACT*EKIN 
            L=0 
            DO 150 I=1,NUMAT 
               DO 150 J=1,3 
                  L=L+1 
  150       GEO(J,I)=(1.D0-FRACT)*PAROLD(L) + FRACT*XPARAM(L) 
            LPOINT=LPOINT+1 
            IF(ETOT.EQ.0)ETOT=ESCF+EKIN 
            IF(LPOINT.EQ.1)THEN 
               WRITE(6,'(//,'' TIME IN FEMTOSECONDS  POINT  POTENTIAL +' 
     1','' KINETIC  =  TOTAL     ERROR    REF%'')') 
            ELSE 
               WRITE(6,'(//,'' TIME IN FEMTOSECONDS  POINT  POTENTIAL +' 
     1','' KINETIC  =  TOTAL     ERROR    REF'')') 
            ENDIF 
            WRITE(6,'(F10.3,I16,F12.5,F11.5,F11.5, F10.5,''   '' 
     1,I3,''%'')')TPOINT*1.D15, ILOOP, HPOINT, POINTK, HPOINT+POINTK, 
     2HPOINT+POINTK-ETOT, LPOINT 
C#     1,HPOINT+POINTK-ETOT,HPOINT,POINTK,HPOINT+POINTK 
            WRITE(6,*)'                CARTESIAN GEOMETRY 
     1 '//'VELOCITY (IN CM/SEC)' 
            WRITE(6,*)'  ATOM        X          Y          Z 
     1    '//'X          Y          Z' 
            DO 160 I=1,NUMAT 
               LL=(I-1)*3+1 
               LU=LL+2 
               HPOINT = (1.D0-FRACT)*OLDH + FRACT*ESCF 
               WRITE(6,'(I4,3X,A2,3F11.5,2X,3F11.1)') 
     1I, ELEMNT(NAT(I)),(GEO(J,I),J=1,3), 
     2((1.D0-FRACT)*VOLD(L) + FRACT*VELO0(L),L=LL,LU) 
  160       CONTINUE 
            CALL CHRGE(P,Q2) 
            DO 170 I=1,NUMAT 
               L=NAT(I) 
  170       Q2(I)=CORE(L) - Q2(I) 
            CALL XYZINT(GEO,NATOMS,NA,NB,NC,1.D0,COORDS) 
            DEGREE=57.29577951D0 
            COORDS(2,1)=0.D0 
            COORDS(3,1)=0.D0 
            COORDS(1,1)=0.D0 
            COORDS(2,2)=0.D0 
            COORDS(3,2)=0.D0 
            COORDS(3,3)=0.D0 
            IVAR=1 
            NA(1)=0 
            L=0 
            WRITE(6,'(//10X,''FINAL GEOMETRY OBTAINED'',33X,''CHARGE'')' 
     1) 
            WRITE(6,'(1X,A)')KEYWRD,KOMENT,TITLE 
            DO 200 I=1,NATOMS 
               J=I/26 
               ALPHA(1:1)=CHAR(ICHAR('A')+J) 
               J=I-J*26 
               ALPHA(2:2)=CHAR(ICHAR('A')+J-1) 
               DO 180 J=1,3 
  180          IEL1(J)=0 
  190          CONTINUE 
               IF(LOC(1,IVAR).EQ.I) THEN 
                  IEL1(LOC(2,IVAR))=1 
                  IVAR=IVAR+1 
                  GOTO 190 
               ENDIF 
               IF(I.LT.4) THEN 
                  IEL1(3)=0 
                  IF(I.LT.3) THEN 
                     IEL1(2)=0 
                     IF(I.LT.2) THEN 
                        IEL1(1)=0 
                     ENDIF 
                  ENDIF 
               ENDIF 
               IF(I.EQ.LATOM)IEL1(LPARAM)=-1 
               Q(1)=COORDS(1,I) 
               Q(2)=COORDS(2,I)*DEGREE 
               Q(3)=COORDS(3,I)*DEGREE 
               IF(LABELS(I).LT.99)THEN 
                  L=L+1 
                  WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3,F13.4,I5,A)') 
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I),Q2(L) 
     2    ,LPOINT,ALPHA//'*' 
               ELSE 
                  WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3,13X,I5,A)') 
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I) 
     2    ,LPOINT,ALPHA//'%' 
               ENDIF 
  200       CONTINUE 
            NA(1)=99 
            WRITE(6,*) 
            WRITE(6,*) 
  210       CONTINUE 
  220    CONTINUE 
  221    OLDT=TOTIME 
         TOTIME=TOTIME+DELTAT 
         OLDH=ESCF 
         XOLD=XNOW 
         OLDK=EKIN 
      OLDTIM=TNOW 
      CALL SECOND (TNOW) 
      TCYCLE=TNOW-OLDTIM 
      TLEFT=TLEFT-TCYCLE 
      IF (ILOOP.EQ.IUPPER.OR.TLEFT.LT.3*TCYCLE) THEN 
      OPEN(UNIT=9,STATUS='UNKNOWN',FORM='FORMATTED') 
      REWIND 9 
      OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 10 
      WRITE(9,'(A)')' CARTESIAN GEOMETRY PARAMETERS IN ANGSTROMS' 
      WRITE(9,'(8F10.6)')(XPARAM(I),I=1,NVAR) 
      WRITE(9,'(A)')' VELOCITY FOR EACH CARTESIAN COORDINATE, IN CM/SEC' 
      WRITE(9,'(8F10.1)')(VELO0(I),I=1,NVAR) 
      WRITE(9,'(A)')' FIRST, SECOND, AND THIRD-ORDER GRADIENTS, ETC' 
      WRITE(9,*)(GRAD(I),I=1,NVAR) 
      WRITE(9,*)(GROLD(I),I=1,NVAR) 
      WRITE(9,*)(GROLD2(I),I=1,NVAR) 
      WRITE(9,*)(PARREF(I),I=1,NVAR) 
      I=ILOOP+1 
      WRITE(9,*)ETOT,ESCF,EKIN,DELOLD,DELTAT,DLOLD2,I, 
     +TOTIME,OLDT,TREF,OLDH,OLDT,REFSCF 
         LINEAR=(NORBS*(NORBS+1))/2 
         WRITE(10)(PA(I),I=1,LINEAR) 
         IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR) 
      WRITE(6,'(//10X,'' RUNNING OUT OF TIME, RESTART FILE WRITTEN'')') 
      STOP 
      ENDIF 
  230 CONTINUE 
      END 
      SUBROUTINE ENPART(UHF,H,ALPHA,BETA,P,Q,COORD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      PARAMETER (NATMS2 = (NUMATM*(NUMATM+1))/2) 
      DIMENSION H(*), ALPHA(*), BETA(*), P(*), Q(*), COORD(3,*) 
      LOGICAL UHF, MINDO3, AM1, IEQJ, KEQL 
      CHARACTER*80 KEYWRD 
C*********************************************************************** 
C 
C *** ENERGY PARTITIONING WITHIN THE UMINDO/3 AND UMNDO SCHEME 
C     ROUTINE WRITTEN BY S.OLIVELLA, BARCELONA NOV. 1979. 
C 
C   ON INPUT UHF     = .TRUE. IF A U.H.F. CALCULATION. 
C            H       = ONE-ELECTRON MATRIX. 
C            ALPHA   = ALPHA ELECTRON DENSITY. 
C            BETA    = BETA ELECTRON DENSITY. 
C            P       = TOTAL ELECTRON DENSITY. 
C            Q       = ATOM ELECTRON DENSITIES. 
C 
C    NOTHING IS CHANGED ON EXIT. 
C 
C*********************************************************************** 
      COMMON /ONELEC/ USS(107), UPP(107), UDD(107) 
      COMMON /CORE  / CORE(107) 
      COMMON /IDEAS / FN1(107,10),FN2(107,10),FN3(107,10),NFN(107) 
      COMMON /ALPHA3/ ALP3(153) 
      COMMON /TWOEL3/ F03(107) 
      COMMON /ALPHA / ALP(107) 
      COMMON /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     1                ,GSD(107),GPD(107),GDD(107) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM),NORBS,NELECS, 
     2                NALPHA,NBETA,NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /WMATRX/ W(N2ELEC*3),KDUMMY,NBAND(NUMATM) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /SCRACH/ EA(NUMATM,2),EAT(NUMATM), E(NATMS2,4), WAB(100) 
       SAVE
      MINDO3=(INDEX(KEYWRD,'MINDO3').NE.0) 
C 
C *** RECALCULATE THE DENSITY MATRICES IN THE UHF SCHEME 
C 
      LINEAR=NORBS*(NORBS+1)/2 
      IF( .NOT. UHF) THEN 
         DO 10 I=1,LINEAR 
   10    BETA(I)=ALPHA(I) 
      ENDIF 
C 
C *** ONE-CENTRE ENERGIES 
      K=0 
      DO 30 I=1,NUMAT 
         IA=NFIRST(I) 
         IB=NLAST(I) 
         NI=NAT(I) 
         EA(I,1)=0.0 
         DO 20 J=IA,IB 
            K=K+J 
            T=UPP(NI) 
            IF(J.EQ.IA) T=USS(NI) 
   20    EA(I,1)=EA(I,1)+P(K)*T 
         ISS=(IA*(IA+1))/2 
         EA(I,2)=0.5*GSS(NI)*P(ISS)*P(ISS) 
     1  -0.5*GSS(NI)*(ALPHA(ISS)*ALPHA(ISS)+BETA(ISS)*BETA(ISS)) 
         IF(IA.EQ.IB) GO TO 30 
         IA1=IA+1 
         IA2=IA+2 
         IXX=IA1*IA2/2 
         IYY=IA2*IB/2 
         IZZ=(IB*(IB+1))/2 
         IXY=IA1+IA2*IA1/2 
         IXZ=IA1+IB*IA2/2 
         IYZ=IA2+IB*IA2/2 
         ISX=IA+IA1*IA/2 
         ISY=IA+IA2*IA1/2 
         ISZ=IA+IB*IA2/2 
         SS1=P(IXX)*P(IXX)+P(IYY)*P(IYY)+P(IZZ)*P(IZZ) 
         SS2=P(ISS)*(P(IXX)+P(IYY)+P(IZZ)) 
         SS3=P(IXX)*P(IYY)+P(IXX)*P(IZZ)+P(IYY)*P(IZZ) 
         SS4=P(ISX)*P(ISX)+P(ISY)*P(ISY)+P(ISZ)*P(ISZ) 
         SS5=P(IXY)*P(IXY)+P(IXZ)*P(IXZ)+P(IYZ)*P(IYZ) 
         TT1=ALPHA(IXX)*ALPHA(IXX)+ALPHA(IYY)*ALPHA(IYY) 
     1+ALPHA(IZZ)*ALPHA(IZZ)+BETA(IXX)*BETA(IXX) 
     2+BETA(IYY)*BETA(IYY)+BETA(IZZ)*BETA(IZZ) 
         TT2=ALPHA(ISS)*(ALPHA(IXX)+ALPHA(IYY)+ALPHA(IZZ)) 
     1   +BETA(ISS)*(BETA(IXX)+BETA(IYY)+BETA(IZZ)) 
         TT3=ALPHA(IXX)*ALPHA(IYY)+ALPHA(IXX)*ALPHA(IZZ) 
     1+ALPHA(IYY)*ALPHA(IZZ)+BETA(IXX)*BETA(IYY) 
     2+BETA(IXX)*BETA(IZZ)+BETA(IYY)*BETA(IZZ) 
         TT4=ALPHA(ISX)*ALPHA(ISX)+ALPHA(ISY)*ALPHA(ISY) 
     1+ALPHA(ISZ)*ALPHA(ISZ)+BETA(ISX)*BETA(ISX) 
     2+BETA(ISY)*BETA(ISY)+BETA(ISZ)*BETA(ISZ) 
         TT5=ALPHA(IXY)*ALPHA(IXY)+ALPHA(IXZ)*ALPHA(IXZ) 
     1+ALPHA(IYZ)*ALPHA(IYZ)+BETA(IXY)*BETA(IXY) 
     2+BETA(IXZ)*BETA(IXZ)+BETA(IYZ)*BETA(IYZ) 
         EA(I,2)=EA(I,2)+0.5*GPP(NI)*SS1+GSP(NI)*SS2 
     1+GP2(NI)*SS3+HSP(NI)*SS4*2.0+0.5D0*(GPP(NI)-GP2(NI))*SS5*2.0 
     2                -0.5*GPP(NI)*TT1-GSP(NI)*TT4-GP2(NI)*TT5- 
     3        HSP(NI)*(TT2+TT4)-0.5D0*(GPP(NI)-GP2(NI))*(TT3+TT5) 
   30 CONTINUE 
      AM1=(INDEX(KEYWRD,'AM1').NE.0) 
      IF(MINDO3) THEN 
         WRITE(6,'(//,10X,''TOTAL ENERGY PARTITIONING IN MINDO/3'')') 
      ELSEIF( AM1 ) THEN 
         WRITE(6,'(//,10X,''TOTAL ENERGY PARTITIONING IN AM1'')') 
      ELSE 
         WRITE(6,'(//,10X,''TOTAL ENERGY PARTITIONING IN MNDO'')') 
      ENDIF 
      WRITE(6,'(/,'' ONE-CENTRE ENERGIES (EV)'')') 
      K=1 
      KL=NUMAT 
      IF(NUMAT.GT.7) KL=7 
   40 WRITE(6,50)(I,I=K,KL) 
   50 FORMAT(/,'  ATOM  ',7(I7,3X)) 
      WRITE(6,60)(EA(I,1),I=K,KL) 
   60 FORMAT(/,'  EA U  ',7F10.3) 
      WRITE(6,70)(EA(I,2),I=K,KL) 
   70 FORMAT(/,'  EA E  ',7F10.3) 
      DO 80 I=K,KL 
   80 EAT(I)=EA(I,1)+EA(I,2) 
      WRITE(6,90)(EAT(I),I=K,KL) 
   90 FORMAT(/,'  TOTAL ',7F10.3) 
      IF(NUMAT.LE.KL) GO TO 100 
      K=KL+1 
      KL=K+6 
      GO TO 40 
  100 EAU=0.0 
      EAE=0.0 
      DO 110 I=1,NUMAT 
         NI=NAT(I) 
         EAU=EAU+EA(I,1) 
  110 EAE=EAE+EA(I,2) 
      TONE=EAU+EAE 
      EABE=0.0 
      EABV=0.0 
      EABN=0.0 
      EABR=0.0 
C *** TWO-CENTRE ENERGIES 
C     RESONANCE TERMS 
      N=1 
      DO 130 II=2,NUMAT 
         IA=NFIRST(II) 
         IB=NLAST(II) 
         IMINUS=II-1 
         DO 120 JJ=1,IMINUS 
            N=N+1 
            JA=NFIRST(JJ) 
            JB=NLAST(JJ) 
            E(N,1)=0.0 
            DO 120 I=IA,IB 
               KA=(I*(I-1))/2 
               DO 120 K=JA,JB 
                  IK=KA+K 
  120    E(N,1)=E(N,1)+2.0*P(IK)*H(IK) 
  130 N=N+1 
C 
C     THE CODE THAT FOLLOWS APPLIES ONLY TO MNDO 
C 
      IF(.NOT.MINDO3) THEN 
C     CORE ATTRACTION AND CORE REPULSION TERMS 
         N=1 
         NROW=0 
         IPQRS=1 
         DO 210 II=2,NUMAT 
            IA=NFIRST(II) 
            IB=NLAST(II) 
            NI=NAT(II) 
            ISS=(IA*(IA+1))/2 
            IMINUS=II-1 
            NROW=NROW+NBAND(IMINUS) 
            NCOL=NBAND(II) 
            NBAND2=0 
            DO 200 JJ=1,IMINUS 
               NBAND1=NBAND2+1 
               NBAND2=NBAND2+NBAND(JJ) 
               CALL WNONCA (WAB,W(IPQRS),NROW,NCOL,NBAND1,NBAND2) 
               KK=0 
               N=N+1 
               JA=NFIRST(JJ) 
               JB=NLAST(JJ) 
               NJ=NAT(JJ) 
               JSS=(JA*(JA+1))/2 
               KK=KK+1 
               G=WAB(KK)*4.D0 
               R=SQRT((COORD(1,II)-COORD(1,JJ))**2+(COORD(2,II)-COORD(2, 
     1                 JJ))**2+  (COORD(3,II)-COORD(3,JJ))**2) 
               SCALE=1.0+EXP(-ALP(NI)*R)+EXP(-ALP(NJ)*R) 
               NT=NI+NJ 
               IF(NT.LT.8.OR.NT.GT.9) GO TO 140 
               IF(NI.EQ.7.OR.NI.EQ.8) SCALE=SCALE+(R-1.0)*EXP(-ALP(NI)*R 
     1) 
               IF(NJ.EQ.7.OR.NJ.EQ.8) SCALE=SCALE+(R-1.0)*EXP(-ALP(NJ)*R 
     1) 
  140          E(N,2)=CORE(NI)*CORE(NJ)*G*SCALE 
               IF( AM1 )THEN 
                  SCALE=0 
                  DO 150 IG=1,NFN(NI) 
  150             SCALE=SCALE + 
     1            FN1(NI,IG)*EXP(-FN2(NI,IG)*(R-FN3(NI,IG))**2) 
                  DO 151 IG=1,NFN(NJ) 
  151             SCALE=SCALE + 
     1            FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(R-FN3(NJ,IG))**2) 
                  E(N,2)=E(N,2)+SCALE*CORE(NI)*CORE(NJ)/R 
               ENDIF 
               E(N,3)=-(P(ISS)*CORE(NJ)+P(JSS)*CORE(NI))*G 
               IF(NJ.LT.3) GO TO 170 
               KINC=9 
               JAP1=JA+1 
               DO 160 K=JAP1,JB 
                  KC=(K*(K-1))/2 
                  DO 160 L=JA,K 
                     KL=KC+L 
                     BB=2.0D0 
                     IF(K.EQ.L) BB=1.0D0 
                     KEQL=K.EQ.L 
                     KK=KK+1 
                     G=WAB(KK)*2.D0 
                     IF(KEQL) G=G*2.D0 
  160          E(N,3)=E(N,3)-P(KL)*CORE(NI)*BB*G 
               GO TO 180 
  170          KINC=0 
  180          IF(NI.LT.3) GO TO 200 
               IAP1=IA+1 
               DO 190 I=IAP1,IB 
                  KA=(I*(I-1))/2 
                  DO 190 J=IA,I 
                     IJ=KA+J 
                     AA=2.0D0 
                     IF(I.EQ.J) AA=1.0D0 
                     IEQJ=I.EQ.J 
                     KK=KK+1 
                     G=WAB(KK)*2.D0 
                     IF (IEQJ) G=G*2.D0 
                     E(N,3)=E(N,3)-P(IJ)*CORE(NJ)*AA*G 
  190          KK=KK+KINC 
  200       CONTINUE 
            IPQRS=IPQRS+NROW*NCOL 
  210    N=N+1 
C     COULOMB AND EXCHANGE TERMS 
         N=1 
         NROW=0 
         IPQRS=1 
         DO 230 II=2,NUMAT 
            IA=NFIRST(II) 
            IB=NLAST(II) 
            IMINUS=II-1 
            NROW=NROW+NBAND(IMINUS) 
            NCOL=NBAND(II) 
            NBAND2=0 
            DO 220 JJ=1,IMINUS 
               NBAND1=NBAND2+1 
               NBAND2=NBAND2+NBAND(JJ) 
               CALL WNONCA (WAB,W(IPQRS),NROW,NCOL,NBAND1,NBAND2) 
               KK=0 
               JA=NFIRST(JJ) 
               JB=NLAST(JJ) 
               N=N+1 
               E(N,4)=0.0 
               DO 220 I=IA,IB 
                  KA=(I*(I-1))/2 
                  DO 220 J=IA,I 
                     KB=(J*(J-1))/2 
                     IJ=KA+J 
                     AA=2.0D0 
                     IF(I.EQ.J) AA=1.0D0 
                     IEQJ=I.EQ.J 
                     PIJ=P(IJ) 
                     DO 220 K=JA,JB 
                        KC=(K*(K-1))/2 
                        IK=KA+K 
                        JK=KB+K 
                        DO 220 L=JA,K 
                           IL=KA+L 
                           JL=KB+L 
                           KL=KC+L 
                           BB=2.0D0 
                           IF(K.EQ.L) BB=1.0D0 
                           KEQL=K.EQ.L 
                           KK=KK+1 
                           G=WAB(KK) 
                           IF (IEQJ) G=G*2.D0 
                           IF (KEQL) G=G*2.D0 
  220       E(N,4)=    AA*BB*G*PIJ*P(KL)+E(N,4) 
     1            -0.5*AA*BB*G*(ALPHA(IK)*ALPHA(JL)+ALPHA(IL)*ALPHA(JK) 
     2                         +BETA(IK) *BETA (JL)+BETA (IL)*BETA (JK)) 
            IPQRS=IPQRS+NROW*NCOL 
  230    N=N+1 
      ELSE 
         N=1 
         DO 290 I=2,NUMAT 
            IA=NFIRST(I) 
            IB=NLAST(I) 
            NI=NAT(I) 
            IMINUS=I-1 
            DO 280 J=1,IMINUS 
               N=N+1 
               JA=NFIRST(J) 
               JB=NLAST(J) 
               NJ=NAT(J) 
               RIJ=(COORD(1,I)-COORD(1,J))**2+(COORD(2,I)-COORD(2,J))**2 
     1+  (COORD(3,I)-COORD(3,J))**2 
               GIJ=14.399D0/SQRT(RIJ+(7.1995D0/F03(NI)+7.1995D0/F03(NJ)) 
     1**2) 
               PAB2=0.0 
               IJ=MAX(NI,NJ) 
               NBOND=(IJ*(IJ-1))/2+NI+NJ-IJ 
               RIJ=SQRT(RIJ) 
               IF(NBOND.EQ.22 .OR. NBOND .EQ. 29) GO TO 240 
               GO TO 250 
  240          SCALE=ALP3(NBOND)*EXP(-RIJ) 
               GO TO 260 
  250          SCALE=EXP(-ALP3(NBOND)*RIJ) 
  260          CONTINUE 
               E(N,2)=CORE(NI)*CORE(NJ)*GIJ+ 
     1     ABS(CORE(NI)*CORE(NJ)*(14.399D0/RIJ-GIJ)*SCALE) 
               E(N,3)=(-Q(I)*CORE(NJ)-Q(J)*CORE(NI))*GIJ 
               E(N,4)=Q(I)*Q(J)*GIJ 
               DO 270 K=IA,IB 
                  KK=(K*(K-1))/2 
                  DO 270 L=JA,JB 
                     LK=KK+L 
  270          PAB2=PAB2+ALPHA(LK)*ALPHA(LK)+BETA(LK)*BETA(LK) 
  280       E(N,4)=E(N,4)-PAB2*GIJ 
  290    N=N+1 
      ENDIF 
      XC=0.D0 
      XD=0.D0 
      WRITE(6,300) 
  300 FORMAT(/,' TWO-CENTRE ENERGIES (EV)',//,3X,'E( A, B)',5X, 
     11HR,9X,1HN,9X,1HV,9X,1HE,8X,5HTOTAL) 
      DO 360 I=1,NUMAT 
         NI=NAT(I) 
         XA=0.0 
         XB=0.0 
         IP1=I+1 
         DO 350 J=IP1,NUMAT 
            NJ=NAT(J) 
            IJ=I+(J*(J-1))/2 
            XT=E(IJ,1)+E(IJ,2)+E(IJ,3)+E(IJ,4) 
            EABE=EABE+E(IJ,4) 
            EABN=EABN+E(IJ,2) 
            EABV=EABV+E(IJ,3) 
            EABR=EABR+E(IJ,1) 
            R=SQRT((COORD(1,I)-COORD(1,J))**2+(COORD(2,I)-COORD(2,J))**2 
     1+  (COORD(3,I)-COORD(3,J))**2) 
            IF(R.GT.1.9) GO TO 310 
            NT=NI+NJ 
            IF(NT.EQ.2) GO TO 310 
            XB=XB+XT 
            GO TO 320 
  310       XA=XA+XT 
  320       CONTINUE 
  330       WRITE(6,340)I,J,(E(IJ,K),K=1,4),XT 
  340       FORMAT(/,5X,I2,1X,I2,5F10.3) 
  350    CONTINUE 
         XC=XC+XA 
         XD=XD+XB 
  360 CONTINUE 
      XT=XD+XC 
      WRITE(6,370)XD,XC 
  370 FORMAT(//,'  TOTAL SUM NEIGHBORING PAIR INTERACTIONS',10X,F15.4, 
     1//,'  TOTAL SUM NONNEIGHBOR INTERACTIONS (R>1.9 A)',5X,F15.4) 
      ET=EAU+EAE+EABR+EABV+EABN+EABE 
      WRITE(6,380) TONE,XT 
  380 FORMAT(//,'  TOTAL SUM ONE-CENTRE ENERGIES          ',5X,F15.4, 
     1       //,'  TOTAL SUM TWO-CENTRE ENERGIES          ',5X,F15.4) 
      WRITE(6,390) 
  390 FORMAT(///,'  TOTAL SUMS OF ENERGY TERMS:') 
      WRITE(6,400) EAU,EAE,EABV,EABR,EABE,EABN 
  400 FORMAT(//,'  ONE-CENTRE CORE-ELECTRON ATTRACTION',8X,F15.4, 
     1       //,'  ONE-CENTRE ELECTRON-ELECTRON REPULSION',5X,F15.4, 
     2       //,'  TWO-CENTRE CORE-ELECTRON ATTRACTION',8X,F15.4, 
     3       //,'  TWO-CENTRE CORE-ELECTRON RESONANCE ',8X,F15.4, 
     4       //,'  TWO-CENTRE ELECTRON-ELECTRON REPULSION',5X,F15.4, 
     5       //,'  TWO-CENTRE CORE-CORE REPULSION     ',8X,F15.4) 
      WRITE(6,410) ET 
  410 FORMAT(///,10X,'TOTAL ENERGY =',F15.4) 
      IF(UHF) RETURN 
      DO 420 I=1,LINEAR 
  420 ALPHA(I)=P(I) 
      RETURN 
      END 
      SUBROUTINE EXCHNG (A,B,C,D,X,Y,T,Q,N) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION X(*), Y(*) 
C******************************************************************** 
C 
C THE CONTENTS OF A, C, T, AND X ARE STORED IN B, D, Q, AND Y] 
C 
C   THIS IS A DEDICATED ROUTINE, IT IS CALLED BY LINMIN AND LOCMIN ONLY. 
C 
C******************************************************************** 
       SAVE
      B=A 
      D=C 
      Q=T 
      DO 10 I=1,N 
   10 Y(I)=X(I) 
      RETURN 
C 
      END 
      SUBROUTINE FLEPO(XPARAM,NVAR,FUNCT1) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XPARAM(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(3*NUMATM+4),NCLOSE,NOPEN 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /NUMSCF/ NSCF,FROZEN 
      COMMON /LAST  / LAST 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /MESAGE/ IFLEPO,ISCF 
      COMMON /TIME  / TIME0 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,HESINV(MAXHES),XVAR(MAXPAR) 
     .               ,GVAR(MAXPAR),XD(MAXPAR),GD(MAXPAR),GLAST(MAXPAR) 
     .               ,XLAST(MAXPAR),GG(MAXPAR),PVECT(MAXPAR) 
      COMMON /PRECI / SCFCRT,SCFTOL,DUM(9),KDUM(MAXPAR) 
      COMMON /NUMCAL/ NUMCAL 
      CHARACTER*80 KEYWRD 
      CHARACTER SPACE*1, CHDOT*1, ZERO*1, NINE*1, CH*1 
C 
C     * 
C     THIS SUBROUTINE ATTEMPTS TO MINIMIZE A REAL-VALUED FUNCTION OF 
C     THE N-COMPONENT REAL VECTOR XPARAM ACCORDING TO THE 
C     DAVIDON-FLETCHER-POWELL ALGORITHM (COMPUTER JOURNAL, VOL. 6, 
C     P. 163).  THE USER MUST SUPPLY THE SUBROUTINE 
C     COMPFG(XPARAM,FUNCT,FAIL,GRAD,LGRAD) 
C     WHICH COMPUTES FUNCTION VALUES  FUNCT AT GIVEN VALUES FOR THE 
C     VARIABLES XPARAM, AND THE GRADIENT GRAD IF LGRAD=.TRUE. 
C     THE .TRUE. VALUE IS RETURNED IN FAIL IF SCF NOT CONVERGED. 
C     THE MINIMIZATION PROCEEDS BY A SEQUENCE OF ONE-DIMENSIONAL 
C     MINIMIZATIONS.  THESE ARE CARRIED OUT WITHOUT GRADIENT COMPUTATION 
C     BY THE SUBROUTINE LINMIN, WHICH SOLVES THE SUBPROBLEM OF 
C     MINIMIZING THE FUNCTION FUNCT ALONG THE LINE XPARAM+ALPHA*PVECT, 
C     WHERE XPARAM 
C     IS THE VECTOR OF CURRENT VARIABLE VALUES,  ALPHA IS A SCALAR 
C     VARIABLE, AND  PVECT  IS A SEARCH-DIRECTION VECTOR PROVIDED BY THE 
C     DAVIDON-FLETCHER-POWELL ALGORITHM.  EACH ITERATION STEP CARRIED 
C     OUT BY FLEPO PROCEEDS BY LETTING LINMIN FIND A VALUE FOR ALPHA 
C     WHICH MINIMIZES  FUNCT  ALONG  XPARAM+ALPHA*PVECT, BY 
C     UPDATING THE VECTOR  XPARAM  BY THE AMOUNT ALPHA*PVECT, AND 
C     FINALLY BY GENERATING A NEW VECTOR  PVECT.  UNDER 
C     CERTAIN RESTRICTIONS (POWELL, J.INST.MATHS.APPLICS.(1971), 
C     V.7,21-36)  A SEQUENCE OF FUNCT VALUES CONVERGING TO SOME 
C     LOCAL MINIMUM VALUE AND A SEQUENCE OF 
C     XPARAM VECTORS CONVERGING TO THE CORRESPONDING MINIMUM POINT 
C     ARE PRODUCED. 
C                          CONVERGENCE TESTS. 
C 
C     HERBERTS TEST: THE ESTIMATED DISTANCE FROM THE CURRENT POINT 
C                    POINT TO THE MINIMUM IS LESS THAN TOLERA. 
C 
C                    "HERBERTS TEST SATISFIED - GEOMETRY OPTIMISED" 
C 
C     GRADIENT TEST: THE GRADIENT NORM HAS BECOME LESS THAN TOLERG 
C                    TIMES THE SQUARE ROOT OF THE NUMBER OF VARIABLES. 
C 
C                    "TEST ON GRADIENT SATISFIED". 
C 
C     XPARAM TEST:  THE RELATIVE CHANGE IN XPARAM, MEASURED BY ITS NORM, 
C                   OVER ANY TWO SUCCESSIVE ITERATION STEPS DROPS BELOW 
C                   TOLERX. 
C 
C                    "TEST ON XPARAM SATISFIED". 
C 
C     FUNCTION TEST: THE CALCULATED VALUE OF THE HEAT OF FORMATION 
C                    BETWEEN ANY TWO CYCLES IS WITHIN TOLERF OF 
C                    EACH OTHER. 
C 
C                    "HEAT OF FORMATION TEST SATISFIED" 
C 
C     FOR THE GRADIENT, FUNCTION, AND XPARAM TESTS A FURTHER CONDITION, 
C     THAT NO INDIVIDUAL COMPONENT OF THE GRADIENT IS GREATER 
C     THAN TOLERG, MUST BE SATISFIED, IN WHICH CASE THE 
C     CALCULATION EXITS WITH THE MESSAGE 
C 
C                     "PETERS TEST SATISFIED" 
C 
C     AN UNSUCCESSFUL TERMINATION WILL TAKE PLACE AFTER 
C     COMPFG HAS BEEN CALLED MORE TIMES THAN THE USER-SUPPLIED VALUE 
C     OF MAXEND.  IN THIS CASE THE COMMENT 
C 
C                     "*** TERMINATION FROM TOO MANY COUNTS ***" 
C 
C     WILL BE PRINTED, AND FUNCT AND XPARAM WILL CONTAIN THE LAST 
C     FUNCTION VALUE CUM VARIABLE VALUES REACHED. 
C 
C     SIMILAR UNSUCCESSFUL TERMINATIONS WILL TAKE PLACE IF THE COSINE OF 
C     THE SEARCH DIRECTION TO GRADIENT VECTOR IS LESS THAN RST ON TWO 
C     CONSECUTIVE ITERATIONS. 
C 
C     THE DAVIDON-FLETCHER-POWELL ALGORITHM CHOOSES SEARCH DIRECTIONS 
C     ON THE BASIS OF LOCAL PROPERTIES OF THE FUNCTION.  A MATRIX  H, 
C     WHICH IN FLEPO IS PRESET WITH THE IDENTITY, IS MAINTAINED AND 
C     UPDATED AT EACH ITERATION STEP.  THE MATRIX DESCRIBES A LOCAL 
C     METRIC ON THE SURFACE OF FUNCTION VALUES ABOVE THE POINT XPARAM. 
C     THE SEARCH-DIRECTION VECTOR  PVECT  IS SIMPLY A TRANSFORMATION 
C     OF THE GRADIENT  GRAD  BY THE MATRIX H.  THE USER MAY THROW OUT  H 
C     AFTER EACH  NRST ITERATION STEPS (RESTARTING WITH THE IDENTITY) OR 
C     WHENEVER THE COSINE OF THE ANGLE BETWEEN  GRAD  AND PVECT BECOMES 
C     LESS THAN RST. THIS CAN BE SUPPRESSED ENTIRELY IF NRST .GT. MAXEND 
C     AND RST .LT. 0.0.   RESTARTING IS DISCUSSED MARGINALLY IN THE 
C     PAPER BY FLETCHER AND POWELL, BUT THERE ARE NO GOOD RULES ABOUT 
C     WHEN OR WHETHER THIS SHOULD BE DONE FOR ANY GIVEN FUNCTION. 
C 
      DIMENSION MDFP(9),XDFP(9) 
      LOGICAL OKF, OKC, PRINT,  TIME, RESTRT, MINPRT, SADDLE, GEOOK 
     1        ,RESET, FAIL, LGRAD, FROZEN, FULSCF 
      EQUIVALENCE (MDFP(1),JCYC  ),(MDFP(2),JNRST),(MDFP(3),NCOUNT), 
     1            (MDFP(4),LNSTOP),(XDFP(1),ALPHA),(XDFP(2),COS   ), 
     2            (XDFP(3),PNORM ),(XDFP(4),YEAD ),(XDFP(5),DEL   ), 
     3            (XDFP(6),FREPF ),(XDFP(7),CYCMX),(XDFP(8),TOTIME) 
      DATA ICALCN /0/ 
      DATA SPACE,CHDOT,ZERO,NINE /' ','.','0','9'/ 
       SAVE
      IF (ICALCN.NE.NUMCAL) THEN 
         IF(INDEX(KEYWRD,'OLDENS').NE.0) THEN
          OPEN(UNIT=10,
     $         STATUS='UNKNOWN',FORM='UNFORMATTED')
          REWIND 10
         ENDIF
C 
C   THE FOLLOWING CONSTANTS SHOULD BE SET BY THE USER. 
C 
         RST   = 0.05D0 
         MAXEND= 9999 
         TDEL  = 6.D0 
         NRST  = 30 
         SFACT=1.5 
         PMSTE = 0.1D0 
         DELL  = 0.01D0 
         EINC  = 0.3D0 
         IGG1  = 3 
         DEL=DELL 
C 
C    THESE CONSTANTS SHOULD BE SET BY THE PROGRAM. 
C 
         FULSCF = INDEX(KEYWRD,'FULS').NE.0 .OR. NOPEN.GT.NCLOSE .OR. 
     .            INDEX(KEYWRD,'C.I.').NE.0 .OR. 
     .            INDEX(KEYWRD,'PREC').NE.O 
         OKF    = .TRUE. 
         RESTRT = INDEX(KEYWRD,'RESTAR').NE.0 
         GEOOK  = INDEX(KEYWRD,'GEO-OK').NE.0 
         SADDLE = INDEX(KEYWRD,'SADDLE').NE.0 
         MINPRT = INDEX(KEYWRD,'DEBUG').NE.0.AND.SADDLE 
         TIME   = INDEX(KEYWRD,'TIME').NE.0 
         TLEFT=3600 
         TOLERG=1.0D0 
         CONST=1.D0 
         CCN=NVAR 
         IF(INDEX(KEYWRD,'GNORM=').NE.0) THEN 
            TOLERG=READA(KEYWRD,INDEX(KEYWRD,'GNORM=')) 
            ROOTV=1.D0 
            CONST=1.D-10 
         ELSE 
            ROOTV=SQRT(CCN+1.D-5) 
         ENDIF 
         I=INDEX(KEYWRD,' T=') 
         IF(I.NE.0) THEN 
            TIM=READA(KEYWRD,I) 
            DO 10 J=I+3,80 
               CH=KEYWRD(J:J) 
               IF( CH .NE. CHDOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) 
     1 THEN 
                  IF( CH .EQ. 'M') TIM=TIM*60 
                  GOTO 20 
               ENDIF 
   10       CONTINUE 
   20       TLEFT=TIM 
         ENDIF 
         CALL SECOND (TX2) 
         TLEFT=TLEFT-TX2+TIME0 
         PRINT  = (INDEX(KEYWRD,'FLEPO').NE.0).OR.(IMP.GE.1) 
         TOLERX = 0.0001D0*CONST 
         EYEAD  = 0.0010D0*CONST 
         TOLERF = 0.002D0*CONST 
         TOLRG  = TOLERG 
         IF (INDEX(KEYWRD,'FORCE') .NE. 0) THEN 
            TOLERX = 0.00001D0 
            TOLERF = 0.0002D0 
            TOLERG = 0.1D0 
            EYEAD  = 0.00010D0 
         ENDIF 
         IF(INDEX(KEYWRD,'PREC') .NE. 0) THEN 
            TOLERX=TOLERX*0.1D0 
            EYEAD=EYEAD*0.1D0 
            TOLERF=TOLERF*0.1D0 
            TOLERG=TOLERG*0.2D0 
         ENDIF 
         TOLERG=TOLERG/ROOTV 
      ENDIF 
C 
C   THE FOLLOWING CONSTANTS SHOULD BE SET TO SOME ARBITARY LARGE VALUE. 
C 
      YEAD  = 1.D15 
      FREPF = 1.D15 
C 
C     AND FINALLY, THE FOLLOWING CONSTANTS ARE CALCULATED. 
C 
      IHDIM=(NVAR*(NVAR+1))/2 
      CNCADD=1.0D00/ROOTV 
      IF (CNCADD.GT.0.15D00) CNCADD=0.15D00 
C 
C     FIRST, WE INITIALISE THE VARIABLES. 
C 
      JCYC=0 
      LNSTOP=1 
      IREPET=1 
      ALPHA = 1.0D00 
      PNORM=1.0D00 
      JNRST=0 
      CYCMX=0.D0 
      COS=0.0D00 
      TOTIME=0.D0 
      NCOUNT=1 
      FAIL=.FALSE. 
      IF( SADDLE) THEN 
* 
*   WE DON'T NEED HIGH PRECISION DURING A SADDLE-POINT CALCULATION. 
* 
         IF(NVAR.GT.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR))-3.D0 
         IF(GNORM.GT.10.D0)GNORM =10.D0 
         IF(GNORM.GT.1.D0) TOLERG=TOLRG*GNORM 
         WRITE(IPRT,'('' GRADIENT CRITERION IN FLEPO ='',F12.5)')TOLERG 
      ENDIF 
      IF (RESTRT .AND. ICALCN .NE. NUMCAL) THEN 
         MDFP(9)=0 
         CALL DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP) 
         WRITE(IPRT,'(//10X,''TOTAL TIME USED SO FAR:'', 
     1    F13.2,'' SECONDS'')')TOTIME 
         IF(INDEX(KEYWRD,'1SCF') .NE. 0) THEN 
            LGRAD= INDEX(KEYWRD,'GRAD').NE.0 
            CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,LGRAD) 
            IFLEPO=1 
            RETURN 
         ENDIF 
      ELSE 
         TOTIME=0.D0 
C 
C CALCULATE THE VALUE OF THE FUNCTION -> FUNCT1, AND GRADIENTS -> GRAD. 
C NORMAL SET-UP OF FUNCT1 AND GRAD, DONE ONCE ONLY. 
C 
         LGRAD=INDEX(KEYWRD,'1SCF').EQ.0 .OR. INDEX(KEYWRD,'GRAD').NE.0 
         CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,LGRAD) 
         IF(FAIL)STOP 
         CALL SCOPY (NVAR,GRAD,1,GD,1) 
      ENDIF 
      ICALCN=NUMCAL 
      IF (NVAR.NE.0) THEN 
         GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
         CALL SCOPY (NVAR,GRAD,1,GLAST,1) 
         GLNORM=GNORM 
      ENDIF 
      IFLEPO=1 
      IF(INDEX(KEYWRD,'1SCF') .NE. 0) RETURN 
      IFLEPO=2 
      IF(GNORM.LT.TOLERG.OR.NVAR.EQ.0) THEN 
         IF(RESTRT) 
     1 CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
         RETURN 
      ENDIF 
      CALL SECOND (TX1) 
      TLEFT=TLEFT-TX1+TX2 
C     * 
C     START OF EACH ITERATION CYCLE ... 
C     * 
C 
      RESET=.FALSE. 
      GOTO 60 
   40 CONTINUE 
      IF(COS .LT. RST) THEN 
         DO 50 I=1,NVAR 
   50    GD(I)=0.5D0 
      ENDIF 
   60 CONTINUE 
      GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
      JCYC=JCYC+1 
      JNRST=JNRST+1 
      IF (LNSTOP.NE.1 .AND. COS.GT.RST .AND. JNRST.LT.NRST) GOTO 160 
C 
C     * 
C     RESTART SECTION 
C     * 
C 
   70 CONTINUE 
      RESET=.TRUE. 
      DO 80 I=1,NVAR 
         XD(I)=XPARAM(I)-SIGN(DEL,GRAD(I)) 
   80 CONTINUE 
C 
C THIS CALL OF COMPFG IS USED TO CALCULATE THE SECOND-ORDER MATRIX IN H 
C IF THE NEW POINT HAPPENS TO IMPROVE THE RESULT, THEN IT IS KEPT. 
C OTHERWISE IT IS SCRAPPED, BUT STILL THE SECOND-ORDER MATRIX IS O.K. 
C 
      CALL COMPFG (XD,FUNCT2,FAIL,GD,.TRUE.) 
      IF(FAIL)STOP 
      IF(.NOT. GEOOK .AND. SQRT(DOT(GD,GD,NVAR))/GNORM.GT.10. 
     1 AND.GNORM.GT.20.AND.JCYC.GT.2)THEN 
C 
C  THE GEOMETRY IS BADLY SPECIFIED IN THAT MINOR CHANGES IN INTERNAL 
C  COORDINATES LEAD TO LARGE CHANGES IN CARTESIAN COORDINATES, AND THESE 
C  LARGE CHANGES ARE BETWEEN PAIRS OF ATOMS THAT ARE CHEMICALLY BONDED 
C  TOGETHER. 
         WRITE(IPRT,'('' GRADIENTS OF OLD GEOMETRY, GNORM='',F13.6)') 
     .              GNORM 
         WRITE(IPRT,'(6F12.6)')(GRAD(I),I=1,NVAR) 
         GDNORM=SQRT(DOT(GD,GD,NVAR)) 
         WRITE(IPRT,'('' GRADIENTS OF NEW GEOMETRY, GNORM='',F13.6)') 
     .              GDNORM 
         WRITE(IPRT,'(6F12.6)')(GD(I),I=1,NVAR) 
         WRITE(IPRT,'(///20X,''CALCULATION ABANDONED AT THIS POINT]'')') 
         WRITE(IPRT,'(//10X,'' SMALL CHANGES IN INTERNAL COORDINATES ARE 
     .   '',/10X,'' CAUSING A LARGE CHANGE IN THE DISTANCE BETWEEN'',/ 
     .   10X,'' CHEMICALLY-BOUND ATOMS. THE GEOMETRY OPTIMISATION'',/ 
     .   10X,'' PROCEDURE WOULD LIKELY PRODUCE INCORRECT RESULTS'')') 
         CALL GEOUT 
         STOP 
      ENDIF 
      NCOUNT=NCOUNT+1 
      DO 90 I=1,IHDIM 
   90 HESINV(I)=0.0D00 
      II=0 
      DO 120 I=1,NVAR 
         II=II+I 
         GGGGG=GRAD(I)-GD(I) 
         IF (ABS(GGGGG).LT.1.D-12) GO TO 100 
         GGD=ABS(GRAD(I)) 
         IF (FUNCT2.LT.FUNCT1) GGD=ABS(GD(I)) 
         HESINV(II)=SIGN(DEL,GRAD(I))/GGGGG 
         IF (HESINV(II).LT.0.0D00.AND.GGD.LT.1.D-12) GO TO 100 
         IF (HESINV(II).LT.0.0D00) HESINV(II)=(TDEL*DEL)/GGD 
         GO TO 110 
  100    HESINV(II)=0.01D00 
  110    CONTINUE 
         IF (GGD.LT.1.D-12) GGD=1.D-12 
         PMSTEP=ABS(PMSTE/GGD) 
         IF (HESINV(II).GT.PMSTEP) HESINV(II)=PMSTEP 
  120 CONTINUE 
      JNRST=0 
      IF(FUNCT2 .GE. FUNCT1) THEN 
         IF(PRINT)WRITE (IPRT,130) FUNCT1,FUNCT2 
  130    FORMAT (' FUNCTION VALUE=',F13.7, 
     1           '  WILL NOT BE REPLACED BY VALUE=',F13.7,/10X, 
     2           'CALCULATED BY RESTART PROCEDURE',/) 
      ELSE 
         IF( PRINT ) WRITE (IPRT,140) FUNCT1,FUNCT2 
  140    FORMAT (' FUNCTION VALUE=',F13.7, 
     1           ' IS BEING REPLACED BY VALUE=',F13.7,/,10X, 
     2           ' FOUND IN RESTART PROCEDURE',/,6X,'THE CORRESPONDING' 
     3           ,' X VALUES AND GRADIENTS ARE ALSO BEING REPLACED',/) 
         FUNCT1=FUNCT2 
         CALL SCOPY (NVAR,XD,1,XPARAM,1) 
         CALL SCOPY (NVAR,GD,1,GRAD  ,1) 
         GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
      ENDIF 
      GO TO 200 
C 
C     * 
C     UPDATE VARIABLE-METRIC MATRIX 
C     * 
C 
  160 DO 170 I=1,NVAR 
      XVAR(I)=XPARAM(I)-XLAST(I) 
  170 GVAR(I)=GRAD(I)-GLAST(I) 
      CALL SUPDOT(GG,HESINV,GVAR,NVAR,1) 
      YHY=DOT(GG,GVAR,NVAR) 
      SY =DOT(XVAR,GVAR,NVAR) 
      K=0 
      DO 180 I=1,NVAR 
      XVARI=XVAR(I)/SY 
      GGI=GG(I)/YHY 
      DO 180 J=1,I 
      K=K+1 
  180 HESINV(K)=HESINV(K)+XVAR(J)*XVARI-GG(J)*GGI 
C 
C     * 
C     ESTABLISH NEW SEARCH DIRECTION 
C     * 
  200 PNLAST=PNORM 
      CALL SUPDOT(PVECT,HESINV,GRAD,NVAR,1) 
      PNORM=SQRT(DOT(PVECT,PVECT,NVAR)) 
      DOTT=-DOT(PVECT,GRAD,NVAR) 
      DO 210 I=1,NVAR 
  210 PVECT(I)=-PVECT(I) 
      COS=-DOTT/(PNORM*GNORM) 
      IF (JNRST.EQ.0) GO TO 250 
      IF (COS.LE.CNCADD.AND.YEAD.GT.1.0D00) GO TO 230 
      IF (COS.LE.RST) GO TO 230 
      GO TO 250 
  230 PNORM=PNLAST 
      IF( PRINT )WRITE (IPRT,240) COS 
  240 FORMAT (//,5X, 'SINCE COS=',F9.3,5X,'THE PROGRAM WILL GO TO RE', 
     1'START SECTION',/) 
      GO TO 70 
  250 CONTINUE 
      IF ( PRINT ) WRITE (IPRT,260) JCYC,FUNCT1 
  260 FORMAT (1H , 'AT THE BEGINNING OF CYCLE',I5, '  THE FUNCTION VA 
     1LUE IS ',F13.6/, '  THE CURRENT POINT IS ...') 
      IF(PRINT)WRITE (IPRT,270) GNORM,COS 
  270 FORMAT ( '  GRADIENT NORM = ',F10.4/,'  ANGLE COSINE =',F10.4) 
      NTO6=NVAR/6 
      NREM6=NVAR-NTO6*6 
      IINC1=-5 
      IF (NTO6.LT.1.OR. .NOT. PRINT) GO TO 330 
      DO 320 I=1,NTO6 
         WRITE (IPRT,'(/)') 
         IINC1=IINC1+6 
         IINC2=IINC1+5 
         WRITE (IPRT,280) (J,J=IINC1,IINC2) 
         WRITE (IPRT,290) (XPARAM(J),J=IINC1,IINC2) 
         WRITE (IPRT,300) (GRAD(J),J=IINC1,IINC2) 
         WRITE (IPRT,310) (PVECT(J),J=IINC1,IINC2) 
  280    FORMAT (1H ,3X,  1HI,9X,I3,9(8X,I3)) 
  290    FORMAT (1H ,1X, 'XPARAM(I)',1X,F9.4,2X,9(F9.4,2X)) 
  300    FORMAT (1H ,1X, 'GRAD  (I)',F10.4,1X,9(F10.4,1X)) 
  310    FORMAT (1H ,1X, 'PVECT (I)',1X,F9.4,2X,9(F9.4,2X)) 
  320 CONTINUE 
  330 CONTINUE 
      IF (NREM6.LT.1.OR. .NOT. PRINT) GO TO 340 
      WRITE (IPRT,'(/)') 
      IINC1=IINC1+6 
      IINC2=IINC1+(NREM6-1) 
      WRITE (IPRT,280) (J,J=IINC1,IINC2) 
      WRITE (IPRT,290) (XPARAM(J),J=IINC1,IINC2) 
      WRITE (IPRT,300) (GRAD(J),J=IINC1,IINC2) 
      WRITE (IPRT,310) (PVECT(J),J=IINC1,IINC2) 
  340 CONTINUE 
      FI=FUNCT1 
      LNSTOP=0 
      ALPHA=ALPHA*PNLAST/PNORM 
      COSINE=DOT(GRAD,GLAST,NVAR)/(GLNORM*GNORM) 
      CALL SCOPY (NVAR,GRAD,  1,GLAST,1) 
      CALL SCOPY (NVAR,XPARAM,1,XLAST,1) 
      GLNORM=GNORM 
      IF (JNRST.EQ.0) ALPHA=1.0D00 
      YEAD=ABS(ALPHA*DOTT) 
      IF(PRINT)WRITE (IPRT,360) YEAD 
  360 FORMAT (1H , 13H -ALPHA.P.G =,F18.6,/) 
      IF (JNRST.NE.0.AND.YEAD.LT.EYEAD) THEN 
         IF(MINPRT)WRITE (IPRT,370) 
  370    FORMAT(//,10X,'HERBERTS TEST SATISFIED - GEOMETRY OPTIMISED') 
C 
C   FLEPO IS ENDING PROPERLY. THIS IS IMMEDIATELY BEFORE THE RETURN. 
C 
         LAST=1 
         CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
         IFLEPO=3 
         TIME0=TIME0-TOTIME 
         RETURN 
      ENDIF 
C 
C  ONE-DIMENSIONAL SEARCH ALONG THE DIRECTION PVECT. 
C 
C                VARIOUS ATTEMPT TO SAVE TIME : 
C 1)  SCFTOL OVERWRITE THE STANDARD SCF CV CRITERION. 
C 2)  (CLOSED SHELLS WITHOUT C.I. ONLY) CHECK THE ANGLE BETWEEN TWO 
C     SUCCESSIVE GRADIENTS AND DECIDE IF FULL SCF CALCULATION ARE TO 
C     BE DONE. (THRESHOLD = 0.8) 
      SCFTOL=1.D0 
      IF (JCYC.LT.3) SCFTOL=MIN(GNORM,1.D1) 
      FROZEN=COSINE.LT.0.8D0 
      IF(FULSCF.OR..NOT.OKF) FROZEN=.FALSE. 
C     PERFORM THE LINE SEARCH WITHOUT GRADIENT COMPUTATION 
      SMVAL=FUNCT1 
      BETA =ALPHA 
  380 CALL LINMIN(XPARAM,ALPHA,PVECT,NVAR,FUNCT1,OKF,OKC) 
      NCOUNT=NCOUNT+1 
      IF ( .NOT. OKF) THEN 
         LNSTOP = 1 
         IF(MINPRT)WRITE (IPRT,'(/,20X, ''NO POINT LOWER IN ENERGY '', 
     1    ''THAN THE STARTING POINT COULD BE FOUND '', 
     2    ''IN THE LINE MINIMIZATION'')') 
         FUNCT1=SMVAL 
         ALPHA=BETA 
         CALL SCOPY (NVAR,GLAST,1,GRAD  ,1) 
         CALL SCOPY (NVAR,XLAST,1,XPARAM,1) 
         IF (FROZEN.OR.SCFTOL.GT.1.D0) THEN 
            FROZEN=.FALSE. 
            SCFTOL=1.D0 
            GO TO 380 
         ENDIF 
         IF (JNRST.EQ.0)THEN 
            WRITE (IPRT,400) 
  400       FORMAT (1H ,//,20X, 'SINCE COS WAS JUST RESET,THE SEARCH', 
     1        ' IS BEING ENDED') 
C 
C           FLEPO IS ENDING BADLY. THIS IS IMMEDIATELY BEFORE THE RETURN 
C 
            LAST=1 
            CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
            IFLEPO=4 
            TIME0=TIME0-TOTIME 
            RETURN 
         ENDIF 
         IF(PRINT)WRITE (IPRT,410) 
  410    FORMAT (1H ,20X, 'COS WILL BE RESET AND ANOTHER ' 
     1    ,'ATTEMPT MADE') 
         COS=0.0D00 
         GO TO 570 
      ENDIF 
C   WE WANT ACCURATE DERIVATIVES AT THIS POINT 
C 
C   LINMIN DOES NOT GENERATE ANY DERIVATIVES, THEREFORE COMPFG MUST BE 
C   CALLED TO END THE SEARCH 
C 
C     RESTORE TO STANDARD VALUE BEFORE COMPUTING THE GRADIENT 
      FROZEN=.FALSE. 
      SCFTOL=1.D0 
      RESET=.FALSE. 
      CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
      IF(FAIL)STOP 
      IF (.NOT. OKC .AND. MINPRT)WRITE (IPRT,430) JCYC 
  430 FORMAT ( 23H0LINMIN FAILED AT CYCLE,I5/,  1H0) 
      XN=SQRT(DOT(XPARAM,XPARAM,NVAR)) 
      TX=ABS(ALPHA*PNORM) 
      IF (XN.NE.0.0D00) TX=TX/XN 
      TF=ABS(FI-FUNCT1) 
      IF (PRINT) WRITE (IPRT,450) NCOUNT,TX,TF,GNORM 
  450 FORMAT ( '  TERMINATION TESTS ...',/, '     NUMBER OF COUNTS =' 
     1,I5/, '     RELATIVE CHANGE IN X = ',F13.6/, '     RELATIVE CHA' 
     2,'NGE IN F = ',F13.6/, '     GRADIENT NORM        = ',F13.6,//) 
  460 IF (NCOUNT.GE.MAXEND) THEN 
         WRITE (IPRT,470) 
  470    FORMAT ( 33H0TERMINATION FROM TOO MANY COUNTS) 
         LAST=1 
         CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
         IFLEPO=5 
         TIME0=TIME0-TOTIME 
         RETURN 
      ENDIF 
      IOUT=0 
      IF (TX.LE.TOLERX) THEN 
         IF(MINPRT) WRITE (IPRT,480) 
  480    FORMAT (' TEST ON X SATISFIED') 
         IOUT=1 
      ENDIF 
      IF (TF.LE.TOLERF) THEN 
         IF(MINPRT) WRITE (IPRT,490) 
  490    FORMAT (' HEAT OF FORMATION TEST SATISFIED') 
         IOUT=1 
      ENDIF 
      IF (GNORM.LE.TOLERG*ROOTV) THEN 
         IF(MINPRT) WRITE (IPRT,500) 
  500    FORMAT (' TEST ON GRADIENT SATISFIED') 
         IOUT=1 
      ENDIF 
      IF(IOUT.EQ.0) GO TO 570 
  510 DO 550 I=1,NVAR 
         IF (ABS(GRAD(I)).GT.TOLERG)THEN 
            IREPET=IREPET+1 
            IF (IREPET.GT.1) GO TO 520 
            FREPF=FUNCT1 
            COS=0.0D00 
  520       IF(MINPRT) WRITE (IPRT,530)TOLERG 
  530       FORMAT (20X,'HOWEVER, A COMPONENT OF GRADIENT IS ', 
     1     'LARGER THAN',F6.2 ,/) 
            IF (ABS(FUNCT1-FREPF).GT.EINC) IREPET=0 
            IF (IREPET.GT.IGG1) THEN 
               WRITE (IPRT,540)IGG1,EINC 
  540          FORMAT (10X,' THERE HAVE BEEN',I2,' ATTEMPTS TO REDUCE TH 
     1E ',' GRADIENT.',/10X,' DURING THESE ATTEMPTS THE ENERGY DROPPED', 
     2' BY LESS THAN',F4.1,' KCAL/MOLE',/ 
     310X,' FURTHER CALCULATION IS NOT JUSTIFIED AT THIS TIME.',/ 
     410X,' TO CONTINUE, START AGAIN WITH THE WORD "PRECISE"' ) 
               LAST=1 
               CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
               IFLEPO=8 
               TIME0=TIME0-TOTIME 
               RETURN 
            ELSE 
               GOTO 570 
            ENDIF 
         ENDIF 
  550 CONTINUE 
      IF(MINPRT) WRITE (IPRT,560) 
  560 FORMAT ( 23H PETERS TEST SATISFIED ) 
      LAST=1 
      CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
      IFLEPO=6 
      TIME0=TIME0-TOTIME 
      RETURN 
C 
C   ALL TESTS HAVE FAILED, WE NEED TO DO ANOTHER CYCLE. 
C 
  570 CONTINUE 
      BSMVF=ABS(SMVAL-FUNCT1) 
      IF (BSMVF.GT.10.D00) COS = 0.0D00 
      DEL=0.002D00 
      IF (BSMVF.GT.1.0D00) DEL=DELL/2.0D00 
      IF (BSMVF.GT.5.0D00) DEL=DELL 
      CALL SECOND (TX2) 
      TCYCLE=TX2-TX1 
      TX1=TX2 
C 
C END OF ITERATION LOOP, EVERYTHING IS STILL O.K. SO GO TO 
C NEXT ITERATION, IF THERE IS ENOUGH TIME LEFT. 
C 
      IF(TCYCLE.LT.100000.D0)CYCMX=MAX(CYCMX,TCYCLE) 
      TLEFT=TLEFT-TCYCLE 
      IF(TLEFT.LT.0)TLEFT=-0.1D0 
      IF(TCYCLE.GT.1.D5)TCYCLE=0.D0 
      IF(MINPRT.OR.TIME) WRITE(IPRT,580)JCYC,TCYCLE,TLEFT,GNORM,FUNCT1 
  580 FORMAT(' CYCLE:',I3,' TIME:',F7.2,' TIME LEFT:',F9.1, 
     1' GRAD.NORM:',F10.3,' HEAT:',G14.7) 
      IF (TLEFT.GT.SFACT*CYCMX) GO TO 40 
      WRITE(IPRT,590) 
  590 FORMAT (20X, 42HTHERE IS NOT ENOUGH TIME FOR ANOTHER CYCLE,/,30X, 
     118HNOW GOING TO FINAL) 
      MDFP(9)=1 
      CALL SECOND (TFLY) 
      TOTIME=TOTIME+TFLY-TIME0 
      CALL DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP) 
C 
C 
      END 
      SUBROUTINE FMAT(FMATRX, TSCF, TDER, DELDIP, HEAT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
*  VALUE CALCULATES THE SECOND-ORDER OF THE ENERGY WITH 
*        RESPECT TO THE CARTESIAN COORDINATES I AND J AND PLACES IT 
*        IN FMATRX 
* 
*  ON INPUT NATOMS  = NUMBER OF ATOMS IN THE SYSTEM. 
*           XPARAM  = INTERNAL COORDINATES OF MOLECULE STORED LINEARLY 
* 
*  VARIABLES USED 
*           COORDL  = ARRAY OF CARTESIAN COORDINATES, STORED LINEARLY. 
*           I       = INDEX OF CARTESIAN COORDINATE. 
*           J       = INDEX OF CARTESIAN COORDINATE. 
* 
*  ON OUTPUT FMATRX = SECOND DERIVATIVE OF THE ENERGY WITH RESPECT TO 
*                    CARTESIAN COORDINATES I AND J. 
*********************************************************************** 
      DIMENSION FMATRX(*), DELDIP(3,*) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY, DUMY(MAXPAR) 
      COMMON /DENSTY/ P(MPACK),PDUMY(2,MPACK) 
      COMMON /TIME  / TIME0 
      COMMON /CORE  / CORE(107) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /COORD / COORD(3,NUMATM) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,FDUMMY(MAXHES),STORE(MAXPAR**2) 
     1               ,EVECS(MAXPAR*MAXPAR),COLD(MAXPAR),GRAD(MAXPAR) 
     2               ,GROLD(MAXPAR),Q(NUMATM),DEL2(3) 
     3               ,EIGS(MAXPAR),FCONST(MAXPAR) 
      DIMENSION COORDL(MAXPAR) 
      CHARACTER*80 KEYWRD 
      LOGICAL DEBUG, DERIV, RESTRT,FAIL 
      CHARACTER SPACE*1, DOT*1, ZERO*1, NINE*1, CH*1 
      EQUIVALENCE (COORD(1,1),COORDL(1)) 
      DATA SPACE,DOT,ZERO,NINE /' ','.','0','9'/ 
      DATA FACT/6.95125D-3/ 
       SAVE
C 
C    FACT IS THE CONVERSION FACTOR FROM KCAL/MOLE TO ERGS 
C 
C SET UP CONSTANTS AND FLAGS 
      NA(1)=99 
C 
C  SET UP THE VARIABLES IN XPARAM ANDLOC,THESE ARE IN CARTESIAN COORDINA 
C 
      NUMAT=0 
      DO 10 I=1,NATOMS 
         IF(LABELS(I).NE.99.AND.LABELS(I).NE.107) THEN 
            NUMAT=NUMAT+1 
            LABELS(NUMAT)=LABELS(I) 
         ENDIF 
   10 CONTINUE 
      NATOMS=NUMAT 
C 
C   THIS IS A QUICK, IF CLUMSY, WAY TO CALCULATE NUMAT, AND TO REMOVE TH 
C   DUMMY ATOMS FROM THE ARRAY LABELS. 
C 
      NVAR=0 
      DO 20 I=1,NUMAT 
         DO 20 J=1,3 
            NVAR=NVAR+1 
            LOC(1,NVAR)=I 
            LOC(2,NVAR)=J 
   20 CONTINUE 
      LIN=(NVAR*(NVAR+1))/2 
      DO 30 I=1,LIN 
   30 FMATRX(I)=0.D0 
      RESTRT =(INDEX(KEYWRD,'RESTART') .NE. 0) 
      IF(INDEX(KEYWRD,'NLLSQ') .NE. 0) RESTRT=.FALSE. 
      DEBUG =INDEX(KEYWRD,'FMAT') .NE. 0 
      DERIV=INDEX(KEYWRD,'DERINU') .EQ. 0 
      WRITE(IPRT,'(//4X,''FIRST DERIVATIVES WILL BE USED IN THE'' 
     1,'' CALCULATION OF SECOND DERIVATIVES'')') 
      TIME=3600 
      I=INDEX(KEYWRD,' T=') 
      IF(I.NE.0) THEN 
         TIM=READA(KEYWRD,I) 
         DO 40 J=I+3,80 
            CH=KEYWRD(J:J) 
            IF( CH .NE. DOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) THEN 
               IF( CH .EQ. 'M') TIM=TIM*60 
               GOTO 50 
            ENDIF 
   40    CONTINUE 
   50    TIME=TIM 
         WRITE(IPRT,'(/10X,''TIME DEFINED FOR THIS STEP ='',F19.2, 
     1    '' SECONDS'')')TIME 
      ELSE 
         WRITE(IPRT,'(/10X,''DEFAULT TIME OF'',F8.2, 
     1    '' SECONDS ALLOCATED FOR THIS STEP'')')TIME 
      ENDIF 
      CALL SECOND (TFLY) 
      TLEFT=TIME-TFLY+TIME0 
      IF(RESTRT) THEN 
         DO 60 I=1,NVAR 
   60    COLD(I)=COORDL(I) 
         ISTART = 0 
         I=0 
         CALL FORSAV(TOTIME,DELDIP,ISTART,I,FMATRX, COORD, NVAR,HEAT, 
     1                EVECS,JSTART,FCONST) 
         KOUNTF=(ISTART*(ISTART+1))/2 
         ISTART=ISTART+1 
         JSTART=JSTART+1 
         CALL SECOND (TIME2) 
         IF(ISTART.GT.NVAR) GOTO 160 
      ELSE 
         KOUNTF=0 
         TOTIME=0.D0 
         IF (TSCF.GT.0.D0)TLEFT=TLEFT-TSCF-TDER 
         ISTART=1 
      ENDIF 
      CONST =60 
      DELTA =0.5D0/CONST 
C CALCULATE FMATRX 
      IF(ISTART.GT.1) THEN 
         ESTIME=(NVAR-ISTART+1)*TOTIME/(ISTART-1.D0) 
      ELSE 
         ESTIME=NVAR*(TSCF+TDER)*2.D0 
      ENDIF 
      IF(TSCF.GT.0) 
     1WRITE(IPRT,'(/10X,''ESTIMATED TIME TO COMPLETE CALCULATION ='' 
     2,F9.2,'' SECONDS'')')ESTIME 
      IF(RESTRT) THEN 
         IF(ISTART.LE.NVAR) 
     1    WRITE(IPRT,'(/10X,''STARTING AGAIN AT LINE'',18X,I4)')ISTART 
         WRITE(IPRT,'(/10X,''TIME USED UP TO RESTART ='',F22.2)')TOTIME 
      ENDIF 
      LU=KOUNTF 
      CALL SECOND (TIME1) 
      NUMAT=NVAR/3 
      DO 120 I=ISTART,NVAR 
         CALL SECOND (TIME2) 
         COORDL(I)=COORDL(I)+DELTA*0.5 
         GROLD(1)=100.D0 
         CALL COMPFG(COORDL,ESCF,FAIL,GROLD,.TRUE.) 
         IF(FAIL)STOP 
         CALL CHRGE(P,Q) 
         DO 70 II=1,NUMAT 
   70    Q(II)=CORE(LABELS(II))-Q(II) 
         SUM = DIPOLE(P,Q,COORDL,DELDIP(1,I)) 
         COORDL(I)=COORDL(I)-DELTA 
         GRAD(1)=100.D0 
         CALL COMPFG(COORDL,HEATAA,FAIL,GRAD,.TRUE.) 
         IF(FAIL)STOP 
         CALL CHRGE(P,Q) 
         DO 80 II=1,NUMAT 
   80    Q(II)=CORE(LABELS(II))-Q(II) 
         SUM = DIPOLE(P,Q,COORDL,DEL2) 
         DO 90 II=1,3 
   90    DELDIP(II,I)=(DELDIP(II,I)-DEL2(II))*CONST 
         LL=LU+1 
         LU=LL+I-1 
         L=0 
         DO 100 KOUNTF=LL,LU 
            L=L+1 
            FMATRX(KOUNTF)=FMATRX(KOUNTF)+ 
     1         ((GROLD(L)-GRAD(L))) 
     2          *CONST*FACT*0.5D0 
  100    CONTINUE 
         L=L-1 
         DO 110 K=I,NVAR 
            L=L+1 
            KK=(K*(K-1))/2+I 
            FMATRX(KK)=FMATRX(KK)+ 
     1         ((GROLD(L)-GRAD(L))) 
     2          *CONST*FACT*0.5D0 
  110    CONTINUE 
         COORDL(I)=COORDL(I)+DELTA*0.5D0 
         CALL SECOND (TIME3) 
         TSTEP=TIME3-TIME2 
         TOTIME= TOTIME+TSTEP 
         TLEFT= TLEFT-TSTEP 
         WRITE(IPRT,'('' STEP:'',I4,'' TIME ='',F9.2,'' SECS, INTEGRAL = 
     1'',F10.2,'' TIME LEFT:'',F10.2)')I,TSTEP,TOTIME,TLEFT 
         IF(DERIV) THEN 
            ESTIM = TOTIME/I 
         ELSE 
            ESTIM = TOTIME*2.D0/I 
         ENDIF 
         IF(I.NE.NVAR.AND.TLEFT-10.D0 .LT. ESTIM) THEN 
            WRITE(IPRT,'(//10X,''- - - - -  TIME  LIMIT - - - - -'')') 
            WRITE(IPRT,'(/10X,'' POINT REACHED ='',I4)')I 
            WRITE(IPRT,'(/10X,'' RESTART USING KEY-WORD "RESTART"'')') 
            WRITE(IPRT,'(10X,''ESTIMATED TIME FOR THE NEXT STEP ='', 
     1F8.2,'' SECONDS'')')ESTIM 
            JSTART=1 
            II=I 
            CALL FORSAV(TOTIME,DELDIP,II,NVAR,FMATRX, COORD,NVAR,HEAT, 
     1                EVECS,JSTART,FCONST) 
         ENDIF 
  120 CONTINUE 
C#      CALL FORSAV(TOTIME,DELDIP,NVAR,NVAR,FMATRX, COORD,NVAR,HEAT, 
C#     +                EVECS,JSTART,FCONST) 
      IF(DERIV) GOTO 250 
      WRITE(IPRT,'(//10X,'' STARTING TO CALCULATE FORCE CONSTANTS'',/)') 
      CALL FRAME(FMATRX,NUMAT,0,EIGS) 
      CALL HQRII(FMATRX,NVAR,NVAR,EIGS,EVECS) 
      IF(DEBUG) THEN 
         WRITE(IPRT,'(''   EIGENVECTORS FROM FIRST CALCULATION'')') 
         CALL MATOUT(EVECS,EIGS,NVAR,NVAR,NVAR) 
      ENDIF 
      L=0 
      NREAL=NVAR-6 
      DO 140 I=1,NVAR 
         DO 140 J=1,I 
            L=L+1 
            SUM=0.D0 
            DO 130 K=1,NREAL 
               K1=(K-1)*NVAR+I 
               K2=(K-1)*NVAR+J 
  130       SUM=SUM+EVECS(K1)*EIGS(K)*EVECS(K2) 
  140 FMATRX(L)=SUM 
      CALL FRAME(FMATRX,NUMAT,0,EIGS) 
      CALL HQRII(FMATRX,NVAR,NVAR,EIGS,EVECS) 
      JSTART=1 
      DO 150 I=1,NVAR 
  150 COLD(I)=COORDL(I) 
  160 IF(DERIV) GOTO 250 
      DELTA=0.025D0 
      L=(JSTART-1)*NVAR 
      DO 210 ILOOP=JSTART,NVAR 
         J=L 
         DO 170 I=1,NVAR 
            J=J+1 
  170    COORDL(I)=COLD(I)+EVECS(J)*DELTA 
         CALL COMPFG(COORDL,HEATA,FAIL,GRAD,.FALSE.) 
         IF(FAIL)STOP 
         HEATA=HEATA-HEAT 
         J=L 
         DO 180 I=1,NVAR 
            J=J+1 
  180    COORDL(I)=COLD(I)-EVECS(J)*DELTA 
         CALL COMPFG(COORDL,HEATB,FAIL,GRAD,.FALSE.) 
         IF(FAIL)STOP 
         HEATB=HEATB-HEAT 
         J=L 
         DO 190 I=1,NVAR 
            J=J+1 
  190    COORDL(I)=COLD(I)+EVECS(J)*DELTA*2 
         CALL COMPFG(COORDL,HEATAA,FAIL,GRAD,.FALSE.) 
         IF(FAIL) STOP 
         HEATAA=HEATAA-HEAT 
         J=L 
         DO 200 I=1,NVAR 
            J=J+1 
  200    COORDL(I)=COLD(I)-EVECS(J)*DELTA*2 
         CALL COMPFG(COORDL,HEATBB,FAIL,GRAD,.FALSE.) 
         IF(FAIL) STOP 
         HEATBB=HEATBB-HEAT 
         SUM=( (HEATA+HEATB)*16 - (HEATAA+HEATBB) )/12.D0 
     1/DELTA*FACT/DELTA*0.5D0 
         FCONST(ILOOP)=SUM*0.5D0 
         L=L+NVAR 
         CALL SECOND (TIME3) 
         TSTEP=TIME3-TIME2 
         TIME2=TIME3 
         TOTIME= TOTIME+TSTEP 
         TLEFT= TLEFT-TSTEP 
         WRITE(IPRT,'('' STEP:'',I4,'' TIME ='',F9.2,'' SECS, INTEGRAL = 
     1'',F10.2,'' TIME LEFT:'',F10.2)')ILOOP,TSTEP,TOTIME,TLEFT 
         ESTIM = TSTEP*5.D0 
C 
C    5.0 IS A SAFETY FACTOR 
C 
         IF(ILOOP.NE.NVAR.AND.TLEFT-10.D0 .LT. ESTIM) THEN 
            WRITE(IPRT,'(//10X,''- - - - -  TIME  LIMIT - - - - -'')') 
            WRITE(IPRT,'(/10X,'' POINT REACHED ='',I4)')ILOOP 
            WRITE(IPRT,'(/10X,'' RESTART USING KEY-WORD "RESTART"'')') 
            WRITE(IPRT,'(10X,''ESTIMATED TIME FOR THE NEXT STEP ='', 
     1F8.2,'' SECONDS'')')ESTIM 
            IFOR=ILOOP 
            IX=NVAR+2 
* 
* VALUE OF IX IS NOT IMPORTANT. SHOULD NOT BE 0 OR NVAR 
* 
            CALL FORSAV(TOTIME,DELDIP,IX,NVAR,FMATRX, COORD,NVAR,HEAT, 
     1                EVECS,IFOR,FCONST) 
         ENDIF 
  210 CONTINUE 
      L=0 
      DO 230 I=1,NVAR 
         DO 230 J=1,I 
            L=L+1 
            SUM=0.D0 
            DO 220 K=1,NVAR 
               K1=(K-1)*NVAR+I 
               K2=(K-1)*NVAR+J 
  220       SUM=SUM+EVECS(K1)*FCONST(K)*EVECS(K2) 
  230 FMATRX(L)=SUM*2.D0 
      DO 240 I=1,NVAR 
  240 COORDL(I)=COLD(I) 
  250 CONTINUE 
      IF(ISTART.LE.NVAR .AND. INDEX(KEYWRD,'ISOTOPE') .NE. 0) 
     1CALL FORSAV(TOTIME,DELDIP,NVAR,NVAR,FMATRX, COORD,NVAR,HEAT, 
     2                EVECS,ILOOP,FCONST) 
      RETURN 
      END 
      SUBROUTINE FOCK (F, P, N) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C*********************************************************************** 
C 
C FOCK  FORMS THE 2-ELECTRON PART OF THE FOCK MATRIX FOR MOLECULES 
C       IN RHF CASE WITHIN * MNDO (AM1) * OR * MINDO * FORMALISMS. 
C  INPUT    P(N,N) = TOTAL DENSITY MATRIX. 
C           N      = NUMBER OF A.O. 
C 
C  OUTPUT   F(N,N) = 2-ELECTRON CONTRIBUTION TO THE FOCK MATRIX. 
C*********************************************************************** 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA 
     2               ,NCLOSE,NOPEN,NDUMY,FRACT 
     3       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     4               ,GSD(107),GPD(107),GDD(107) 
     5       /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NUMBW,NBAND(NUMATM) 
     6       /SCRACH/ PDUM(MORB2),FJINT(10*NUMATM),PIJ(10*NUMATM) 
     7               ,FKL(10*NUMATM),F12(2,MAXORB),P12(2,MAXORB) 
     8       /KEYWRD/ KEYWRD 
      DIMENSION F(N,*), P(N,*) 
      CHARACTER*80 KEYWRD 
       SAVE
      DO 10 I=1,N*N 
   10 F(I,1)=0.D0 
      IF(INDEX(KEYWRD,'MINDO').NE.0) GO TO 90 
C 
C     * MNDO * OR * AM1 * 
C       ----        --- 
C 
      KPQRS=1 
      IPQRS=1 
      IJ=0 
      DO 20 I=1,NLAST(1) 
      DO 20 J=1,I 
      IJ=IJ+1 
      FJINT(IJ)=0.D0 
   20 PIJ(IJ)=P(J,I)*2.D0 
      DO 85 II=2,NUMAT 
         IF(NBAND(II).LE.0) GO TO 85 
         IA=NFIRST(II) 
         IC=NLAST(II) 
C 
C     J-CONTRIBUTIONS IN FJINT 
C 
         IJOLD=IJ+1 
         DO 30 I=IA,IC 
         DO 30 J=IA,I 
         IJ=IJ+1 
   30    PIJ(IJ)=P(J,I)*2.D0 
         NROW=IJOLD-1 
         NCOL=NBAND(II) 
         CALL MXM (PIJ,1,WJ(IPQRS),NROW,FJINT(IJOLD),NCOL) 
         CALL MXM (WJ(IPQRS),NROW,PIJ(IJOLD),NCOL,FKL,1) 
         IPQRS=IPQRS+NROW*NCOL 
         DO 40 I=1,NROW 
   40    FJINT(I)=FJINT(I)+FKL(I) 
C 
C     K-CONTRIBUTIONS IN F 
C 
         DO 84 I=IA,IC 
         IF (I.GT.IA) THEN 
            DO 50 K=1,IA 
   50       P12(1,K)=P(I,K) 
            DO 70 J=IA,I-1 
            DO 55 K=1,IA 
   55       P12(2,K)=P(J,K) 
            DO 65 JJ=1,II-1 
               JA=NFIRST(JJ) 
               JJLEN=NLAST(JJ)-JA+1 
               IF (JJLEN.GT.1) THEN 
                  CALL MXM (P12(1,JA),2,WK(KPQRS),JJLEN,F12(1,JA),JJLEN) 
                  KPQRS=KPQRS+JJLEN*JJLEN 
               ELSE IF (JJLEN.EQ.1) THEN 
                  DO 60 K=1,2 
   60             F12(K,JA)=WK(KPQRS)*P12(K,JA) 
                  KPQRS=KPQRS+1 
               ENDIF 
   65       CONTINUE 
CDIR$ IVDEP 
            DO 70 K=1,IA-1 
            F(I,K)=F(I,K)+F12(2,K) 
   70       F(J,K)=F(J,K)+F12(1,K) 
         ENDIF 
         DO 80 JJ=1,II-1 
            JA=NFIRST(JJ) 
            JJLEN=NLAST(JJ)-JA+1 
            IF (JJLEN.GT.1) THEN 
               CALL MXM (P(JA,I),1,WK(KPQRS),JJLEN,F12(JA,1),JJLEN) 
               KPQRS=KPQRS+JJLEN*JJLEN 
            ELSE IF (JJLEN.EQ.1) THEN 
               F12(JA,1)=WK(KPQRS)*P(JA,I) 
               KPQRS=KPQRS+1 
            ENDIF 
   80    CONTINUE 
         CALL SAXPY (IA-1,2.D0,F12,1,F(I,1),NORBS) 
   84    CONTINUE 
   85 CONTINUE 
C 
C     INSERT J-CONTRIBUTIONS IN F 
C 
      IJ=0 
      DO 86 II=1,NUMAT 
      IA=NFIRST(II) 
      IC=NLAST(II) 
      DO 86 I=IA,IC 
      DO 86 J=IA,I 
      IJ=IJ+1 
   86 F(I,J)=FJINT(IJ) 
C 
      GO TO 200 
C 
C     * MINDO * 
C       ----- 
C 
   90 KR=0 
      DO 120 II=2,NUMAT 
         IA=NFIRST(II) 
         IB=NLAST(II) 
         DO 110 JJ=1,II-1 
            KR=KR+1 
            ELREP=2.D0*WJ(KR) 
            JA=NFIRST(JJ) 
            JB=NLAST(JJ) 
            DO 100 I=IA,IB 
               DO 100 K=JA,JB 
                  F(I,I)=F(I,I)+P(K,K)*ELREP 
                  F(K,K)=F(K,K)+P(I,I)*ELREP 
  100       F(I,K)=F(I,K)-P(I,K)*ELREP 
  110    CONTINUE 
  120 CONTINUE 
C ********************************************************************* 
C 
C *** COMPUTE THE REMAINING CONTRIBUTIONS TO THE ONE-CENTRE ELEMENTS. 
C --- DUE TO ROUND-OFF CUMULATIVE EFFECTS, THIS SECTION IS BETTER 
C     TO BE DONE AFTER THE 2-CENTRE ONE. 
C           ..... NO "D" ORBITALS IN THIS VERSION ... 
C 
C ********************************************************************* 
  200 DO 250 II=1,NUMAT 
         IA=NFIRST(II) 
         IB=NMIDLE(II) 
         NI=NAT(II) 
C 
C     F(S,S) ... 1/2 
C 
         F(IA,IA)=F(IA,IA)+P(IA,IA)*GSS(NI)*0.25D0 
         IF (NI.LT.3) GO TO 250 
         PTPOP=0.D0 
         DO 210 I=IA+1,IB 
  210    PTPOP=PTPOP+P(I,I) 
         GSPHSP=GSP(NI)*0.5D0-HSP(NI)*0.25D0 
C 
C     F(S,S) ... 2/2 
C 
         F(IA,IA)=F(IA,IA)+PTPOP*GSPHSP 
         DO 220 J=IA+1,IB 
C 
C     F(P,P) 
C 
            F(J,J)=F(J,J)+P(IA,IA)*GSPHSP 
     1               +P(J,J)*GPP(NI)*0.25D0 
     2               +(PTPOP-P(J,J))*(0.625D0*GP2(NI)-0.125D0*GPP(NI)) 
C 
C     F(S,P) 
C 
  220    F(J,IA)=F(J,IA)+P(J,IA)*(1.5D0*HSP(NI)-0.5D0*GSP(NI)) 
C 
C     F(P,P*) 
C 
         DO 240 J=IA+1,IB-1 
            DO 230 L=J+1,IB 
  230       F(L,J)=F(L,J)+P(L,J)*(0.75D0*GPP(NI)-1.25D0*GP2(NI)) 
  240    CONTINUE 
  250 CONTINUE 
C 
C     SYMMETRIZE F 
C 
      DO 300 I=2,N 
CDIR$ IVDEP 
      DO 300 J=1,I-1 
  300 F(J,I)=F(I,J) 
      DO 310 I=1,NORBS*NORBS,NORBS+1 
  310 F(I,1)=F(I,1)*2.D0 
      RETURN 
      END 
      SUBROUTINE FOCK1(F, PTOT, PA, PB) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C ********************************************************************* 
C 
C *** COMPUTE THE REMAINING CONTRIBUTIONS TO THE ONE-CENTRE ELEMENTS. 
C 
C ********************************************************************* 
      DIMENSION F(*), PTOT(*), PA(*), PB(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /GAUSS / FN1(107),FN2(107) 
      COMMON /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     1                ,GSD(107),GPD(107),GDD(107) 
      DIMENSION QTOT(NUMATM) 
       SAVE
      CALL CHRGE(PTOT,QTOT) 
      KDIAG=0 
      DO 100 II=1,NUMAT 
         IA=NFIRST(II) 
         IB=NMIDLE(II) 
         IC=NLAST(II) 
         NI=NAT(II) 
         DTPOP=0.D0 
         DAPOP=0.D0 
         PTPOP=0.D0 
         PAPOP=0.D0 
         KDIAG=KDIAG+IA 
         KA=KDIAG 
         IF (IB.GT.IA) THEN 
            IAPLUS=IA+1 
            DO 20 I=IAPLUS,IB 
            KDIAG=KDIAG+I 
            PTPOP=PTPOP+PTOT(KDIAG) 
   20       PAPOP=PAPOP+PA  (KDIAG) 
            IF (IC.GT.IB) THEN 
               IBPLUS=IB+1 
               DO 30 I=IBPLUS,IC 
               KDIAG=KDIAG+I 
               DTPOP=DTPOP+PTOT(KDIAG) 
   30          DAPOP=DAPOP+PA  (KDIAG) 
            ENDIF 
         ENDIF 
C 
C     F(S,S) 
C 
         F(KA)=F(KA)+PB(KA)*GSS(NI)+PTPOP*GSP(NI) 
     1         -PAPOP*HSP(NI) + DTPOP*GSD(NI) 
         IF (NI.LT.3) GO TO 100 
         L=KA 
         DO 70 J=IAPLUS,IB 
            M=L+IA 
            L=L+J 
C 
C     F(P,P) 
C 
            F(L)=F(L)+PTOT(KA)*GSP(NI)-PA(KA)*HSP(NI)+ 
     1      PB(L)*GPP(NI)+(PTPOP-PTOT(L))*GP2(NI) 
     2      -0.5D0*(PAPOP-PA(L))*(GPP(NI)-GP2(NI)) 
     3      +DTPOP*GPD(NI) 
C 
C     F(S,P) 
C 
   70    F(M)=F(M)+2.D0*PTOT(M)*HSP(NI)-PA(M)*(HSP(NI)+GSP(NI)) 
C 
C     F(P,P*) 
C 
         IMINUS=IB-1 
         DO 80 J=IAPLUS,IMINUS 
            ICC=J+1 
            M=J*(J+3)/2 
            DO 75 L=ICC,IB 
            F(M)=F(M)+    PTOT(M)*(GPP(NI)-GP2(NI)) 
     1               -0.5D0*PA(M)*(GPP(NI)+GP2(NI)) 
   75       M=M+L 
   80    CONTINUE 
         M=M+1 
         DO 90 J=IBPLUS,IC 
         M=M+J 
   90    F(M)=F(M)+PTOT(KA)*GSD(NI)+PTPOP*GPD(NI)+(DTPOP-PA(M))*GDD(NI) 
  100 CONTINUE 
      RETURN 
      END 
      SUBROUTINE FOCK2 (F, PTOT, P, W, WJ, WK, NUMAT, NFIRST 
     1                 ,NMIDLE, NLAST) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C*********************************************************************** 
C 
C FOCK2 FORMS THE TWO-ELECTRON TWO-CENTER REPULSION PART OF THE FOCK 
C MATRIX WITHIN * MNDO * OR * MINDO * FORMALISMS. 
C ON INPUT  PTOT = TOTAL DENSITY MATRIX. 
C           P    = ALPHA OR BETA DENSITY MATRIX. 
C           W    = TWO-ELECTRON INTEGRAL MATRIX. 
C 
C  ON OUTPUT F   = PARTIAL FOCK MATRIX 
C*********************************************************************** 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /WMATRX/ WDUM(N2ELEC*3),NUMBW,NBAND(NUMATM) 
      COMMON /SCRACH/ FJINT(10*NUMATM),PIJ(10*NUMATM),FKL(10*NUMATM) 
     1               ,F12(2,MAXORB),P12(2,MAXORB) 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION F(*), PTOT(*), WJ(*), WK(*), NFIRST(*), NMIDLE(*), 
     1          NLAST(*), P(*), W(*) 
      DIMENSION IFACT(MAXORB),I1FACT(MAXORB) 
      CHARACTER*80 KEYWRD 
      LOGICAL LID,IEQJ,MINDO 
      DATA IPASS /0/ 
      SAVE
      IF (IPASS.EQ.0) THEN 
C 
C        INITIALISATION (DONE ONLY ONCE) 
C 
         IPASS=1 
         MINDO=INDEX(KEYWRD,'MINDO') .NE. 0 
C        SET UP ARRAY OF (I*(I-1))/2 AND (I*(I+1))/2 
         DO 10 I=1,MAXORB 
         IFACT(I)=(I*(I-1))/2 
   10    I1FACT(I)=IFACT(I)+I 
         LID=ID.EQ.0 
         IF(.NOT.LID) THEN 
            LINEA1=NLAST(NUMAT)*(NLAST(NUMAT)+1)/2 + 1 
            P(LINEA1)=0.D0 
            IONE=0 
         ELSE 
            IONE=1 
         ENDIF 
      ENDIF 
      IF (MINDO) GO TO 100 
C 
C     * MNDO * OR * AM1 * 
C       ----        --- 
C 
      IF (LID) THEN 
C 
C        MOLECULE 
C        -------- 
         IPQRS=1 
         KPQRS=1 
         JIJ=0 
         DO 15 I=1,NLAST(1) 
         DO 15 J=1,I 
         JIJ=JIJ+1 
         FJINT(JIJ)=0.D0 
   15    PIJ(JIJ)=PTOT(JIJ)*2.D0 
         DO 75 II=2,NUMAT 
            IF (NBAND(II).LE.0) GO TO 75 
            IA=NFIRST(II) 
            IC=NLAST(II) 
C           J-CONTRIBUTIONS IN FJINT 
            IJOLD=JIJ+1 
            DO 20 I=IA,IC 
            DO 20 J=IA,I 
            JIJ=JIJ+1 
   20       PIJ(JIJ)=PTOT(IFACT(I)+J)*2.D0 
            NROW=IJOLD-1 
            NCOL=NBAND(II) 
            CALL MXM (PIJ,1,W(IPQRS),NROW,FJINT(IJOLD),NCOL) 
            CALL MXM (W(IPQRS),NROW,PIJ(IJOLD),NCOL,FKL,1) 
            IPQRS=IPQRS+NROW*NCOL 
            DO 25 I=1,NROW 
   25       FJINT(I)=FJINT(I)+FKL(I) 
C           K-CONTRIBUTIONS IN F 
            DO 70 I=IA,IC 
               KA=IFACT(I) 
               IF (I.GT.IA) THEN 
                  DO 30 K=1,IA-1 
   30             P12(1,K)=P(KA+K)*2.D0 
                  DO 55 J=IA,I-1 
                     KB=IFACT(J) 
                     DO 35 K=1,IA-1 
   35                P12(2,K)=P(KB+K)*2.D0 
                     DO 50 JJ=1,II-1 
                        JA=NFIRST(JJ) 
                        JJLEN=NLAST(JJ)-JA+1 
                        IF (JJLEN.GT.1) THEN 
                           CALL MXM (P12(1,JA),2,WK(KPQRS),JJLEN 
     .                              ,F12(1,JA),JJLEN) 
                           KPQRS=KPQRS+JJLEN*JJLEN 
                        ELSE IF (JJLEN.EQ.1) THEN 
                           DO 40 K=1,2 
   40                      F12(K,JA)=WK(KPQRS)*P12(K,JA) 
                           KPQRS=KPQRS+1 
                        ENDIF 
   50                CONTINUE 
CDIR$ IVDEP 
                     DO 55 K=1,IA-1 
                     F(KA+K)=F(KA+K)+F12(2,K) 
   55             F(KB+K)   =F(KB+K)+F12(1,K) 
               ENDIF 
               DO 60 JJ=1,II-1 
                  JA=NFIRST(JJ) 
                  JJLEN=NLAST(JJ)-JA+1 
                  IF (JJLEN.GT.1) THEN 
                     CALL MXM (P(KA+JA),1,WK(KPQRS),JJLEN,F12(JA,1) 
     .                        ,JJLEN) 
                     KPQRS=KPQRS+JJLEN*JJLEN 
                  ELSE IF (JJLEN.EQ.1) THEN 
                     F12(JA,1)=WK(KPQRS)*P(KA+JA) 
                     KPQRS=KPQRS+1 
                  ENDIF 
   60          CONTINUE 
               CALL SAXPY (IA-1,4.D0,F12,1,F(KA+1),1) 
   70       CONTINUE 
   75    CONTINUE 
C        MERGE J-CONTRIBUTIONS IN F 
         JIJ=0 
         DO 85 II=1,NUMAT 
         IA=NFIRST(II) 
         IC=NLAST(II) 
         DO 85 I=IA,IC 
         DO 80 J=IA,I-1 
         JIJ=JIJ+1 
   80    F(IFACT(I)+J)=F(IFACT(I)+J)+FJINT(JIJ) 
         JIJ=JIJ+1 
   85    F(I1FACT(I))=F(I1FACT(I))+FJINT(JIJ)*2.D0 
      ELSE 
C 
C        POLYMER 
C        ------- 
         KK=0 
         DO 90 II=1,NUMAT 
            IA=NFIRST(II) 
            IB=NLAST(II) 
            DO 90 I=IA,IC 
                KA=IFACT(I) 
                DO 90 J=IA,I 
                   KB=IFACT(J) 
                   IJ=KA+J 
                   IEQJ=I.EQ.J 
                   PTOIJ2=PTOT(IJ)*2.D0 
                   DO 90 JJ=1,II 
                      JA=NFIRST(JJ) 
                      JC=NLAST(JJ) 
                      DO 90 K=JA,JC 
                         KC=IFACT(K) 
                         IF(I.GE.K) THEN 
                            IK=KA+K 
                         ELSE 
                            IK=LINEA1 
                         ENDIF 
                         IF(J.GE.K) THEN 
                            JK=KB+K 
                         ELSE 
                            JK=LINEA1 
                         ENDIF 
                         DO 90 L=JA,K 
                            IF(I.GE.L) THEN 
                               IL=KA+L 
                            ELSE 
                               IL=LINEA1 
                            ENDIF 
                            IF(J.GE.L) THEN 
                               JL=KB+L 
                            ELSE 
                               JL=LINEA1 
                            ENDIF 
                            KL=KC+L 
                            KK=KK+1 
                            AJ=WJ(KK) 
                            AK=WK(KK) 
                            IF (KL.EQ.IJ) THEN 
                               F(IJ)=F(IJ)+2.D0*AJ*PTOIJ2 
                            ELSE IF (KL.LT.IJ) THEN 
                               AJKL=2.D0*AJ*PTOT(KL) 
                               IF (IEQJ) AJKL=AJKL+AJKL 
                               F(IJ)=F(IJ)+AJKL 
                               AJIJ=AJ*PTOIJ2 
                               IF (K.EQ.L) AJIJ=AJIJ+AJIJ 
                               F(KL)=F(KL)+AJIJ 
                               F(IK)=F(IK)-AK*P(JL) 
                               F(IL)=F(IL)-AK*P(JK) 
                               F(JK)=F(JK)-AK*P(IL) 
                               F(JL)=F(JL)-AK*P(IK) 
                            ENDIF 
   90    CONTINUE 
      ENDIF 
      RETURN 
C 
C     * MINDO * 
C       ----- 
C 
  100 KR=0 
      DO 130 II=1,NUMAT 
         IA=NFIRST(II) 
         IB=NLAST(II) 
         DO 120 JJ=1,II-IONE 
            KR=KR+1 
            IF(LID)THEN 
               ELREP=4.D0*W(KR) 
               ELEXC=ELREP 
            ELSE 
               ELREP=4.D0*WJ(KR) 
               ELEXC=4.D0*WK(KR) 
            ENDIF 
            JA=NFIRST(JJ) 
            JB=NLAST(JJ) 
            DO 110 I=IA,IB 
               KA=IFACT(I) 
               KK=KA+I 
               DO 110 K=JA,JB 
                  LL=I1FACT(K) 
                  IK=KA+K 
                  F(KK)=F(KK)+PTOT(LL)*ELREP 
                  F(LL)=F(LL)+PTOT(KK)*ELREP 
  110       F(IK)=F(IK)-P(IK)*ELEXC 
  120    CONTINUE 
  130 CONTINUE 
      RETURN 
      END 
      SUBROUTINE FOCK2D (F,PTOT, P, W, WJ, WK, NUMAT, NFIRST 
     1                  ,NMIDLE, NLAST) 
      IMPLICIT REAL (A-H,O-Z) 
C*********************************************************************** 
C 
C FOCK2D FORMS THE TWO-ELECTRON TWO-CENTER REPULSION PART OF THE FOCK 
C MATRIX 
C ON INPUT  PTOT = TOTAL DENSITY MATRIX. 
C           P    = ALPHA OR BETA DENSITY MATRIX. 
C           W    = TWO-ELECTRON INTEGRAL MATRIX. 
C 
C  ON OUTPUT F   = PARTIAL FOCK MATRIX 
C*********************************************************************** 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION F(*), PTOT(*), WJ(*), WK(*), NFIRST(*), NMIDLE(*), 
     1          NLAST(*), P(*), W(*) 
      DIMENSION IFACT(300), I1FACT(300) 
      LOGICAL LID,IEQJ 
      CHARACTER*80 KEYWRD 
      DATA ITYPE /1/ 
      SAVE
   10 GOTO (20,100,40) ITYPE 
C 
C   SET UP ARRAY OF (I*(I-1))/2 
C 
   20 DO 30 I=1,300 
         IFACT(I)=(I*(I-1))/2 
   30 I1FACT(I)=IFACT(I)+I 
      LID=(ID.EQ.0) 
         IONE=1 
      IF(INDEX(KEYWRD,'MINDO') .NE. 0) THEN 
         ITYPE=2 
      ELSE 
         ITYPE=3 
      ENDIF 
      GOTO 10 
   40 KK=0 
      IF (.NOT.LID) THEN 
         NORBS=NLAST(NUMAT) 
         LINEA1=NORBS*(NORBS+1)/2+1 
         P(LINEA1)=0.D0 
      ENDIF 
      DO 90 II=1,NUMAT 
         IA=NFIRST(II) 
         IB=NLAST(II) 
         IC=NMIDLE(II) 
            IMINUS=II-IONE 
            DO 90 JJ=1,IMINUS 
               JA=NFIRST(JJ) 
               JB=NLAST(JJ) 
               JC=NMIDLE(JJ) 
               IF(LID) THEN 
                  DO 70 I=IA,IC 
                     KA=IFACT(I) 
                     DO 70 J=IA,I 
                        KB=IFACT(J) 
                        IJ=KA+J 
                        IEQJ=I.EQ.J 
                        PTOIJ2=PTOT(IJ)*2.D0 
                        FIJ=0.D0 
                           DO 60 K=JA,JC 
                              KC=IFACT(K) 
                              IK=KA+K 
                              JK=KB+K 
                              DO 50 L=JA,K-1 
                                 IL=KA+L 
                                 JL=KB+L 
                                 KL=KC+L 
                                 KK=KK+1 
                                 A=W(KK) 
C 
C     A  IS THE REPULSION INTEGRAL (I,J/K,L) WHERE ORBITALS I AND J ARE 
C     ON ATOM II, AND ORBITALS K AND L ARE ON ATOM JJ. 
C     IJ IS THE LOCATION OF THE MATRIX ELEMENTS BETWEEN ATOMIC ORBITALS 
C     I AND J.  SIMILARLY FOR IK ETC. 
C 
C THIS FORMS THE TWO-ELECTRON TWO-CENTER REPULSION PART OF THE DIATOMIC 
C FOCK MATRIX FOR MOLECULE. 
                                 FIJ=FIJ+A*PTOT(KL) 
                                 F(KL)=F(KL)+A*PTOIJ2 
                                 F(IK)=F(IK)-A*P(JL) 
                                 F(IL)=F(IL)-A*P(JK) 
                                 F(JK)=F(JK)-A*P(IL) 
                                 F(JL)=F(JL)-A*P(IK) 
   50                         CONTINUE 
                              KK=KK+1 
                              A=W(KK) 
                              KL=KC+K 
                              FIJ=FIJ+A*PTOT(KL) 
                              A=A+A 
                              F(KL)=F(KL)+A*PTOIJ2 
                              F(IK)=F(IK)-A*P(JK) 
                              F(JK)=F(JK)-A*P(IK) 
   60                      CONTINUE 
                           IF (IEQJ) THEN 
                              F(IJ)=F(IJ)+4.D0*FIJ 
                           ELSE 
                              F(IJ)=F(IJ)+2.D0*FIJ 
                           ENDIF 
   70             CONTINUE 
               ELSE 
                  DO 80 I=IA,IC 
                     KA=IFACT(I) 
                     DO 80 J=IA,I 
                        KB=IFACT(J) 
                        IJ=KA+J 
                        IEQJ=I.EQ.J 
                        PTOIJ2=PTOT(IJ)*2.D0 
                        DO 80 K=JA,JC 
                           KC=IFACT(K) 
                           IF(I.GE.K) THEN 
                              IK=KA+K 
                           ELSE 
                              IK=LINEA1 
                           ENDIF 
                           IF(J.GE.K) THEN 
                              JK=KB+K 
                           ELSE 
                              JK=LINEA1 
                           ENDIF 
                           DO 80 L=JA,K 
                              IF(I.GE.L) THEN 
                                 IL=KA+L 
                              ELSE 
                                 IL=LINEA1 
                              ENDIF 
                              IF(J.GE.L) THEN 
                                 JL=KB+L 
                              ELSE 
                                 JL=LINEA1 
                              ENDIF 
                              KL=KC+L 
                              KK=KK+1 
                              AJ=WJ(KK) 
                              AK=WK(KK) 
C 
C     A  IS THE REPULSION INTEGRAL (I,J/K,L) WHERE ORBITALS I AND J ARE 
C     ON ATOM II, AND ORBITALS K AND L ARE ON ATOM JJ. 
C     IJ IS THE LOCATION OF THE MATRIX ELEMENTS BETWEEN ATOMIC ORBITALS 
C     I AND J.  SIMILARLY FOR IK ETC. 
C 
C THIS FORMS THE TWO-ELECTRON TWO-CENTER REPULSION PART OF THE DIATOMIC 
C FOCK MATRIX FOR POLYMERS. 
                              IF (KL.EQ.IJ) THEN 
                                 F(IJ)=F(IJ)+2.D0*AJ*PTOIJ2 
                              ELSE IF (KL.LT.IJ) THEN 
                                 AJKL=2.D0*AJ*PTOT(KL) 
                                 IF (IEQJ) AJKL=AJKL+AJKL 
                                 F(IJ)=F(IJ)+AJKL 
                                 AJIJ=AJ*PTOIJ2 
                                 IF (K.EQ.L) AJIJ=AJIJ+AJIJ 
                                 F(KL)=F(KL)+AJIJ 
                                 F(IK)=F(IK)-AK*P(JL) 
                                 F(IL)=F(IL)-AK*P(JK) 
                                 F(JK)=F(JK)-AK*P(IL) 
                                 F(JL)=F(JL)-AK*P(IK) 
                              ENDIF 
   80             CONTINUE 
               ENDIF 
   90 CONTINUE 
C 
      RETURN 
  100 KR=0 
      DO 130 II=1,NUMAT 
         IA=NFIRST(II) 
         IB=NLAST(II) 
         IM1=II-IONE 
         DO 120 JJ=1,IM1 
            KR=KR+1 
            IF(LID)THEN 
               ELREP=4.D0*W(KR) 
               ELEXC=ELREP 
            ELSE 
               ELREP=4.D0*WJ(KR) 
               ELEXC=4.D0*WK(KR) 
            ENDIF 
            JA=NFIRST(JJ) 
            JB=NLAST(JJ) 
            DO 110 I=IA,IB 
               KA=IFACT(I) 
               KK=KA+I 
               DO 110 K=JA,JB 
                  LL=I1FACT(K) 
                  IK=KA+K 
                  F(KK)=F(KK)+PTOT(LL)*ELREP 
                  F(LL)=F(LL)+PTOT(KK)*ELREP 
  110       F(IK)=F(IK)-P(IK)*ELEXC 
  120    CONTINUE 
  130 CONTINUE 
      RETURN 
      END 
      SUBROUTINE FORCE 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      PARAMETER (MORB22=MORB2*2, MAXOR2=MAXORB*2) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,DUMY(MAXPAR) 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR), 
     1                LOCDEP(MAXPAR) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,FMATRX(MAXHES),STORE(MAXPAR**2) 
      COMMON /TIME  / TIME0 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /VECTOR/ CNORML(MORB22),FREQ(MAXOR2) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /COORD / COORD(3,NUMATM) 
      COMMON /EULER / TVEC(3,3), ID 
*********************************************************************** 
* 
*   FORCE CALCULATES THE FORCE CONSTANTS FOR THE MOLECULE, AND THE 
*         VIBRATIONAL FREQUENCIES.  ISOTOPIC SUBSTITUTION IS ALLOWED. 
* 
*********************************************************************** 
      DIMENSION XPARAM(MAXPAR), GR(3,NUMATM), DELDIP(3,MAXPAR), 
     1          TRDIP(3,MAXPAR), REDMAS(MAXPAR), SHIFT(6), ROT(3,3) 
      CHARACTER KEYWRD*80, KEYS(80)*1 
      LOGICAL RESTRT, DIPOK, LINEAR, DEBUG, BARTEL, FAIL 
      EQUIVALENCE (GRAD(1), GR(1,1)), (KEYWRD,KEYS(1)) 
       SAVE
C 
C TEST GEOMETRY TO SEE IF IT IS OPTIMISED 
      TIME2=-1.D9 
      CALL GMETRY(GEO,COORD) 
      NVAR=0 
      NUMAT=0 
      IF(LABELS(1) .NE. 99) NUMAT=1 
      DO 20 I=2,NATOMS 
         IF(LABELS(I).EQ.99.OR.LABELS(I).EQ.107) GOTO 20 
         NUMAT=NUMAT+1 
         IF(I.EQ.2)ILIM=1 
         IF(I.EQ.3)ILIM=2 
         IF(I.GT.3)ILIM=3 
         DO 10 J=1,ILIM 
            NVAR=NVAR+1 
            LOC(1,NVAR)=I 
            LOC(2,NVAR)=J 
   10    XPARAM(NVAR)=GEO(J,I) 
   20 CONTINUE 
C 
C   IF A RESTART, THEN TSCF AND TDER WILL BE FAULTY, THEREFORE SET TO -1 
C 
      TSCF=-1.D0 
      TDER=-1.D0 
      DEBUG=(INDEX(KEYWRD,'DFORCE') .NE. 0) 
      BARTEL=(INDEX(KEYWRD,'NLLSQ') .NE. 0) 
      RESTRT=(INDEX(KEYWRD,'RESTART') .NE. 0) 
      CALL SECOND (TIME1) 
      IF (RESTRT) THEN 
C 
C   CHECK TO SEE IF CALCULATION IS IN NLLSQ OR FORCE. 
C 
         IF(BARTEL)GOTO 40 
C 
C   CALCULATION IS IN FORCE 
C 
         GOTO 70 
      ENDIF 
      IF(INDEX(KEYWRD,'OLDENS').NE.0) THEN
       OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED') 
       REWIND 10 
      ENDIF
      CALL COMPFG( XPARAM,ESCF,FAIL,GRAD,.FALSE.) 
      IF(FAIL) STOP 
      WRITE(IPRT,'(//10X,''HEAT OF FORMATION ='',F12.6, 
     1'' KCALS/MOLE'')')ESCF 
      CALL SECOND (TIME2) 
      TSCF=TIME2-TIME1 
      CALL COMPFG( XPARAM,ESCF,FAIL, GRAD, .TRUE.) 
      IF(FAIL) STOP 
      CALL SECOND (TIME3) 
      TDER=TIME3-TIME2 
      WRITE(IPRT,'(//10X,''INTERNAL COORDINATE DERIVATIVES'',//3X, 
     1''ATOM  AT. NO.'',2X,''BOND'',9X,''ANGLE'',8X,''DIHEDRAL'',/)') 
      L=0 
      IU=0 
      DO 30 I=1,NATOMS 
         IF(LABELS(I).EQ.99) GOTO 30 
         L=L+1 
         IL=IU+1 
         IF(I .EQ. 1) IU=IL-1 
         IF(I .EQ. 2) IU=IL 
         IF(I .EQ. 3) IU=IL+1 
         IF(I .GT. 3) IU=IL+2 
         WRITE(IPRT,'(2I6,F13.6,2F10.6)') L,LABELS(I),(GRAD(J),J=IL,IU) 
   30 CONTINUE 
C   TEST SUM OF GRADIENTS 
      GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
      WRITE(IPRT,'(//10X,''GRADIENT NORM ='',F10.5)') GNORM 
      IF(GNORM.LT.10.D0) GOTO 50 
      WRITE(IPRT,'(///1X,''** GRADIENT IS TOO LARGE TO ALLOW '', 
     1    ''FORCE MATRIX TO BE CALCULATED, (LIMIT=10) **'',//)') 
      IF(INDEX(KEYWRD,' LET ') .NE. 0) GOTO 60 
   40 CONTINUE 
      WRITE(IPRT,'(//10X,'' GEOMETRY WILL BE OPTIMISED FIRST'')') 
      IF(BARTEL) THEN 
         WRITE(IPRT,'(15X,''USING NLLSQ'')') 
         CALL NLLSQ(XPARAM,NVAR,ESCF,GRAD) 
      ELSE 
         WRITE(IPRT,'(15X,''USING FLEPO'')') 
         CALL FLEPO(XPARAM,NVAR,ESCF) 
         CALL COMPFG( XPARAM,ESCF,FAIL, GRAD, .TRUE.) 
         IF(FAIL) STOP 
      ENDIF 
      CALL WRITE(TIME1,ESCF) 
      WRITE(IPRT,'(//10X,''GRADIENT NORM ='',F10.7)') GNORM 
      CALL GMETRY(GEO,COORD) 
   50 CONTINUE 
C 
C NOW TO CALCULATE THE FORCE MATRIX 
C 
C CHECK OUT SYMMETRY 
   60 CONTINUE 
      IF(INDEX(KEYWRD,'THERMO').NE.0 .AND.GNORM.GT.1.D0) THEN 
         WRITE(IPRT,'(//30X,''**** WARNING ****'',// 
     110X,'' GRADIENT IS VERY LARGE FOR A THERMO CALCULATION'',/ 
     210X,'' RESULTS ARE LIKELY TO BE INACCURATE IF THERE ARE'')') 
         WRITE(IPRT,'(10X,'' ANY LOW-LYING VIBRATIONS (LESS THAN ABOUT ' 
     1',''400CM-1)'',/ 
     210X,'' GRADIENT NORM SHOULD BE LESS THAN ABOUT 0.2 FOR THERMO'',// 
     310X,'' TO GIVE ACCURATE RESULTS'')') 
      ENDIF 
      IF(TSCF.GT.0.D0) THEN 
         WRITE(IPRT,'(//10X,''TIME FOR SCF CALCULATION ='',F8.2)')TSCF 
         WRITE(IPRT,'(//10X,''TIME FOR DERIVATIVES     ='',F8.2)')TDER 
      ENDIF 
   70 CONTINUE 
      IF(NDEP.GT.0) THEN 
         WRITE(IPRT,'(//10X,''SYMMETRY WAS SPECIFIED, BUT '', 
     1''CANNOT BE USED HERE'')') 
         NDEP=0 
      ENDIF 
      CALL AXIS(COORD,NUMAT,A,B,C,WTMOL,2,ROT) 
      WRITE(IPRT,'(/9X,''ORIENTATION OF MOLECULE IN FORCE CALCULATION'') 
     1') 
      WRITE(IPRT,'(/,4X,''NO.'',7X,''ATOM'',9X,''X'', 
     19X,''Y'',9X,''Z'',/)') 
      L=0 
      DO 80 I=1,NATOMS 
         IF(LABELS(I) .EQ. 99) GOTO 80 
         L=L+1 
         WRITE(IPRT,'(I6,7X,I3,4X,3F10.4)') 
     1    L,LABELS(I),(COORD(J,L),J=1,3) 
   80 CONTINUE 
      CALL FMAT(FMATRX, TSCF, TDER, DELDIP,ESCF) 
C 
C   THE FORCE MATRIX IS PRINTED AS AN ATOM-ATOM MATRIX RATHER THAN 
C   AS A 3N*3N MATRIX, AS THE 3N MATRIX IS VERY CONFUSING] 
C 
      IJ=0 
      IU=0 
      DO 110 I=1,NUMAT 
         IL=IU+1 
         IU=IL+2 
         IM1=I-1 
         JU=0 
         DO 100 J=1,IM1 
            JL=JU+1 
            JU=JL+2 
            SUM=0.D0 
            DO 90 II=IL,IU 
               DO 90 JJ=JL,JU 
   90       SUM=SUM+FMATRX((II*(II-1))/2+JJ)**2 
            IJ=IJ+1 
  100    STORE(IJ)=SQRT(SUM) 
         IJ=IJ+1 
  110 STORE(IJ)=SQRT( 
     1FMATRX(((IL+0)*(IL+1))/2)**2+ 
     2FMATRX(((IL+1)*(IL+2))/2)**2+ 
     3FMATRX(((IL+2)*(IL+3))/2)**2+2.D0*( 
     4FMATRX(((IL+1)*(IL+2))/2-1)**2+ 
     5FMATRX(((IL+2)*(IL+3))/2-2)**2+ 
     6FMATRX(((IL+2)*(IL+3))/2-1)**2)) 
      IF(DEBUG) THEN 
         WRITE(IPRT,'(//10X,'' FULL FORCE MATRIX, INVOKED BY "DFORCE"'') 
     1') 
         I=-NVAR 
         CALL VECPRT(FMATRX,I) 
      ENDIF 
      WRITE(IPRT,'(//10X,'' FORCE MATRIX IN MILLIDYNES/ANGSTROM'')') 
      CALL VECPRT(STORE,NUMAT) 
      L=(NVAR*(NVAR+1))/2 
      DO 120 I=1,L 
  120 STORE(I)=FMATRX(I) 
      CALL AXIS(COORD,NUMAT,A,B,C,SUM,0,ROT) 
      CALL FRAME(STORE,NUMAT,0, SHIFT) 
      CALL HQRII(STORE,NVAR,NVAR,FREQ,CNORML) 
      WRITE(IPRT,'(//10X,''HEAT OF FORMATION ='',F12.6, 
     1'' KCALS/MOLE'')')ESCF 
      NVIB=NVAR-6 
      IF(ABS(C).LT.1.D-20)NVIB=NVIB+1 
      IF(ID.NE.0)NVIB=NVAR-3 
      DO 130 I=NVIB+1,NVAR 
         J=(FREQ(I)+50.D0)*0.01D0 
  130 FREQ(I)=FREQ(I)-J*100 
      WRITE(IPRT,'(//10X,''TRIVIAL VIBRATIONS, SHOULD BE ZERO'')') 
      WRITE(IPRT,'(/, F9.4,''=TX'',F9.4,''=TY'',F9.4,''=TZ'', 
     1             F9.4,''=RX'',F9.4,''=RY'',F9.4,''=RZ'')') 
     2(FREQ(I),I=NVIB+1,NVAR) 
      WRITE(IPRT,'(//10X,''FORCE CONSTANTS IN MILLIDYNES/ANGSTROM'' 
     1,'' (= 10**5 DYNES/CM)'',/)') 
      WRITE(IPRT,'(8F10.5)')(FREQ(I),I=1,NVIB) 
C CONVERT TO WEIGHTED FMAT 
      WRITE(IPRT,'(//10X,'' ASSOCIATED EIGENVECTORS'')') 
      I=-NVAR 
      CALL MATOUT(CNORML,FREQ,NVIB,I,NVAR) 
      CALL FREQCY(FMATRX,FREQ,CNORML,REDMAS) 
C 
C  CALCULATE ZERO POINT ENERGY 
C 
C 
C  THESE CONSTANTS TAKEN FROM HANDBOOK OF CHEMISTRY AND PHYSICS 62ND ED. 
C   N AVOGADRO'S NUMBER = 6.022045*10**23 
C   H PLANCK'S CONSTANT = 6.626176*10**(-34)JHZ 
C   C SPEED OF LIGHT    = 2.99792458*10**10 CM/SEC 
C   CONST=0.5*N*H*C/(1000*4.184) 
      CONST=1.4295718D-3 
      SUM=0.D0 
      DO 140 I=1,NVAR 
  140 SUM=SUM+FREQ(I) 
      SUM=SUM*CONST 
      WRITE(IPRT,'(//10X,'' ZERO POINT ENERGY'' 
     1, F12.3,'' KILOCALORIES PER MOLE'')')SUM 
      SUMM=0.D0 
      DO 180 I=1,NVAR 
         DO 150 K=1,3 
  150    GRAD(K)=0.D0 
         DO 170 K=1,3 
            SUM=0.D0 
            DO 160 J=1,NVAR 
  160       SUM=SUM+CNORML(J+(I-1)*NVAR)*DELDIP(K,J) 
            SUMM=SUMM+ABS(SUM) 
  170    TRDIP(K,I)=SUM 
  180 CONTINUE 
      DIPOK  =  (SUMM.GT.0.1D0) 
      WRITE(IPRT,'(//3X,'' THE LAST'',I2,'' VIBRATIONS ARE THE'', 
     1'' TRANSLATION AND ROTATION MODES'')')NVAR-NVIB 
      WRITE(IPRT,'(3X,'' THE FIRST THREE OF THESE BEING TRANSLATIONS'', 
     1'' IN X, Y, AND Z, RESPECTIVELY'')') 
      IF(DIPOK) THEN 
         WRITE(IPRT,'(//10X,'' FREQUENCIES, REDUCED MASSES AND '', 
     1''VIBRATIONAL DIPOLES''/)') 
      ELSE 
         WRITE(IPRT,'(//10X,''      FREQUENCIES AND REDUCED MASSES ''/)' 
     1) 
      ENDIF 
      NTO6=NVAR/6 
      NREM6=NVAR-NTO6*6 
      IINC1=-5 
      IF (NTO6.LT.1) GO TO 200 
      DO 190 I=1,NTO6 
         WRITE (IPRT,'(/)') 
         IINC1=IINC1+6 
         IINC2=IINC1+5 
         WRITE (IPRT,'(3X,''I'',10I10)') (J,J=IINC1,IINC2) 
         WRITE (IPRT,'('' FREQ(I)'',6F10.4,/)')(FREQ(J),J=IINC1,IINC2) 
         WRITE (IPRT,'('' MASS(I)'',6F10.5,/)')(REDMAS(J),J=IINC1,IINC2) 
         IF(DIPOK) THEN 
            WRITE (IPRT,'('' DIPX(I)'',6F10.5)') (TRDIP(1,J),J=IINC1, 
     1IINC2) 
            WRITE (IPRT,'('' DIPY(I)'',6F10.5)') (TRDIP(2,J),J=IINC1, 
     1IINC2) 
            WRITE (IPRT,'('' DIPZ(I)'',6F10.5,/)') (TRDIP(3,J),J=IINC1, 
     1IINC2) 
            WRITE (IPRT,'('' DIPT(I)'',6F10.5)') 
     1   (SQRT(TRDIP(1,J)**2+TRDIP(2,J)**2+TRDIP(3,J)**2) 
     2   ,J=IINC1,IINC2) 
         ENDIF 
  190 CONTINUE 
  200 CONTINUE 
      IF (NREM6.LT.1) GO TO 210 
      WRITE (IPRT,'(/)') 
      IINC1=IINC1+6 
      IINC2=IINC1+(NREM6-1) 
      WRITE (IPRT,'(3X,''I'',10I10)') (J,J=IINC1,IINC2) 
      WRITE (IPRT,'('' FREQ(I)'',6F10.4)') (FREQ(J),J=IINC1,IINC2) 
      WRITE (IPRT,'(/,'' MASS(I)'',6F10.5)') (REDMAS(J),J=IINC1,IINC2) 
      IF(DIPOK) THEN 
         WRITE (IPRT,'(/,'' DIPX(I)'',6F10.5)') (TRDIP(1,J),J=IINC1, 
     1IINC2) 
         WRITE (IPRT,'('' DIPY(I)'',6F10.5)') (TRDIP(2,J),J=IINC1,IINC2) 
         WRITE (IPRT,'('' DIPZ(I)'',6F10.5)') (TRDIP(3,J),J=IINC1,IINC2) 
         WRITE (IPRT,'(/,'' DIPT(I)'',6F10.5)') 
     1   (SQRT(TRDIP(1,J)**2+TRDIP(2,J)**2+TRDIP(3,J)**2) 
     2   ,J=IINC1,IINC2) 
      ENDIF 
  210 CONTINUE 
      WRITE(IPRT,'(//10X,'' NORMAL VECTORS'')') 
      I=-NVAR 
      CALL MATOUT(CNORML,FREQ,NVAR,I,NVAR) 
      CALL ANAVIB(COORD,FREQ,NVAR,CNORML,FMATRX) 
      IF(INDEX(KEYWRD,'THERMO').NE.0) THEN 
         CALL GMETRY(GEO,COORD) 
         I=INDEX(KEYWRD,' ROT') 
         IF(I.NE.0) THEN 
            SYM=READA(KEYWRD,I) 
         ELSE 
            SYM=1 
         ENDIF 
         LINEAR=(ABS(A*B*C) .LT. 1.D-10) 
         I=INDEX(KEYWRD,' TRANS') 
C 
C   "I" IS GOING TO MARK THE BEGINNING OF THE GENUINE VIBRATIONS. 
C 
         IF(I.NE.0)THEN 
            WRITE(IPRT,'(//10X,''SYSTEM IS A TRANSITION STATE'')') 
            I=2 
            J=NVIB-1 
         ELSE 
            WRITE(IPRT,'(//10X,''SYSTEM IS A GROUND STATE'')') 
            I=1 
            J=NVIB 
         ENDIF 
         CALL THERMO(A,B,C,LINEAR,SYM,WTMOL,FREQ(I),J) 
      ENDIF 
      CALL SECOND (TFLY) 
      WRITE(IPRT,'('' COMPUTATION TIME '',F10.2,'' SECONDS'')') 
     .         TFLY-TIME0 
      RETURN 
      END 
      SUBROUTINE FORSAV(TIME,DELDIP,IPT,N3,FMATRX, COORD,NVAR,REFH, 
     1                  EVECS,JSTART,FCONST) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
* 
*  FORSAV SAVES AND RESTORES DATA USED IN THE FORCE CALCULATION. 
* 
* ON INPUT TIME = TOTAL TIME ELAPSED SINCE THE START OF THE CALCULATION. 
*          IPT  = LINE OF FORCE MATRIX REACHED, IF IN WRITE MODE, 
*               = 0 IF IN READ MODE. 
*        FMATRX = FORCE MATRIX 
************************************************************************ 
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      DIMENSION FMATRX(*), DELDIP(3,*), COORD(*), EVECS(*), FCONST(*) 
       SAVE
      OPEN(UNIT=9,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 9 
      OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 10 
      IR=9 
      IW=9 
      IF( IPT .EQ. 0 ) THEN 
C 
C   READ IN FORCE DATA 
C 
         READ(IR)TIME,IPT,REFH 
         LINEAR=(NVAR*(NVAR+1))/2 
         READ(IR)(COORD(I),I=1,NVAR) 
         READ(IR,END=10,ERR=10)(FMATRX(I),I=1,LINEAR) 
         READ(IR)((DELDIP(J,I),J=1,3),I=1,IPT) 
         N33=NVAR*NVAR 
         READ(IR)(EVECS(I),I=1,N33) 
         READ(IR)JSTART,(FCONST(I),I=1,NVAR) 
         RETURN 
      ELSE 
C 
C    WRITE FORCE DATA 
C 
         REWIND IW 
         IF(TIME.GT.1.D6)TIME=TIME-1.D6 
         WRITE(IW)TIME,IPT,REFH 
         LINEAR=(NVAR*(NVAR+1))/2 
         WRITE(IW)(COORD(I),I=1,NVAR) 
         WRITE(IW)(FMATRX(I),I=1,LINEAR) 
         WRITE(IW)((DELDIP(J,I),J=1,3),I=1,IPT) 
         N33=NVAR*NVAR 
         WRITE(IR)(EVECS(I),I=1,N33) 
         WRITE(IR)JSTART,(FCONST(I),I=1,NVAR) 
         LINEAR=(NORBS*(NORBS+1))/2 
         WRITE(10)(PA(I),I=1,LINEAR) 
         IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR) 
         IF(IPT.EQ.N3) THEN 
            WRITE(6,'(//10X,''FORCE MATRIX WRITTEN TO DISK'')') 
         ELSE 
            STOP 
         ENDIF 
      ENDIF 
      RETURN 
   10 WRITE(6,20) 
   20 FORMAT(//,10X, 
     1'INSUFFICIENT DATA ON DISK FILES FOR A FORCE CALCULATION',/10X, 
     2'RESTART. PERHAPS THIS STARTED OF AS A FORCE CALCULATION ',/10X, 
     3'BUT THE GEOMETRY HAD TO BE OPTIMIZED FIRST, IN WHICH CASE ',/10X, 
     4'REMOVE THE KEY-WORD "FORCE".') 
      STOP 
      END 
      SUBROUTINE FRAME(FMAT,NUMAT,MODE,SHIFT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /COORD /COORD(3,NUMATM) 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      DIMENSION FMAT(*), SHIFT(6) 
      DIMENSION VIB(6,MAXPAR), ROT(3,3), COORD1(3,NUMATM) 
*********************************************************************** 
* 
*   FRAME APPLIES AN RIGID ORIENTATION TO THE MOLECULE IN A FORCE 
*         CALCULATION. THE TRANSLATIONS ARE GIVEN A 'FORCE CONSTANT' 
*         OF T(X)=500 MILLIDYNES/ANGSTROM 
*            T(Y)=600 MILLIDYNES/ANGSTROM 
*            T(Z)=700 MILLIDYNES/ANGSTROM 
*         AND THE ROTATIONS ARE GIVEN A 'FORCE CONSTANT' OF 
*            R(X)=800 MILLIDYNES/ANGSTROM 
*            R(Y)=900 MILLIDYNES/ANGSTROM 
*            R(Z)=1000 MILLIDYNES/ANGSTROM, 
*    THE ROTATIONS ARE MADE ABOUT AXES DETERMINED BY THE MOMENTS 
*    OF INERTIA, WHICH IN TURN DEPEND ON THE ISOTOPIC MASSES. FOR 
*    THE NORMAL FREQUENCY CALCULATION THESE ARE THE REAL MASSES, 
*    FOR THE FORCE CALCULATION THEY ARE ALL UNITY. 
*********************************************************************** 
      COMMON /EULER / TVEC(3,3), ID 
       SAVE
      CALL AXIS(COORD,NUMAT,A,B,C,SUMW, MODE,ROT ) 
      DO 20 I=1,NUMAT 
         DO 20 J=1,3 
            SUM=0.D0 
            DO 10 K=1,3 
   10       SUM=SUM+COORD(K,I)*ROT(K,J) 
   20 COORD1(J,I)=SUM 
      N3=NUMAT*3 
      J=0 
      WTMASS=1.D0 
      DO 30 I=1,NUMAT 
         IF(MODE.EQ.1)  WTMASS=SQRT(ATMASS(I)) 
         J=J+1 
         VIB(1,J)=WTMASS 
         VIB(2,J)=0.D0 
         VIB(3,J)=0.D0 
         VIB(4,J)=0.D0 
         VIB(5,J)=COORD1(3,I)*WTMASS 
         VIB(6,J)=COORD1(2,I)*WTMASS 
         J=J+1 
         VIB(1,J)=0.D0 
         VIB(2,J)=WTMASS 
         VIB(3,J)=0.D0 
         VIB(4,J)=COORD1(3,I)*WTMASS 
         VIB(5,J)=0.D0 
         VIB(6,J)=-COORD1(1,I)*WTMASS 
         J=J+1 
         VIB(1,J)=0.D0 
         VIB(2,J)=0.D0 
         VIB(3,J)=WTMASS 
         VIB(4,J)=-COORD1(2,I)*WTMASS 
         VIB(5,J)=-COORD1(1,I)*WTMASS 
         VIB(6,J)=0.D0 
   30 CONTINUE 
      J=1 
      DO 50 I=1,NUMAT 
         DO 40 K=4,6 
            X=VIB(K,J) 
            Y=VIB(K,J+1) 
            Z=VIB(K,J+2) 
            VIB(K,J  )=X*ROT(1,1)+Y*ROT(1,2)+Z*ROT(1,3) 
            VIB(K,J+1)=X*ROT(2,1)+Y*ROT(2,2)+Z*ROT(2,3) 
            VIB(K,J+2)=X*ROT(3,1)+Y*ROT(3,2)+Z*ROT(3,3) 
   40    CONTINUE 
         J=J+3 
   50 CONTINUE 
      SUM1=0.D0 
      SUM2=0.D0 
      SUM3=0.D0 
      SUM4=0.D0 
      SUM5=0.D0 
      SUM6=0.D0 
      DO 60 I=1,N3 
         SUM1=SUM1+VIB(1,I)**2 
         SUM2=SUM2+VIB(2,I)**2 
         SUM3=SUM3+VIB(3,I)**2 
         SUM4=SUM4+VIB(4,I)**2 
         SUM5=SUM5+VIB(5,I)**2 
   60 SUM6=SUM6+VIB(6,I)**2 
      IF(SUM1.GT.1.D-5)SUM1=SQRT(1.D0/SUM1) 
      IF(SUM2.GT.1.D-5)SUM2=SQRT(1.D0/SUM2) 
      IF(SUM3.GT.1.D-5)SUM3=SQRT(1.D0/SUM3) 
      IF(SUM4.GT.1.D-5)SUM4=SQRT(1.D0/SUM4) 
      IF(SUM5.GT.1.D-5)SUM5=SQRT(1.D0/SUM5) 
      IF(SUM6.GT.1.D-5)SUM6=SQRT(1.D0/SUM6) 
      IF(ID.NE.0)THEN 
         SUM4=0.D0 
         SUM5=0.D0 
         SUM6=0.D0 
      ENDIF 
      DO 70 I=1,N3 
         VIB(1,I)=VIB(1,I)*SUM1 
         VIB(2,I)=VIB(2,I)*SUM2 
         VIB(3,I)=VIB(3,I)*SUM3 
         VIB(4,I)=VIB(4,I)*SUM4 
         VIB(5,I)=VIB(5,I)*SUM5 
   70 VIB(6,I)=VIB(6,I)*SUM6 
      DO 80 I=1,6 
   80 SHIFT(I)=400.D0+I*100.D0 
      L=0 
      DO 100 I=1,N3 
         DO 100 J=1,I 
            L=L+1 
            SUM1=0.D0 
            DO 90 K=1,6 
   90       SUM1=SUM1+VIB(K,I)*SHIFT(K)*VIB(K,J) 
  100 FMAT(L)=FMAT(L)+SUM1 
      END 
      SUBROUTINE FREQCY(FMATRX,FREQ,CNORML,REDMAS) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
********************************************************************* 
* 
*  FRCE CALCULATES THE FORCE CONSTANTS AND VIBRATIONAL FREQUENCIES 
*       FOR A MOLECULE.  IT USES THE ISOTOPIC MASSES TO WEIGHT THE 
*       FORCE MATRIX 
* 
* ON INPUT   FMATRX   =  FORCE MATRIX, OF SIZE NUMAT*3*(NUMAT*3+1)/2. 
* 
********************************************************************* 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      COMMON /SCRACH/ OLDF(MAXHES), DUMMY(MAXPAR**2-MAXHES) 
      DIMENSION FMATRX(*), REDMAS(*), FREQ(*), CNORML(*) 
      DIMENSION WTMASS(MAXPAR), SHIFT(6) 
      DATA FACT/6.023D23/ 
       SAVE
C 
C    CONVERSION FACTOR FOR SPEED OF LIGHT AND 2 PI. 
C 
      C2PI=1.D0/(2.998D10*3.141592653598D0*2.D0) 
C NOW TO CALCULATE THE VIBRATIONAL FREQUENCIES 
C 
C   FIND CONVERSION CONSTANTS FOR MASS WEIGHTED SYSTEM 
      N3=3*NUMAT 
      L=0 
      DO 10 I=1,NUMAT 
         WEIGHT=1.4142136D0/SQRT(ATMASS(I)) 
         DO 10 J=1,3 
            L=L+1 
   10 WTMASS(L)=WEIGHT 
C    CONVERT TO MASS WEIGHTED FMATRX 
      LINEAR=0 
      DO 20 I=1,N3 
         DO 20 J=1,I 
            LINEAR=LINEAR+1 
            OLDF(LINEAR)=  FMATRX(LINEAR)*1.D5 
   20 FMATRX(LINEAR)=FMATRX(LINEAR)*WTMASS(I)*WTMASS(J) 
C 
C    1.D5 IS TO CONVERT FROM MILLIDYNES/ANGSTROM TO DYNES/CM. 
C 
C    DIAGONALIZE 
      CALL FRAME(FMATRX,NUMAT,1, SHIFT) 
      CALL HQRII(FMATRX,N3,N3,FREQ,CNORML) 
      DO 30 I=1,N3 
         J=(FREQ(I)+50.D0)*0.01D0 
   30 FREQ(I)=FREQ(I)-J*100 
      DO 40 I=1,N3 
   40 FREQ(I)=FREQ(I)*1.D5 
C 
C    CALCULATE REDUCED MASSES, STORE IN REDMAS 
C 
      DO 80 I=1,N3 
         II=(I-1)*N3 
         SUM=0.D0 
         DO 70 J=1,N3 
            JII=J+II 
            JJ=(J*(J-1))/2 
            DO 50 K=1,J 
   50       SUM=SUM+CNORML(JII)*OLDF(JJ+K)*CNORML(K+II) 
            DO 60 K=J+1,N3 
   60       SUM=SUM+CNORML(JII)*OLDF((K*(K-1))/2+J)*CNORML(K+II) 
   70    CONTINUE 
         IF(ABS(FREQ(I)).GT.ABS(SUM)*1.D-20) THEN 
            SUM=1.D0*SUM/FREQ(I) 
         ELSE 
            SUM=0.D0 
         ENDIF 
         IF(SUM.LT.0.D0.OR.SUM.GT.1.D2)SUM=0.D0 
   80 REDMAS(I)=SUM 
C 
C    SWITCH EIGENVALUES TO FREQUENCIES 
      DO 90 I=1,N3 
   90 FREQ(I)=SIGN(SQRT(FACT*ABS(FREQ(I)))*C2PI,FREQ(I)) 
C 
C    CONVERT NORMAL VECTORS TO CARTESIAN COORDINATES 
      IJ=0 
      DO 120 I=1,N3 
         SUM=0.D0 
         DO 100 J=1,N3 
            IJ=IJ+1 
            CNORML(IJ)=CNORML(IJ)*WTMASS(J) 
  100    SUM=SUM+CNORML(IJ)**2 
         SUM=1.D0/SQRT(SUM) 
         IJ=IJ-N3 
         DO 110 J=1,N3 
            IJ=IJ+1 
  110    CNORML(IJ)=CNORML(IJ)*SUM 
  120 CONTINUE 
      RETURN 
      END 
      SUBROUTINE GEOUT 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
********************************************************************** 
* 
*   GEOUT PRINTS THE CURRENT GEOMETRY.  IT CAN BE CALLED ANY TIME, 
*         FROM ANY POINT IN THE PROGRAM AND DOES NOT AFFECT ANYTHING. 
* 
********************************************************************** 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,XPARAM(MAXPAR) 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /ELEMTS/ ELEMNT(107) 
      DIMENSION COORD(3,NUMATM) 
      CHARACTER Q(3)*1, ELEMNT*2 
      LOGICAL CART 
       SAVE
C 
C *** OUTPUT THE PARAMETER DATA. 
C 
      CART=.FALSE. 
      IF(NA(1).NE.0) THEN 
         CART=.TRUE. 
         CALL XYZINT(GEO,NATOMS,NA,NB,NC,1.D0,COORD) 
         NA(1)=99 
      ELSE 
         DO 10 I=1,NATOMS 
            DO 10 J=1,3 
   10    COORD(J,I)=GEO(J,I) 
      ENDIF 
      DEGREE=57.29577951D00 
      WRITE (6,20) 
   20 FORMAT (/6X,'ATOM',4X,'CHEMICAL',3X,'BOND LENGTH',4X,'BOND ANGLE' 
     1,4X ,'TWIST ANGLE',/5X,'NUMBER',3X,'SYMBOL', 5X,'(ANGSTROMS)',5 
     2X,'(DEGREES)',5X,'(DEGREES)',/6X,'(I)',20X,'NA:I',10X,'NB:NA:I',5 
     3X,'NC:NB:NA:I',4X,'NA',2X,'NB',2X,'NC',/) 
      N=1 
      WRITE (6,30) ELEMNT(LABELS(1)) 
   30 FORMAT (8X,1H1,5X,A2) 
      IA=LOC(1,1) 
      Q(1)=' ' 
      IF (LATOM.EQ.2) Q(1)='+' 
      IF (LOC(1,1).NE.2) GO TO 40 
      Q(1)='*' 
      N=N+1 
      IA=LOC(1,N) 
   40 CONTINUE 
      IF(LABELS(2).NE.0) 
     1WRITE (6,50) ELEMNT(LABELS(2)),COORD(1,2),Q(1),NA(2) 
   50 FORMAT (8X,1H2,5X,A2,F16.5,1X,A1,34X,I2) 
      DO 60 J=1,2 
         Q(J)=' ' 
         IF (IA.NE.3) GO TO 60 
         IF (LOC(2,N).NE.J) GO TO 60 
         Q(J)='*' 
         N=N+1 
         IA=LOC(1,N) 
   60 CONTINUE 
      W = COORD(2,3) * DEGREE 
      IF (LATOM.NE.3) GO TO 70 
      J=LPARAM 
      Q(J)='+ ' 
   70 CONTINUE 
      IF(LABELS(3).NE.0) 
     1WRITE (6,80) ELEMNT(LABELS(3)),COORD(1,3),Q(1), 
     2              W,Q(2),NA(3),NB(3) 
   80 FORMAT (8X,1H3,5X,A2,F16.5,1X,A1,F15.5,1X,A1,17X,2(I2,2X)) 
      IF (NATOMS.LT.4) RETURN 
      DO 120 I=4,NATOMS 
         DO 90 J=1,3 
            Q(J)=' ' 
            IF (IA.NE.I) GO TO 90 
            IF (J.NE.LOC(2,N)) GO TO 90 
            Q(J)='*' 
            N=N+1 
            IA=LOC(1,N) 
   90    CONTINUE 
         W = COORD(2,I) * DEGREE 
         X = COORD(3,I) * DEGREE 
         IF (LATOM.NE.I) GO TO 100 
         J=LPARAM 
         Q(J)='+ ' 
  100    WRITE (6,110) I,ELEMNT(LABELS(I)),COORD(1,I),Q(1),W,Q(2), 
     1                 X,Q(3),NA(I),NB(I),NC(I) 
  110    FORMAT (7X,I2 ,5X,A2,F16.5,1X,A1,F15.5,1X,A1,F12.5,1X,A1,I5,2I4 
     1) 
  120 CONTINUE 
      RETURN 
      END 
      SUBROUTINE GETGEO(IREAD,LABELS,GEO,LOPT,NA,NB,NC,AMS,NATOMS,INT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
* 
*   GETGEO READS IN THE GEOMETRY. THE ELEMENT IS SPECIFIED BY IT'S 
*          CHEMICAL SYMBOL, OR, OPTIONALLY, BY IT'S ATOMIC NUMBER. 
* 
*  ON INPUT   IREAD  = CHANNEL NUMBER FOR READ 
*             AMS    = DEFAULT ATOMIC MASSES. 
* 
* ON OUTPUT LABELS = ATOMIC NUMBERS OF ALL ATOMS, INCLUDING DUMMIES. 
*           GEO    = INTERNAL COORDINATES, IN ANGSTROMS, AND DEGREES. 
*           LOPT   = INTEGER ARRAY, A '1' MEANS OPTIMISE THIS PARAMETER, 
*                    '0' MEANS DO NOT OPTIMISE, AND A '-1' LABELS THE 
*                    REACTION COORDINATE. 
*           NA     = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) 
*           NB     = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) 
*           NC     = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) 
*           ATMASS = ATOMIC MASSES OF ATOMS. 
************************************************************************ 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      DIMENSION ISTART(40), XYZ(3,NUMATM) 
      DIMENSION GEO(3,*),NA(*),NB(*),NC(*),AMS(*), LOPT(3,*) 
     .         ,LABELS(*) 
      LOGICAL INT 
      LOGICAL LEADSP 
      CHARACTER ELEMNT(107)*2, LINE*80, SPACE*1, NINE*1, ZERO*1 
     1         ,COMMA*1, STRING*80, ELE*2 
      DATA (ELEMNT(I),I=1,107)/'H','HE', 
     1 'LI','BE','B','C','N','O','F','NE', 
     2 'NA','MG','AL','SI','P','S','CL','AR', 
     3 'K','CA','SC','TI','V','CR','MN','FE','CO','NI','CU', 
     4 'ZN','GA','GE','AS','SE','BR','KR', 
     5 'RB','SR','Y','ZR','NB','MO','TC','RU','RH','PD','AG', 
     6 'CD','IN','SN','SB','TE','I','XE', 
     7 'CS','BA','LA','CE','PR','ND','PM','SM','EU','GD','TB','DY', 
     8 'HO','ER','TM','YB','LU','HF','TA','W','RE','OS','IR','PT', 
     9 'AU','HG','TL','PB','BI','PO','AT','RN', 
     1 'FR','RA','AC','TH','PA','U','NP','PU','AM','CM','BK','CF','XX', 
     2 'FM','MD','NO','++','+','--','-','TV'/ 
      DATA COMMA,SPACE,NINE,ZERO/',',' ','9','0'/ 
       SAVE
      ILOWA = ICHAR('a') 
      ILOWZ = ICHAR('z') 
      ICAPA = ICHAR('A') 
      NATOMS=0 
      NUMAT=0 
   10 READ(IREAD,'(A)',END=90,ERR=110)LINE 
      IF(LINE.EQ.' ') GO TO 90 
      IF(NATOMS.GT.NUMATM)THEN 
         WRITE(IPRT,'(//9X,''****  MAX. NUMBER OF ATOMS ALLOWED:'',I4)') 
     .              NUMATM 
         STOP 
      ENDIF 
      NATOMS=NATOMS+1 
*   CLEAN THE INPUT DATA 
************************************************************************ 
      DO 20 I=1,80 
         ILINE=ICHAR(LINE(I:I)) 
         IF(ILINE.GE.ILOWA.AND.ILINE.LE.ILOWZ) THEN 
            LINE(I:I)=CHAR(ILINE+ICAPA-ILOWA) 
         ENDIF 
   20 CONTINUE 
************************************************************************ 
      DO 30 I=1,80 
   30 IF(LINE(I:I).LT.SPACE .OR. 
     1       LINE(I:I).EQ.COMMA) LINE(I:I)=SPACE 
* 
*   INITIALIZE ISTART TO INTERPRET BLANKS AS ZERO'S 
      DO 40 I=1,10 
   40 ISTART(I)=80 
* FIND INITIAL DIGIT OF ALL NUMBERS, CHECK FOR LEADING SPACES FOLLOWED 
*     BY A CHARACTER AND STORE IN ISTART 
      LEADSP=.TRUE. 
      NVALUE=0 
      DO 50 I=1,80 
         IF (LEADSP.AND.LINE(I:I).NE.SPACE) THEN 
            NVALUE=NVALUE+1 
            ISTART(NVALUE)=I 
         END IF 
         LEADSP=(LINE(I:I).EQ.SPACE) 
   50 CONTINUE 
* 
* ESTABLISH THE ELEMENT'S NAME AND ISOTOPE, CHECK FOR ERRORS OR E.O.DATA 
* 
      WEIGHT=0.D0 
      STRING=LINE(ISTART(1):ISTART(2)-1) 
      IF( STRING(1:1) .GE. ZERO .AND. STRING(1:1) .LE. NINE) THEN 
*  ATOMIC NUMBER USED: NO ISOTOPE ALLOWED 
         LABEL=READA(STRING,1) 
         IF (LABEL.EQ.0) GO TO 80 
         IF (LABEL.LT.0.OR.LABEL.GT.107) THEN 
            WRITE(IPRT,'(''  ILLEGAL ATOMIC NUMBER'')') 
            GO TO 120 
         END IF 
         GO TO 70 
      END IF 
*  ATOMIC SYMBOL USED 
      REAL=READA(STRING,1) 
      IF (REAL.LT..005) THEN 
*   NO ISOTOPE 
         ELE=STRING(1:2) 
      ELSE 
         WEIGHT=REAL 
         IF( STRING(2:2) .GE. ZERO .AND. STRING(2:2) .LE. NINE) THEN 
            ELE=STRING(1:1) 
         ELSE 
            ELE=STRING(1:2) 
         END IF 
      END IF 
*   CHECK FOR ERROR IN ATOMIC SYMBOL 
      DO 60 I=1,107 
         IF(ELE.EQ.ELEMNT(I)) THEN 
            LABEL=I 
            GO TO 70 
         END IF 
   60 CONTINUE 
      WRITE(IPRT,'(''  UNRECOGNIZED ELEMENT NAME: ('',A,'')'')')ELE 
      GOTO 120 
* 
* ALL O.K. 
* 
   70 IF (LABEL.NE.99) NUMAT=NUMAT+1 
      IF(WEIGHT.NE.0.D0)THEN 
         WRITE(IPRT,'('' FOR ATOM'',I4,''  ISOTOPIC MASS:'' 
     1    ,F12.5)')NATOMS, WEIGHT 
         ATMASS(NUMAT)=WEIGHT 
      ELSE 
         IF(LABEL .NE. 99)  ATMASS(NUMAT)=AMS(LABEL) 
      ENDIF 
      LABELS(NATOMS)   =LABEL 
      GEO(1,NATOMS)    =READA(LINE,ISTART(2)) 
      LOPT(1,NATOMS)   =READA(LINE,ISTART(3)) 
      GEO(2,NATOMS)    =READA(LINE,ISTART(4)) 
      LOPT(2,NATOMS)   =READA(LINE,ISTART(5)) 
      GEO(3,NATOMS)    =READA(LINE,ISTART(6)) 
      LOPT(3,NATOMS)   =READA(LINE,ISTART(7)) 
      NA(NATOMS)       =READA(LINE,ISTART(8)) 
      NB(NATOMS)       =READA(LINE,ISTART(9)) 
      NC(NATOMS)       =READA(LINE,ISTART(10)) 
      GOTO 10 
* 
* ALL DATA READ IN, CLEAN UP AND RETURN 
* 
   80 NATOMS=NATOMS-1 
   90 NA(2)=1 
      IF(NATOMS.GT.3)THEN 
         INT=(NA(4).NE.0) 
      ELSE 
         IF(GEO(2,3).LT.10.AND.NATOMS.EQ.3) 
     1WRITE(IPRT,'(//10X,'' WARNING: INTERNAL COORDINATES ARE ASSUMED -' 
     .',/10X,'' FOR THREE-ATOM SYSTEMS '',//)') 
         INT=.TRUE. 
      ENDIF 
      IF(  .NOT. INT ) THEN 
         DO 100 I=1,NATOMS 
            DO 100 J=1,3 
  100    XYZ(J,I)=GEO(J,I) 
         DEGREE=180.D0/3.141592652589D0 
         CALL XYZINT(XYZ,NATOMS,NA,NB,NC,DEGREE,GEO) 
      ELSE 
         IF(LOPT(1,1)+LOPT(2,1)+LOPT(3,1)+LOPT(2,2)+LOPT(3,2)+ 
     1        LOPT(3,3) .GT. 0)THEN 
            LOPT(1,1)=0 
            LOPT(2,1)=0 
            LOPT(3,1)=0 
            LOPT(2,2)=0 
            LOPT(3,2)=0 
            LOPT(3,3)=0 
            WRITE(IPRT,'(//10X,'' AN UNOPTIMIZABLE GEOMETRIC PARAMETER H 
     .AS'',/10X,'' BEEN MARKED FOR OPTIMIZATION. THIS IS A NON-FATAL '' 
     .,''ERROR'')') 
         ENDIF 
      ENDIF 
      IF(NA(3).EQ.0) THEN 
         NB(3)=1 
         NA(3)=2 
      ENDIF 
      RETURN 
* ERROR CONDITIONS 
  110 IF(IREAD.EQ.LEC) THEN 
         WRITE(IPRT,'( '' ERROR DURING READ AT ATOM NUMBER '', I3 )') 
     .              NATOMS 
      ELSE 
         NATOMS=0 
         RETURN 
      ENDIF 
  120 J=NATOMS-1 
      WRITE(IPRT,'('' DATA CURRENTLY READ IN ARE '')') 
      DO 130 K=1,J 
  130 WRITE(IPRT,140) LABELS(K),(GEO(J,K),LOPT(J,K),J=1,3) 
     .               ,NA(K),NB(K),NC(K) 
  140 FORMAT(I4,2X,3(F10.5,2X,I2,2X),3(I2,1X)) 
      CALL EXIT 
      END 
      SUBROUTINE GETSYM 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /KEYWRD/ KEYWRD 
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR), 
     1                LOCDEP(MAXPAR) 
C*********************************************************************** 
C 
C   GETSYM READS IN THE SYMMETRY DEPENDENCE RELATIONSHIPS. 
C 
C   ON EXIT     NDEP    = NUMBER OF SYMMETRY RELATIONS. 
C               LOCPAR  = ARRAY OF REFERENCE FUNCTION INDICES. 
C               IDEPFN  = ARRAY OF REFERENCE ATOM LOCATIONS. 
C               LOCDEP  = ARRAY OF DEPENDENT ATOM LOCATIONS. 
C 
C*********************************************************************** 
C 
C     LOCDEP IS THE ATOM WHOSE COORDINATES DEPEND ON THE COORDINATES OF 
C     LOCPAR. 
C     LOCPAR IS THE ATOM WHOSE COORDINATES ARE USED TO CALCULATE THOSE 
C     OF LOCDEP 
C     IDEPFN POINTS TO THE PARTICULAR FUNCTION TO BE USED (SEE NDDO) 
C 
C*********************************************************************** 
      DIMENSION IVALUE(40),VALUE(40) 
      CHARACTER  TEXT(18)*60, KEYWRD*80, LINE*80 
      DATA TEXT/ 
     1' BOND LENGTH    IS SET EQUAL TO THE REFERENCE BOND LENGTH   ', 
     2' BOND ANGLE     IS SET EQUAL TO THE REFERENCE BOND ANGLE    ', 
     3' DIHEDRAL ANGLE IS SET EQUAL TO THE REFERENCE DIHEDRAL ANGLE', 
     4' DIHEDRAL ANGLE VARIES AS  90 DEGREES - REFERENCE DIHEDRAL  ', 
     5' DIHEDRAL ANGLE VARIES AS  90 DEGREES + REFERENCE DIHEDRAL  ', 
     6' DIHEDRAL ANGLE VARIES AS 120 DEGREES - REFERENCE DIHEDRAL  ', 
     7' DIHEDRAL ANGLE VARIES AS 120 DEGREES + REFERENCE DIHEDRAL  ', 
     8' DIHEDRAL ANGLE VARIES AS 180 DEGREES - REFERENCE DIHEDRAL  ', 
     9' DIHEDRAL ANGLE VARIES AS 180 DEGREES + REFERENCE DIHEDRAL  ', 
     1' DIHEDRAL ANGLE VARIES AS 240 DEGREES - REFERENCE DIHEDRAL  ', 
     2' DIHEDRAL ANGLE VARIES AS 240 DEGREES + REFERENCE DIHEDRAL  ', 
     3' DIHEDRAL ANGLE VARIES AS 270 DEGREES - REFERENCE DIHEDRAL  ', 
     4' DIHEDRAL ANGLE VARIES AS 270 DEGREES - REFERENCE DIHEDRAL  ', 
     5' DIHEDRAL ANGLE VARIES AS - REFERENCE DIHEDRAL              ', 
     6' BOND LENGTH VARIES AS HALF THE REFERENCE BOND LENGTH       ', 
     7' BOND ANGLE VARIES AS HALF THE REFERENCE BOND ANGLE         ', 
     8' BOND ANGLE VARIES AS 180 DEGREES - REFERENCE BOND ANGLE    ', 
     9' THE USER HAS TO SUPPLY THIS FUNCTION IN DEPVAR             '/ 
C 
C TITLE OUTPUT 
       SAVE
      WRITE (6,10) 
   10 FORMAT (///5X,25HPARAMETER DEPENDENCE DATA// 
     1'        REFERENCE ATOM      FUNCTION NO.    DEPENDENT ATOM(S)') 
C 
C INPUT SYMMETRY : FUNCTION, REFERANCE PARAMETER, AND DEPENDENT ATOMS 
C 
      NDEP=0 
   20 READ(5,'(A)',END=70) LINE 
      CALL NUCHAR(LINE,VALUE,NVALUE) 
C   INTEGER VALUES 
      DO 30 I=1,NVALUE 
   30 IVALUE(I)=VALUE(I) 
C   FILL THE LOCDEP ARRAY 
      IF(NVALUE.EQ.0.OR.IVALUE(3).EQ.0) GO TO 70 
      DO 40 I=3,NVALUE 
         IF(IVALUE(I).EQ.0) GOTO 50 
         NDEP=NDEP+1 
         LOCDEP(NDEP)=IVALUE(I) 
         LOCPAR(NDEP)=IVALUE(1) 
         IDEPFN(NDEP)=IVALUE(2) 
   40 CONTINUE 
   50 LL=I-1 
      WRITE(6,60)IVALUE(1),IVALUE(2),(IVALUE(J),J=3,LL) 
   60 FORMAT(I13,I19,I14,20I3) 
      GO TO 20 
C 
C CLEAN UP 
   70 CONTINUE 
      WRITE(6,80) 
   80 FORMAT(/10X,'   DESCRIPTIONS OF THE FUNCTIONS USED',/) 
      DO 120 J=1,18 
         DO 90 I=1,NDEP 
            IF(IDEPFN(I).EQ.J) GOTO 100 
   90    CONTINUE 
         GOTO 120 
  100    WRITE(6,110)J,TEXT(J) 
  110    FORMAT(I4,5X,A) 
  120 CONTINUE 
      RETURN 
      END 
      SUBROUTINE GMETRY(GEO,COORD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1NA(NUMATM),NB(NUMATM),NC(NUMATM) 
     2       /EULER / TVEC(3,3), ID 
      COMMON /REACTN/ STEP, GEOA(3,NUMATM), GEOVEC(3,NUMATM),COLCST 
      DIMENSION GEO(3,*),COORD(3,*) 
      CHARACTER *15 NDIMEN(4) 
      LOGICAL FIRST 
      DATA FIRST/.TRUE./, NDIMEN/' MOLECULE     ',' POLYMER       ', 
     1'LAYER STRUCTURE',' SOLID         '/ 
C*********************************************************************** 
C 
C    GMETRY  COMPUTES COORDINATES FROM BOND-ANGLES AND LENGTHS. 
C 
C     THREE SEPARATE OPTIONS EXIST WITHIN GMETRY. THESE ARE: 
C    (A) IF NA(1) IS EQUAL TO 99 (IMPOSSIBLE UNDER NORMAL CIRCUMSTANCES) 
C        THEN GEO IS ASSUMED TO BE IN CARTESIAN RATHER THAN INTERNAL 
C        COORDINATES, AND COORD IS THEN SET EQUAL TO GEO. 
C    (B) IF STEP IS NON-ZERO (THIS IS THE CASE WHEN "SADDLE" IS USED) 
C        THEN GEO IS FIRST MODIFIED BY SHIFTING THE INTERNAL COORDINATES 
C        ALONG A RADIUS FROM GEOA TO PLACE GEO AT ADISTANCESTEPFROMGEOA. 
C    (C) NORMAL CONVERSION FROM INTERNAL TO CARTESIAN COORDINATES, 
C        REMOVING THE DUMMY ATOMS 
C 
C  ON INPUT: 
C         GEO    = ARRAY OF INTERNAL COORDINATES. 
C         NATOMS = NUMBER OF ATOMS, INCLUDING DUMMIES. 
C         NA     = ARRAY OF ATOM LABELS FOR BOND LENGTHS. 
C         NB     =   "          "           ANGLES WITH NA. 
C         NC     =   "          "           DIHEDRALS WITH NB,NA 
C 
C  ON OUTPUT: 
C         COORD  = ARRAY OF CARTESIAN COORDINATES, WITHOUT DUMMIES. 
C 
C*********************************************************************** 
C                                     OPTION (A) 
       SAVE
      IF(NA(1).EQ.99) THEN 
         DO 10 I=1,3 
            DO 10 J=1,NATOMS 
   10    COORD(I,J)=GEO(I,J) 
         GOTO 110 
      ENDIF 
C                                     OPTION (B) 
      IF(ABS(STEP) .GT. 1.D-4) THEN 
         SUM=0.D0 
         DO 20 I=1,NATOMS 
            DO 20 J=1,3 
               GEOVEC(J,I)=GEO(J,I)-GEOA(J,I) 
   20    SUM=SUM+GEOVEC(J,I)**2 
         SUM=SQRT(SUM) 
         ERROR=(SUM-STEP)/SUM 
         DO 30 I=1,NATOMS 
         DO 30 J=1,3 
   30    GEO(J,I)=GEO(J,I)-ERROR*GEOVEC(J,I) 
      ENDIF 
C                                     OPTION (C) 
      CALL INTCAR (GEO,COORD) 
C 
C *** NOW REMOVE THE TRANSLATION VECTORS, IF ANY, FROM THE ARRAY COOR 
C 
  110 CONTINUE 
      K=NATOMS 
  120 IF(LABELS(K).NE.107) GOTO 130 
      K=K-1 
      GOTO 120 
  130 K=K+1 
      IF(K.GT.NATOMS) GOTO 180 
C 
C   SYSTEM IS A SOLID, OF DIMENSION NATOMS+1-K 
C 
      L=0 
      DO 140 I=K,NATOMS 
         L=L+1 
         MC=NA(I) 
         DO 140 J=1,3 
            TVEC(J,L)=COORD(J,I)-COORD(J,MC) 
  140 CONTINUE 
      ID=L 
      IF (FIRST) THEN 
         FIRST=.FALSE. 
         WRITE(6,150)NDIMEN(ID+1) 
  150    FORMAT(/10X,'    THE SYSTEM IS A ',A15,/) 
         IF(ID.EQ.0) GOTO 180 
         WRITE(6,160) 
         WRITE(6,170)(I,(TVEC(J,I),J=1,3),I=1,ID) 
  160    FORMAT(/,'                UNIT CELL TRANSLATION VECTORS',/ 
     1/,'              X              Y              Z') 
  170    FORMAT('    T',I1,' = ',F11.7,'    ',F11.7,'    ',F11.7) 
      ENDIF 
  180 CONTINUE 
C 
C *** REMOVE TRANSLATION VECTORS AND DUMMY ATOMS 
C 
      J=0 
      DO 200 I=1,NATOMS 
         IF (LABELS(I).EQ.99.OR.LABELS(I).EQ.107) GO TO 200 
         J=J+1 
         DO 190 K=1,3 
  190    COORD(K,J)=COORD(K,I) 
  200 CONTINUE 
      CUTOFF=200.D0 
      RETURN 
      END 
      SUBROUTINE INTCAR (GEO,COORD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM) 
     .               ,NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      DIMENSION GEO(3,*),COORD(3,*) 
C*********************************************************************** 
C 
C    INTCAR  COMPUTES COORDINATES FROM BOND-ANGLES AND LENGTHS. 
C *** IT IS ADAPTED FROM THE PROGRAM WRITTEN BY M.J.S. DEWAR. 
C 
C 
C  ON INPUT: 
C         GEO    = ARRAY OF INTERNAL COORDINATES. 
C         NATOMS = NUMBER OF ATOMS, INCLUDING DUMMIES. 
C         NA     = ARRAY OF ATOM LABELS FOR BOND LENGTHS. 
C         NB     =   "          "           ANGLES. 
C         NC     =   "          "           DIHEDRALS. 
C 
C  ON OUTPUT: 
C         COORD  = ARRAY OF CARTESIAN COORDINATES, INCLUDING DUMMIES. 
C 
C  CONVENTION FOR ORIENTATION OF DIHEDRALS: 
C         KLYNE, PRELOG, EXPERIENCA VOL. 16, PP 521 (1960). 
C  NOTE ... THE SAME CONVENTION IS USED IN THE FOLLOWING ROUTINES: 
C  XYZINT, JINCAR 
C 
C*********************************************************************** 
       SAVE
      COORD(1,1)=0.0D00 
      COORD(2,1)=0.0D00 
      COORD(3,1)=0.0D00 
      COORD(1,2)=GEO(1,2) 
      COORD(2,2)=0.0D00 
      COORD(3,2)=0.0D00 
      IF(NATOMS.EQ.2) RETURN 
      CCOS=COS(GEO(2,3)) 
      IF(NA(3).EQ.1)THEN 
         COORD(1,3)=COORD(1,1)+GEO(1,3)*CCOS 
      ELSE 
         COORD(1,3)=COORD(1,2)-GEO(1,3)*CCOS 
      ENDIF 
      COORD(2,3)=GEO(1,3)*SIN(GEO(2,3)) 
      COORD(3,3)=0.0D00 
      DO 100 I=4,NATOMS 
         COSA=COS(GEO(2,I)) 
         MB=NB(I) 
         MC=NA(I) 
         XB=COORD(1,MB)-COORD(1,MC) 
         YB=COORD(2,MB)-COORD(2,MC) 
         ZB=COORD(3,MB)-COORD(3,MC) 
         RBC=1.0D00/SQRT(XB*XB+YB*YB+ZB*ZB) 
         IF (ABS(COSA).LT.0.99999999991D00) GO TO 40 
C 
C     ATOMS MC, MB, AND (I) ARE COLLINEAR 
C 
         RBC=GEO(1,I)*RBC*COSA 
         COORD(1,I)=COORD(1,MC)+XB*RBC 
         COORD(2,I)=COORD(2,MC)+YB*RBC 
         COORD(3,I)=COORD(3,MC)+ZB*RBC 
         GO TO 100 
C 
C     THE ATOMS ARE NOT COLLINEAR 
C 
   40    MA=NC(I) 
         XA=COORD(1,MA)-COORD(1,MC) 
         YA=COORD(2,MA)-COORD(2,MC) 
         ZA=COORD(3,MA)-COORD(3,MC) 
C 
C     ROTATE ABOUT THE Z-AXIS TO MAKE YB=0, AND XB POSITIVE.  IF XYB IS 
C     TOO SMALL, FIRST ROTATE THE Y-AXIS BY 90 DEGREES. 
C 
         XYB=SQRT(XB*XB+YB*YB) 
         K=-1 
         IF (XYB.GT.0.1D00) GO TO 50 
         XPA=ZA 
         ZA=-XA 
         XA=XPA 
         XPB=ZB 
         ZB=-XB 
         XB=XPB 
         XYB=SQRT(XB*XB+YB*YB) 
         K=+1 
C 
C     ROTATE ABOUT THE Y-AXIS TO MAKE ZB VANISH 
C 
   50    COSTH=XB/XYB 
         SINTH=YB/XYB 
         XPA=XA*COSTH+YA*SINTH 
         YPA=YA*COSTH-XA*SINTH 
         SINPH=ZB*RBC 
         COSPH=SQRT(ABS(1.D00-SINPH*SINPH)) 
         XQA=XPA*COSPH+ZA*SINPH 
         ZQA=ZA*COSPH-XPA*SINPH 
C 
C     ROTATE ABOUT THE X-AXIS TO MAKE ZA=0, AND YA POSITIVE. 
C 
         YZA=SQRT(YPA**2+ZQA**2) 
         IF(YZA.LT.2.D-2 )THEN 
            IF(YZA.LT.1.D-4)GOTO 70 
            WRITE(6,'(//20X,'' CALCULATION ABANDONED AT THIS POINT'')') 
            WRITE(6,'(//10X,'' THREE ATOMS BEING USED TO DEFINE THE'',/ 
     110X,'' COORDINATES OF A FOURTH ATOM, WHOSE BOND-ANGLE IS'')') 
            WRITE(6,'(10X,'' NOT ZERO OR 180 DEGREEES, ARE '', 
     1''IN AN ALMOST STRAIGHT'',/ 
     210X,'' LINE.  THERE IS A HIGH PROBABILITY THAT THE'',/ 
     310X,'' COORDINATES OF THE ATOM WILL BE INCORRECT.'')') 
            WRITE(6,'(//20X,''THE FAULTY ATOM IS ATOM NUMBER'',I4)')I 
            CALL GEOUT 
            WRITE(6,'(//20X,''CARTESIAN COORDINATES UP TO FAULTY ATOM'') 
     1') 
            WRITE(6,'(//5X,''I'',12X,''X'',12X,''Y'',12X,''Z'')') 
            DO 60 J=1,I 
   60       WRITE(6,'(I6,F16.5,2F13.5)')J,(COORD(K,J),K=1,3) 
            WRITE(6,'(//6X,'' ATOMS'',I3,'','',I3,'', AND'',I3, 
     1'' ARE WITHIN'',F7.4,'' ANGSTROMS OF A STRAIGHT LINE'')') 
     2MC,MB,MA,YZA 
            STOP 
         ENDIF 
         COSKH=YPA/YZA 
         SINKH=ZQA/YZA 
         GOTO 80 
   70    CONTINUE 
C 
C   ANGLE TOO SMALL TO BE IMPORTANT 
C 
         COSKH=1.D0 
         SINKH=0.D0 
   80    CONTINUE 
C 
C     COORDINATES :-   A=(XQA,YZA,0),   B=(RBC,0,0),  C=(0,0,0) 
C     NONE ARE NEGATIVE. 
C     THE COORDINATES OF I ARE EVALUATED IN THE NEW FRAME. 
C 
         SINA=SIN(GEO(2,I)) 
         SIND=-SIN(GEO(3,I)) 
         COSD=COS(GEO(3,I)) 
         XD=GEO(1,I)*COSA 
         YD=GEO(1,I)*SINA*COSD 
         ZD=GEO(1,I)*SINA*SIND 
C 
C     TRANSFORM THE COORDINATES BACK TO THE ORIGINAL SYSTEM. 
C 
         YPD=YD*COSKH-ZD*SINKH 
         ZPD=ZD*COSKH+YD*SINKH 
         XPD=XD*COSPH-ZPD*SINPH 
         ZQD=ZPD*COSPH+XD*SINPH 
         XQD=XPD*COSTH-YPD*SINTH 
         YQD=YPD*COSTH+XPD*SINTH 
         IF (K.LT.1) GO TO 90 
         XRD=-ZQD 
         ZQD=XQD 
         XQD=XRD 
   90    COORD(1,I)=XQD+COORD(1,MC) 
         COORD(2,I)=YQD+COORD(2,MC) 
         COORD(3,I)=ZQD+COORD(3,MC) 
  100 CONTINUE 
      RETURN 
      END 
      SUBROUTINE GRID 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************************ 
* 
*  GRID CALCULATES THE ENERGY-SURFACE RESULTING FROM VARIATION OF 
*       TWO COORDINATES. THE STEP-SIZE IS STEP1 AND STEP2, AND A 11 
*       BY 11 GRID OF POINTS IS GENERATED 
* 
************************************************************************ 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /GRAVEC/ COSINE 
      COMMON /MESH  / LATOM1, LPARA1, LATOM2, LPARA2 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION SURFAC(11,11) 
      CHARACTER*80 KEYWRD 
       SAVE
      STEP1=READA(KEYWRD,INDEX(KEYWRD,'STEP1=')+6) 
      STEP2=READA(KEYWRD,INDEX(KEYWRD,'STEP2=')+6) 
C 
C  THE CENTRAL VALUE OF THE FIRST AND SECOND DIMENSIONS ARE 
C      GEO(LPARA1,LATOM1) AND GEO(LPARA2,LATOM2) 
      NPTS=11 
C NPTS MUST BE ODD, IN ORDER TO HAVE A CENTER POINT. 
      NPTS2=NPTS/2 
      DEGREE=180.D0/3.14159265359D0 
      IF(LPARA1.NE.1)STEP1=STEP1/DEGREE 
      IF(LPARA2.NE.1)STEP2=STEP2/DEGREE 
      START1=GEO(LPARA1,LATOM1)-(NPTS2+1)*STEP1 
      START2=GEO(LPARA2,LATOM2)-(NPTS2+1)*STEP2 
C 
C  NOW TO SWEEP THROUGH THE GRID OF POINTS LEFT TO RIGHT THEN RIGHT 
C  TO LEFT. THIS SHOULD AVOID THE GEOMETRY OR SCF GETTING MESSED UP. 
C 
      GEO(LPARA1,LATOM1)=START1 
      GEO(LPARA2,LATOM2)=START2 
      IONE=-1.D0 
      IF(LPARA1.NE.1) THEN 
         C1=DEGREE 
      ELSE 
         C1=1.D0 
      ENDIF 
      IF(LPARA2.NE.1) THEN 
         C2=DEGREE 
      ELSE 
         C2=1.D0 
      ENDIF 
      WRITE(6,'(''   FIRST VARIABLE   SECOND VARIABLE   FUNCTION'')') 
      DO 20 ILOOP=1,NPTS 
         GEO(LPARA1,LATOM1)=GEO(LPARA1,LATOM1)+STEP1 
         IONE=-IONE 
         JLOOP1=0 
         IF(IONE.LT.0)JLOOP1=NPTS+1 
         DO 10 JLOOP=1,NPTS 
            JLOOP1=JLOOP1+IONE 
            GEO(LPARA2,LATOM2)=GEO(LPARA2,LATOM2)+STEP2*IONE 
            CALL FLEPO(XPARAM, NVAR, ESCF) 
            SURFAC(ILOOP,JLOOP1)=ESCF 
            WRITE(6,'('' :'',F16.5,F16.5,F13.6)')GEO(LPARA1,LATOM1)*C1, 
     1        GEO(LPARA2,LATOM2)*C2,ESCF 
   10    CONTINUE 
         GEO(LPARA2,LATOM2)=GEO(LPARA2,LATOM2)+STEP2*IONE 
   20 CONTINUE 
      WRITE(6,'(/10X,''HORIZONTAL: VARYING SECOND PARAMETER,'', 
     1          /10X,''VERTICAL:   VARYING FIRST PARAMETER'')') 
      WRITE(6,'(/10X,''WHOLE OF GRID, SUITABLE FOR PLOTTING'',//)') 
      DO 30 I=1,NPTS 
   30 WRITE(6,'(11F7.2)')(SURFAC(J,I),J=1,NPTS) 
      END 
      SUBROUTINE H1ELEC(NI,NJ,XI,XJ,SMAT) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XI(3),XJ(3),SMAT(9,9), BI(9), BJ(9) 
C*********************************************************************** 
C 
C  H1ELEC FORMS THE ONE-ELECTRON MATRIX BETWEEN TWO ATOMS. 
C 
C   ON INPUT    NI   = ATOMIC NO. OF FIRST ATOM. 
C               NJ   = ATOMIC NO. OF SECOND ATOM. 
C               XI   = COORDINATES OF FIRST ATOM. 
C               XJ   = COORDINATES OF SECOND ATOM. 
C 
C   ON OUTPUT   SMAT = MATRIX OF ONE-ELECTRON INTERACTIONS. 
C 
C*********************************************************************** 
      COMMON /BETAS / BETAS(107),BETAP(107),BETAD(107) 
      COMMON /BETA3 / BETA3(153) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /VSIPS / VS(107),VP(107),VD(107) 
      COMMON /NATORB/ NATORB(107) 
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U,KDUM(6) 
      DIMENSION SBITS(9,9), LIMS(3,2), XJUC(3) 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST 
      EQUIVALENCE (L1L,LIMS(1,1)) 
      DATA ITYPE /1/,FIRST/.TRUE./ 
       SAVE
      IF(ID.EQ.0) THEN 
         CALL DIAT(NI,NJ,XI,XJ,SMAT) 
      ELSE 
         IF(FIRST)THEN 
            FIRST=.FALSE. 
            DO 10 I=1,ID 
               LIMS(I,1)=-1 
   10       LIMS(I,2)= 1 
            DO 20 I=ID+1,3 
               LIMS(I,1)=0 
   20       LIMS(I,2)=0 
         ENDIF 
         DO 30 I=1,9 
            DO 30 J=1,9 
   30    SMAT(I,J)=0 
         DO 60 I=L1L,L1U 
            DO 60 J=L2L,L2U 
               DO 60 K=L3L,L3U 
                  DO 40 L=1,3 
   40             XJUC(L)=XJ(L)+TVEC(L,1)*I+TVEC(L,2)*J+TVEC(L,3)*K 
                  CALL DIAT(NI,NJ,XI,XJUC,SBITS) 
                  DO 50 L=1,9 
                     DO 50 M=1,9 
   50             SMAT(L,M)=SMAT(L,M)+SBITS(L,M) 
   60    CONTINUE 
      ENDIF 
   70 GOTO (80,90,100) ITYPE 
   80 IF(INDEX(KEYWRD,'MINDO') .NE. 0) THEN 
         ITYPE=2 
      ELSE 
         ITYPE=3 
      ENDIF 
      GOTO 70 
   90 CONTINUE 
      II=MAX(NI,NJ) 
      NBOND=(II*(II-1))/2+NI+NJ-II 
      IF(NBOND.GT.153)GOTO 110 
      BI(1)=BETA3(NBOND)*VS(NI) 
      BI(2)=BETA3(NBOND)*VP(NI) 
      BI(3)=BI(2) 
      BI(4)=BI(2) 
      BJ(1)=BETA3(NBOND)*VS(NJ) 
      BJ(2)=BETA3(NBOND)*VP(NJ) 
      BJ(3)=BJ(2) 
      BJ(4)=BJ(2) 
      GOTO 110 
  100 CONTINUE 
      BI(1)=BETAS(NI)*0.5D0 
      BI(2)=BETAP(NI)*0.5D0 
      BI(3)=BI(2) 
      BI(4)=BI(2) 
      BI(5)=BETAD(NI)*0.5D0 
      BI(6)=BI(5) 
      BI(7)=BI(5) 
      BI(8)=BI(5) 
      BI(9)=BI(5) 
      BJ(1)=BETAS(NJ)*0.5D0 
      BJ(2)=BETAP(NJ)*0.5D0 
      BJ(3)=BJ(2) 
      BJ(4)=BJ(2) 
      BJ(5)=BETAD(NJ)*0.5D0 
      BJ(6)=BJ(5) 
      BJ(7)=BJ(5) 
      BJ(8)=BJ(5) 
      BJ(9)=BJ(5) 
  110 CONTINUE 
      NORBI=NATORB(NI) 
      NORBJ=NATORB(NJ) 
      IF(NORBI.EQ.9.OR.NORBJ.EQ.9) THEN 
          DO 120 J=1,NORBJ 
          DO 120 I=1,NORBI 
  120     SMAT(I,J)=-2.0D0*SMAT(I,J)*((BI(I)*BJ(J))**0.50D0) 
      ELSE 
          DO 130 J=1,NORBJ 
          DO 130 I=1,NORBI 
  130     SMAT(I,J)=SMAT(I,J)*(BI(I)+BJ(J)) 
      ENDIF 
C 
C    In the calculation of the one-electron terms the geometric mean 
C    of the two beta values is being used if one of the atoms 
C    contains d-orbitals. 
      RETURN 
      END 
      SUBROUTINE HADDON (W,L,M,LOC,A) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION A(3,*) 
C********************************************************************** 
C 
C   HADDON CALCULATES THE VALUE OF A SYMMETRY-DEPENDENT VARIABLE 
C 
C  ON INPUT: M   = NUMBER SPECIFYING THE SYMMETRY OPERATION 
C            LOC = ADDRESS OF REFERENCE ATOM 
C            A   = ARRAY OF INTERNAL COORDINATES 
C  ON OUTPUT W   = VALUE OF DEPENDENT FUNCTION 
C            L   = 1 (FOR BOND LENGTH), 2 (ANGLE), OR 3 (DIHEDRAL) 
C********************************************************************** 
       SAVE
      PI = 3.1415926536D00 
      IF (M.GT.18 .OR. M.LT.1) THEN 
         WRITE(6,'(///10X,''UNDEFINED SYMMETRY FUNCTION USED'')') 
         STOP 
      ENDIF 
      I=LOC 
      GO TO 
     1(140,160,10,20,30,40,50,60,70,80,90,100,110,120,150,170,180,190), 
     2M 
   10 W=A(3,I) 
      GO TO 130 
   20 W=(PI/2.0D00)-A(3,I) 
      GO TO 130 
   30 W=(PI/2.0D00)+A(3,I) 
      GO TO 130 
   40 W=(2.0D00*PI/3.0D00)-A(3,I) 
      GO TO 130 
   50 W=(2.0D00*PI/3.0D00)+A(3,I) 
      GO TO 130 
   60 W=(PI)-A(3,I) 
      GO TO 130 
   70 W=(PI)+A(3,I) 
      GO TO 130 
   80 W=(4.0D00*PI/3.0D00)-A(3,I) 
      GO TO 130 
   90 W=(4.0D00*PI/3.0D00)+A(3,I) 
      GO TO 130 
  100 W=(3.0D00*PI/2.0D00)-A(3,I) 
      GO TO 130 
  110 W=(3.0D00*PI/2.0D00)+A(3,I) 
      GO TO 130 
  120 W=-A(3,I) 
  130 L=3 
      RETURN 
  140 L=1 
      W=A(1,I) 
      RETURN 
  150 L=1 
      W=A(1,I)/2.0D00 
      RETURN 
  160 L=2 
      W=A(2,I) 
      RETURN 
  170 L=2 
      W=A(2,I)/2.0D00 
      RETURN 
  180 L=2 
      W=PI-A(2,I) 
      RETURN 
  190 CALL DEPVAR (A,I,W,L) 
      RETURN 
C 
      END 
      SUBROUTINE HCORE (COORD,H,W, WJ,WK,ENUCLR) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
     3       /MOLORB/ USPD(MAXORB),DUMY(MAXORB) 
     4       /KEYWRD/ KEYWRD 
     5       /WMATRX/ WDUMMY(N2ELEC*3),KR,NBAND(NUMATM) 
      COMMON /EULER / TVEC(3,3), ID 
************************************************************************ 
C 
C   HCORE GENERATES THE ONE-ELECTRON MATRIX AND TWO ELECTRON INTEGRALS 
C         FOR A GIVEN MOLECULE WHOSE GEOMETRY IS DEFINED IN CARTESIAN 
C         COORDINATES. 
C 
C  ON INPUT  COORD   = COORDINATES OF THE MOLECULE. 
C 
C  ON OUTPUT  H      = ONE-ELECTRON MATRIX. 
C             W      = TWO-ELECTRON INTEGRALS. 
C             ENUCLR = NUCLEAR ENERGY 
************************************************************************ 
      DIMENSION COORD(3,*),H(*), WJ(*), WK(*), W(*) 
      DIMENSION E1B(10),E2A(10),DI(9,9), WJD(100), WKD(100) 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST,DEBUG,MINDO 
      DATA FIRST/.TRUE./ 
       SAVE
      IF (FIRST) THEN 
         IONE=1 
         CUTOFF=1.D10 
         IF(ID.NE.0)CUTOFF=60.D0 
         IF(ID.NE.0)IONE=0 
         FIRST=.FALSE. 
         DEBUG=INDEX(KEYWRD,'HCORE') .NE. 0 
         MINDO=INDEX(KEYWRD,'MINDO') .NE. 0 
      ENDIF 
      DO 10 I=1,(NORBS*(NORBS+1))/2 
   10 H(I)=0 
      ENUCLR=0.D0 
      KR=1 
      NROW=0 
      IPQRS=1 
      DO 110 I=1,NUMAT 
         IA=NFIRST(I) 
         IB=NLAST(I) 
         IC=NMIDLE(I) 
         NI=NAT(I) 
C 
C FIRST WE FILL THE DIAGONALS, AND OFF-DIAGONALS ON THE SAME ATOM 
C 
         DO 30 I1=IA,IB 
            I2=I1*(I1-1)/2+IA-1 
            DO 20 J1=IA,I1 
               I2=I2+1 
   20       H(I2)=0.D0 
   30    H(I2)=USPD(I1) 
         IM1=I-IONE 
         IF(IM1.GT.0) THEN 
            NROW=NROW+NBAND(IM1) 
            NCOL=NBAND(I) 
            NBAND2=0 
         ENDIF 
         DO 100 J=1,IM1 
            HALF=1.D0 
            IF(I.EQ.J)HALF=0.5D0 
            JA=NFIRST(J) 
            JB=NLAST(J) 
            JC=NMIDLE(J) 
            NJ=NAT(J) 
            CALL H1ELEC(NI,NJ,COORD(1,I),COORD(1,J),DI) 
C 
C   FILL THE ATOM-OTHER ATOM ONE-ELECTRON MATRIX<PSI(LAMBDA)!PSI(SIGMA)> 
C 
            I2=0 
            DO 40 I1=IA,IB 
               II=I1*(I1-1)/2+JA-1 
               I2=I2+1 
               J2=0 
               JJ=MIN(I1,JB) 
               DO 40 J1=JA,JJ 
                  II=II+1 
                  J2=J2+1 
   40       H(II)=H(II)+DI(I2,J2) 
C 
C   CALCULATE THE TWO-ELECTRON INTEGRALS, W; THE ELECTRON NUCLEAR TERMS 
C   E1B AND E2A; AND THE NUCLEAR-NUCLEAR TERM ENUC. 
C 
            KRO=KR 
            NBAND1=NBAND2+1 
            NBAND2=NBAND2+NBAND(J) 
            IF(ID.EQ.0) THEN 
               CALL ROTATE (NI,NJ,COORD(1,I),COORD(1,J), 
     1                      WJD,     KR,E1B,E2A,ENUC,CUTOFF) 
               IF(KR.LE.KRO) GO TO 50 
               IF(MINDO) THEN 
                  CALL SCOPY (KR-KRO,WJD,1,W(KRO),1) 
               ELSE 
                  CALL WCANON (WJD,W(IPQRS),NROW,NCOL,NBAND1,NBAND2) 
               ENDIF 
            ELSE 
               CALL SOLROT (NI,NJ,COORD(1,I),COORD(1,J), 
     1                      WJD, WKD,KR,E1B,E2A,ENUC,CUTOFF) 
               IF(KR.LE.KRO) GO TO 50 
               IF(MINDO) THEN 
                  CALL SCOPY (KR-KRO,WJD,1,WJ(KRO),1) 
                  CALL SCOPY (KR-KRO,WKD,1,WK(KRO),1) 
               ELSE 
                  CALL WCANON (WJD,WJ(IPQRS),NROW,NCOL,NBAND1,NBAND2) 
                  CALL WCANON (WKD,WK(IPQRS),NROW,NCOL,NBAND1,NBAND2) 
               ENDIF 
            ENDIF 
   50       ENUCLR = ENUCLR + ENUC 
C 
C   ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM I. 
C 
            I2=0 
            DO 60 I1=IA,IC 
               II=I1*(I1-1)/2+IA-1 
               DO 60 J1=IA,I1 
                  II=II+1 
                  I2=I2+1 
   60       H(II)=H(II)+E1B(I2)*HALF 
            DO  70 I1=IC+1,IB 
               II=(I1*(I1+1))/2 
   70       H(II)=H(II)+E1B(1)*HALF 
C 
C   ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM J. 
C 
            I2=0 
            DO 80 I1=JA,JC 
               II=I1*(I1-1)/2+JA-1 
               DO 80 J1=JA,I1 
                  II=II+1 
                  I2=I2+1 
   80       H(II)=H(II)+E2A(I2)*HALF 
            DO 90 I1=JC+1,JB 
               II=(I1*(I1+1))/2 
   90       H(II)=H(II)+E2A(1)*HALF 
  100    CONTINUE 
         IPQRS=IPQRS+NROW*NCOL 
  110 CONTINUE 
      IF (DEBUG) THEN 
         WRITE(6,'(//10X,''ONE-ELECTRON MATRIX FROM HCORE'')') 
         CALL VECPRT(H,NORBS) 
         J=MIN(400,KR) 
         IF(ID.EQ.0) THEN 
            WRITE(6,'(//10X,''TWO-ELECTRON MATRIX IN HCORE''/)') 
            WRITE(6,120)(W(I),I=1,J) 
         ELSE 
            WRITE(6,'(//10X,''TWO-ELECTRON J MATRIX IN HCORE''/)') 
            WRITE(6,120)(WJ(I),I=1,J) 
            WRITE(6,'(//10X,''TWO-ELECTRON K MATRIX IN HCORE''/)') 
            WRITE(6,120)(WK(I),I=1,J) 
  120       FORMAT(10F8.4) 
         ENDIF 
      ENDIF 
      IF (ID.EQ.0) THEN 
C 
C        UNPACK (-0.5)*K  FOR FURTHER USE IN FOCK2, FOCK ETC 
C        --------------------------------------------------- 
         IPQRS=1 
         KPQRS=0 
         CONST=-0.5D0 
         DO 150 II=2,NUMAT 
         IA=NFIRST(II) 
         IC=NLAST(II) 
         DO 150 I=IA,IC 
         DO 150 J=IA,I 
         DO 150 JJ=1,II-1 
         JJLEN=MAX(0,NLAST(JJ)-NFIRST(JJ)+1) 
         DO 140 K=1,JJLEN 
         LK=(K-1)*JJLEN+1 
         KL=K 
         DO 130 L=1,K-1 
         WK(KPQRS+KL)=WJ(IPQRS)*CONST 
         WK(KPQRS+LK)=WJ(IPQRS)*CONST 
         IPQRS=IPQRS+1 
         LK=LK+1 
  130    KL=KL+JJLEN 
         WK(KPQRS+LK)=-WJ(IPQRS) 
  140    IPQRS=IPQRS+1 
  150    KPQRS=KPQRS+JJLEN*JJLEN 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE WCANON (W,PQRS,NROW,NCOL,NBAND1,NBAND2) 
      IMPLICIT REAL(A-H,O-Z) 
C     * MNDO *  OR  * AM1 *  BUT NOT  * MINDO * 
C     FROM ONE BICENTRIC BLOCK OF 2-ELECTRON INTEGRALS 
C       TO CANONIC STORAGE. 
      DIMENSION W(*),PQRS(NROW,NCOL) 
       SAVE
      K=1 
      DO 10 J=1,NCOL 
      DO 10 I=NBAND1,NBAND2 
      PQRS(I,J)=W(K) 
   10 K=K+1 
      RETURN 
      END 
      SUBROUTINE WNONCA (W,PQRS,NROW,NCOL,NBAND1,NBAND2) 
      IMPLICIT REAL(A-H,O-Z) 
C     * MNDO *  OR  * AM1 *  BUT NOT  * MINDO * 
C     FROM CANONIC STORAGE 
C       TO ONE BICENTRIC BLOCK OF 2-ELECTRON INTEGRALS. 
      DIMENSION W(*),PQRS(NROW,NCOL) 
       SAVE
      K=1 
      DO 20 J=1,NCOL 
      DO 20 I=NBAND1,NBAND2 
      W(K)=PQRS(I,J) 
   20 K=K+1 
      RETURN 
      END 
      FUNCTION HELECT(N,P,H,F) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION P(*), H(*), F(*) 
       SAVE
C*********************************************************************** 
C 
C    SUBROUTINE CALCULATES THE ELECTRONIC ENERGY OF THE SYSTEM IN EV. 
C 
C    ON ENTRY N = NUMBER OF ATOMIC ORBITALS. 
C             P = DENSITY MATRIX, PACKED, LOWER TRIANGLE. 
C             H = ONE-ELECTRON MATRIX, PACKED, LOWER TRIANGLE. 
C             F = TWO-ELECTRON MATRIX, PACKED, LOWER TRIANGLE. 
C    ON EXIT 
C        HELECT = ELECTRONIC ENERGY. 
C 
C    NO ARGUMENTS ARE CHANGED. 
C 
C*********************************************************************** 
C     MODIFIED FOR OPTIMAL VECTORIZATION (D.L. JUNE 85) 
      LINEAR=N*(N+1)/2 
      HELECT=0.D0 
      K=0 
      DO 10 I=1,N 
      K=K+I 
   10 HELECT=HELECT+P(K)*(H(K)+F(K)) 
      HELECT=-0.5D0*HELECT 
      DO 20 I=1,LINEAR 
   20 HELECT=HELECT+P(I)*(H(I)+F(I)) 
      RETURN 
      END 
      SUBROUTINE IJKL (C,N,N1,NA,W,PQKL,MPQKL,WIJKL,NMCI,DIJKL,LGRAD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C--------------------------------------------------------------------- 
C     2-ELECTRONS INTEGRALS IN M.O BASIS : 
C                 WIJKL WITH I,J,K,L OVER C.I-ACTIVE M.O , 
C                 DIJKL WITH I       OVER     ALL    M.O , 
C                              J,K,L OVER C.I-ACTIVE M.O . 
C 
C   INPUT 
C     C(N,N)     : M.O COEFFICIENTS IN A.O BASIS. 
C     N1         : NUMBER OF THE FIRST ACTIVE M.O 
C     NA         : NUMBER OF (CONSECUTIVE) ACTIVE M.O 
C     W          : 2-CENTRE 2-ELECTRONS INTEGRALS  IN A.O. BASIS. 
C     PQKL(MPQKL): SCRATCH ARRAY PROVIDED FOR THE <PQ!KL> FILE 
C                  ISSUING FROM THE FIRST 2-INDICES TRANSFORMATION. 
C     NMCI       : MAX. SIZE OF WIJKL. 
C     LGRAD      : .TRUE. IF DIJKL IS TO BE FILLED, 
C                  .FALSE. OTHERWISE. 
C   OUTPUT 
C     WIJKL(I,J,K,L)= < I(1),J(1) ! K(2),L(2) > 
C                     WITH I,J,K,L      OVER C.I-ACTIVE M.O. 
C 
C     AND IF LGRAD IS .TRUE. : 
C     DIJKL(I,J,KL )= < I(1),J(1) ! K(2),L(2) > 
C                     WITH I            OVER    ALL     M.O 
C                          J            OVER C.I-ACTIVE M.O. 
C                          KL CANONICAL OVER C.I-ACTIVE M.O. 
C     OTHERWISE DIJKL IS NOT MODIFIED BY THIS ROUTINE. 
C   NOTE ... THIS ROUTINE USES 2-INDICES TRANSFORMATION. 
C            (1-INDEX TRANSFORMATION IS USELESS WITHIN MNDO FORMALISM). 
C     D.L. (DEWAR GROUP)  1986 
C----------------------------------------------------------------------- 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM) 
     2       /WMATRX/ WDUMMY(N2ELEC*3),KDUMMY,NBAND(NUMATM) 
     3       /SCRACH/ CIJ(NMECI*(NMECI+1)*NUMATM*5) 
     4       /OPTIM / IMP,IMP0,LEC,IPRT 
      DIMENSION C(N,N),W(*),PQKL(*),DIJKL(N,NA,*) 
     .         ,WIJKL(NMCI,NMCI,NMCI,NMCI) 
      DIMENSION BUF((NMECI*(NMECI+1)/2)*(NMECI*(NMECI+1)/2+1)/2) 
     .         ,INDX(NUMATM) 
      LOGICAL LGRAD 
       SAVE
C 
C     LENGTH = NUMBER OF CANONICAL COUPLES OF 1-CENTER A.O. 
C     INDX(I)= LOCATION OF THE FIRST COUPLE IJ BELONGING TO ATOM I. 
      INDX(1)=1 
      LENGTH =MAX(0,NBAND(1)) 
      DO 10 I=2,NUMAT 
      INDX(I)=INDX(I-1)+MAX(0,NBAND(I-1)) 
   10 LENGTH =LENGTH   +MAX(0,NBAND(I)) 
C 
C     DEFINE SIZES AND CHECK AVAILABLE CORE MEMORY. 
      I=0 
C     AVAILABLE SPACE IN /SCRACH/ ACCORDING TO DERIV,DERI1,DERI2. 
      MSCRAH=MAX(NMECI*(NMECI+1)*NUMATM*5,MPACK*2) 
      IJBAND=MSCRAH/LENGTH 
      KLBAND=NA*(NA+1)/2 
C     CHECK PQKL(MPKL) 
      IF (LENGTH*KLBAND .GT. MPQKL) THEN 
         WRITE(IPRT,'('' AVAILABLE STORAGE ('',I10,'') TOO SMALL ('' 
     .             ,I10,'') IN COMMON /SCRAH2/'')') 
     .              MPQKL,LENGTH*KLBAND 
         I=1 
      ENDIF 
C     CHECK CIJ(LENGTH,KLBAND) 
      IF (KLBAND.GT.IJBAND) THEN 
         WRITE(IPRT,'('' AVAILABLE STORAGE ('',I10,'') TOO SMALL ('' 
     .             ,I10,'' ) IN COMMON /SCRACH/'')') 
     .             MSCRAH,KLBAND*LENGTH 
         I=1 
      ENDIF 
      IF(I.NE.0) THEN 
         WRITE(IPRT,'( 
     .   ''      ----- FATAL MESSAGE FROM ROUTINE IJKL -----''/ 
     .   '' REDUCE THE NUMBER OF C.I-ACTIVE MOLECULAR ORBITALS''/ 
     .   '' OR COMPILE WITH ADEQUATE VALUES OF THE PARAMETERS '', 
     .   '' NRELAX, MPACK'')') 
         STOP 
      ENDIF 
C 
C     FIRST 2-INDICES TRANSFORMATION OVER C.I-ACTIVE M.O. 
C     --------------------------------------------------- 
      IPQKL=1 
      IPQ=1 
      DO 50 K=1,NA 
      MOK=N1-1+K 
      DO 50 L=1,K 
      MOL=N1-1+L 
C     FORM CHARGE DISTRIBUTION VECTOR CIJ # KL. 
      DO 40 IIA=1,NUMAT 
      DO 20 IP=NFIRST(IIA),NLAST(IIA) 
      DO 20 IQ=NFIRST(IIA),IP 
      CIJ(IPQ)=C(IP,MOK)*C(IQ,MOL)+C(IP,MOL)*C(IQ,MOK) 
   20 IPQ=IPQ+1 
   40 CONTINUE 
C     COMPUTE PQKL OVER C.I-ACTIVE M.O. 
      CALL PQTKL (CIJ(IPQKL),INDX,NBAND,W,PQKL(IPQKL)) 
   50 IPQKL=IPQ 
C 
C     SECOND 2-INDICES TRANSFORMATION OVER C.I-ACTIVE M.O. 
C     ---------------------------------------------------- 
C     FORM <IJ!KL> IN CANONICAL ORDER, STORED IN BUF. 
      CALL MTXMC (CIJ,KLBAND,PQKL,LENGTH,BUF) 
C     EXPAND BUF INTO WIJKL. 
      NIJKL=1 
      DO 60 I=1,NA 
      DO 60 J=1,I 
      DO 60 K=1,I 
      IF(K.EQ.I) THEN 
         LL=J 
      ELSE 
         LL=K 
      ENDIF 
      DO 60 L=1,LL 
      VAL=BUF(NIJKL) 
      NIJKL=NIJKL+1 
      WIJKL(I,J,K,L)=VAL 
      WIJKL(I,J,L,K)=VAL 
      WIJKL(J,I,K,L)=VAL 
      WIJKL(J,I,L,K)=VAL 
      WIJKL(K,L,I,J)=VAL 
      WIJKL(K,L,J,I)=VAL 
      WIJKL(L,K,I,J)=VAL 
   60 WIJKL(L,K,J,I)=VAL 
C 
      IF (.NOT.LGRAD) RETURN 
C 
C     DISPATCH WIJKL(I,J,K,L) AS DIAGONAL BLOCKS OF DIJKL(I,J,KL). 
C     ------------------------------------------------------------ 
      DO 70 I=1,NA 
      MOI=N1+I-1 
      DO 70 J=1,NA 
      KL=0 
      DO 70 K=1,NA 
      DO 70 L=1,K 
      KL=KL+1 
   70 DIJKL(MOI,J,KL)=WIJKL(I,J,K,L) 
C 
C     SECOND 2-INDICES TRANSFORMATION OVER NON ACTIVE/ C.I-ACTIVE M.O. 
C     ---------------------------------------------------------------- 
C     INITIALIZE I1, LOWER BOUND OF THE POINTER I ON NON ACTIVE M.O. 
      IF (N1.EQ.1.AND.N1+NA.GT.N) RETURN 
      IF (N1.GT.1) THEN 
         I1=1 
      ELSE 
         I1=N1+NA 
      ENDIF 
C     UPDATE     I2, UPPER BOUND OF THE POINTER I ON NON ACTIVE M.O. 
   80 IF (I1.LT.N1) THEN 
         I2=MIN(I1+IJBAND,N1)-1 
      ELSE 
         I2=MIN(I1+IJBAND-1,N) 
      ENDIF 
      IJBROD=I2-I1+1 
C     WORK OUT DIJKL(I,J,KL) FOR I=I1, ... ,I2     NON ACTIVE 
C                                J= 1, ... ,NA     C.I-ACTIVE 
C                               KL= 1, ... ,KLBAND C.I-ACTIVE 
      DO 120 J=1,NA 
      MOJ=N1+J-1 
      DO 110 I=I1,I2 
      IPQ=I-I1+1 
C     FORM SECOND CHARGE DISTRIBUTION INTO CIJ(IJBROD,LENGTH) 
C     OVER I NON ACTIVE AND J C.I-ACTIVE. 
      DO 110 IIA=1,NUMAT 
C     SPARKLES ARE SKIPPED OUT (THANKS TO FORTRAN 77) 
      DO 90 IP=NFIRST(IIA),NLAST(IIA) 
      DO 90 IQ=NFIRST(IIA),IP 
      CIJ(IPQ)=C(IP,  I)*C(IQ,MOJ)+C(IP,MOJ)*C(IQ,  I) 
   90 IPQ=IPQ+IJBROD 
  110 CONTINUE 
      IPQKL=1 
      DO 120 KL=1,KLBAND 
      CALL MXM (CIJ,IJBROD,PQKL(IPQKL),LENGTH,DIJKL(I1,J,KL),1) 
  120 IPQKL=IPQKL+LENGTH 
C     UPDATE     I1, LOWER BOUND OF THE POINTER I ON NON ACTIVE M.O. 
      IF (I2.EQ.N1-1) THEN 
         I1=N1+NA 
      ELSE 
         I1=I2+1 
      ENDIF 
      IF (I1.LE.N) GO TO 80 
      RETURN 
      END 
      SUBROUTINE PQTKL (C34,INDX,NBAND,W,PQ34) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION C34(*),INDX(*),NBAND(*),W(*),PQ34(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
     3       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     4               ,GSD(107),GPD(107),GDD(107) 
     5       /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
C------------------------------------------------------------------ 
C 
C    PQTKL WORKS OUT  IN MNDO FORMALISM THE FIRST 2-INDICES TRANSFO. 
C          REQUIRED IN THE COMPUTATION OF 2-ELECTRONS REPULSION OVER M.O 
C  INPUT 
C     C34   : VECTOR OF THE CURRENT CHARGE DISTRIBUTION BETWEEN TWO M.O. 
C     INDX(I) : LOCATION IN C34 OF THE FIRST COUPLE OF A.O BELONGING TO 
C               ATOM # I. 
C     NBAND(I): NUMBER OF COUPLES OF A.O BELONGING TO ATOM # I. 
C     W     : 2-CENTRES 2-ELECTRONS INTEGRALS IN A.O. BASIS, STORED IN 
C             PACKED CANONICAL ORDER, SKIPPING OVER 1-CENTRE BLOCKS. 
C             (IN MINDO/3 OPTION THE SAME CANONICAL ORDER RUNS OVER 
C              THE ATOMS ONLY). 
C  OUTPUT 
C     PQ34(PQ) : <P(1),Q(1)!C3(2),C4(2)> WHERE P ,Q  ARE A.O. 
C                                          AND C3,C4 ARE M.O. 
C                P AND Q RUN IN CANONICAL ORDER OVER THE A.O BELONGING 
C                TO AN ATOM 'A' ONLY (BASIC ASSUMPTION OF MNDO SCHEME) 
C                AND 'A' RUNS OVER THE ATOMS OF THE SYSTEM. 
C     D.L. (DEWAR GROUP) 1986 
C---------------------------------------------------------------------- 
      DIMENSION LD(9),BUF(45),PTOT(NUMATM) 
      LOGICAL MINDO 
      DATA LD /0,2,5,9,14,20,27,35,44/ 
       SAVE
      MINDO=INDEX(KEYWRD,'MINDO') .NE. 0 
C     IJ    : POINTER OF CANONICAL PACKED LOCATION OF COUPLE IJ. 
C     KK    : POINTER OF SUPPORTING ATOM, SPARKLES SKIPPED OUT. 
C     IPQRS : CURRENT ENTRY POINT IN THE <PQ!RS> FILE. 
      KK=0 
      IPQRS=1 
      IJ=0 
      IJOLD=0 
C 
C     LOOP OVER OUTER ATOM A, SPARKLES EXCLUDED. 
C     ------------------------------------------ 
      DO 70 II=1,NUMAT 
      IA=NFIRST(II) 
      IB=NMIDLE(II) 
      IC=NLAST (II) 
      IF(IC.LT.IA) GO TO 70 
      KK=KK+1 
      LS=INDX(II) 
      IJ=IJ+NBAND(II) 
C 
C     PQ34(IJ) = <IJ!KL> * C34(KL)  , 1-CENTRE CONTRIBUTIONS. 
      IZN=NAT(II) 
C     BLOCK SS 
      PTOT(KK)=C34(LS) 
      PQ34(LS)=C34(LS)*GSS(IZN)*0.25D0 
      IF(IB.GT.IA) THEN 
C        BLOCK SP AND PP 
         HPP=0.5D0*(GPP(IZN)-GP2(IZN)) 
         LX=LS+LD(2) 
         LY=LS+LD(3) 
         LZ=LS+LD(4) 
         PP=C34(LX)+C34(LY)+C34(LZ) 
         PQ34(LS+1)=HSP(IZN)*C34(LS+1) 
         PQ34(LX  )=GPP(IZN)*C34(LX  )*0.25D0 
         PQ34(LS+3)=HSP(IZN)*C34(LS+3) 
         PQ34(LS+4)=HPP     *C34(LS+4) 
         PQ34(LY  )=GPP(IZN)*C34(LY  )*0.25D0 
         PQ34(LS+6)=HSP(IZN)*C34(LS+6) 
         PQ34(LS+7)=HPP     *C34(LS+7) 
         PQ34(LS+8)=HPP     *C34(LS+8) 
         PQ34(LZ  )=GPP(IZN)*C34(LZ  )*0.25D0 
         GSPSS=     GSP(IZN)*C34(LS  )*0.25D0 
         PQ34(LS)=PQ34(LS)+GSP(IZN)*PP*0.25D0 
         PQ34(LX)=PQ34(LX)+GP2(IZN)*(C34(LY)+C34(LZ))*0.25D0+GSPSS 
         PQ34(LY)=PQ34(LY)+GP2(IZN)*(C34(LZ)+C34(LX))*0.25D0+GSPSS 
         PQ34(LZ)=PQ34(LZ)+GP2(IZN)*(C34(LX)+C34(LY))*0.25D0+GSPSS 
         PTOT(KK)=PTOT(KK)+PP 
         IF(IC.GT.IB) THEN 
C           BLOCK SD, PD AND DD 
C           --- WAITING FOR 'D' PARAMETERS --- 
C               TAKE CARE : DIAGONAL ELEMENTS OF C34 ARE DOUBLED. 
         ENDIF 
      ENDIF 
      IF(KK.GT.1)THEN 
C 
C        LOOP OVER CHARGE DISTRIBUTION OF INNER ATOMS  B < A . 
C        ----------------------------------------------------- 
C        PQ34(IJ)=<IJ!KL>*C34(KL) 2-CENTRES CONTRIBUTIONS. 
C 
         IF (MINDO) THEN 
C           WE ARE IN MINDO/3 OPTION. 
            GMINDO=DOT(W(IPQRS),PTOT,KK-1) 
            DO 30 L=1,IC-IA+1 
   30       PQ34(LS+LD(L))=PQ34(LS+LD(L))+GMINDO 
            DO 50 JJ=1,II-1 
            JA=NFIRST(JJ) 
            JC=NLAST (JJ) 
            IF(JC.LT.JA) GO TO 50 
            GMINDO=W(IPQRS)*PTOT(KK) 
            DO 40 L=1,JC-JA+1 
   40       PQ34(INDX(JJ)+LD(L))=PQ34(INDX(JJ)+LD(L))+GMINDO 
            IPQRS=IPQRS+1 
   50       CONTINUE 
         ELSE 
C           WE ARE IN MNDO OR AM1 OPTION. 
            CALL MXM (C34,1,W(IPQRS),IJOLD,BUF,NBAND(II)) 
            CALL SAXPY (NBAND(II),1.D0,BUF,1,PQ34(LS),1) 
            DO 60 I=LS,IJ 
            CALL SAXPY (IJOLD,C34(I),W(IPQRS),1,PQ34,1) 
   60       IPQRS=IPQRS+IJOLD 
         ENDIF 
      ENDIF 
      IJOLD=IJ 
   70 CONTINUE 
      RETURN 
      END 
      SUBROUTINE DIJKL1 (C,N,N1,NA,W,PQKL,MPQKL,WIJKL,NMCI,NATI,CIJRDY) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C------------------------------------------------------------------- 
C     2-ELECTRONS INTEGRALS DERIVATIVES IN M.O BASIS : 
C                 WIJKL WITH I,J,K,L OVER C.I-ACTIVE M.O , 
C 
C   INPUT 
C     C(N,N)     : M.O COEFFICIENTS IN A.O BASIS. 
C     N1         : NUMBER OF THE FIRST ACTIVE M.O 
C     NA         : NUMBER OF (CONSECUTIVE) ACTIVE M.O 
C     W          : 2-CENTRE 2-ELECTRONS INTEGRALS DERIVATIVES IN A.O. 
C     PQKL(MPQKL): SCRATCH ARRAY PROVIDED FOR THE <PQ!KL> FILE 
C                  ISSUING FROM THE FIRST 2-INDICES TRANSFORMATION. 
C     NMCI       : MAX. SIZE OF WIJKL. 
C     NATI       : # OF THE MOVING ATOM. 
C     CIJRDY     : .TRUE. IF THE CIJ MATRIX IS AVAILABLE IN /SCRACH/ 
C                  .FALSE. OTHERWISE (NEW BAND OR NEW ATOM, SEE DERIV) 
C   OUTPUT 
C     WIJKL(I,J,K,L)= < I(1),J(1) !d(1/R12)! K(2),L(2) > 
C                     WITH I,J,K,L      OVER C.I-ACTIVE M.O. 
C 
C   NOTE ... THIS ROUTINE USES 2-INDICES TRANSFORMATION. 
C            (1-INDEX TRANSFORMATION IS USELESS WITHIN MNDO FORMALISM). 
C     D.L. (DEWAR GROUP) 1986 
C----------------------------------------------------------------------- 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM) 
     2       /WMATRX/ WDUMMY(N2ELEC*3),KDUMMY,NBAND(NUMATM) 
     3       /SCRACH/ CIJ(NMECI*(NMECI+1)*NUMATM*5) 
     4       /OPTIM / IMP,IMP0,LEC,IPRT 
      DIMENSION C(N,N),W(*),PQKL(*) 
     .         ,WIJKL(NMCI,NMCI,NMCI,NMCI) 
      DIMENSION BUF((NMECI*(NMECI+1)/2)*(NMECI*(NMECI+1)/2+1)/2) 
     .         ,INDX(NUMATM) 
      LOGICAL CIJRDY 
      DATA NATOLD /0/ 
       SAVE
C 
C     LENGTH = NUMBER OF CANONICAL COUPLES OF 1-CENTER A.O. 
C     INDX(I)= LOCATION OF THE FIRST COUPLE IJ BELONGING TO ATOM I. 
      INDX(1)=1 
      LENGTH =MAX(0,NBAND(1)) 
      DO 10 I=2,NUMAT 
      INDX(I)=INDX(I-1)+MAX(0,NBAND(I-1)) 
   10 LENGTH =LENGTH   +MAX(0,NBAND(I)) 
C 
C     DEFINE SIZES AND CHECK AVAILABLE CORE MEMORY. 
      I=0 
C     AVAILABLE SPACE IN /SCRACH/ ACCORDING TO DERIV,DERI1,DERI2. 
      MSCRAH=MAX(NMECI*(NMECI+1)*NUMATM*5,MPACK*2) 
      IJBAND=MSCRAH/LENGTH 
      KLBAND=NA*(NA+1)/2 
C     CHECK PQKL(MPKL) 
      IF (LENGTH*KLBAND .GT. MPQKL) THEN 
         WRITE(IPRT,'('' AVAILABLE STORAGE ('',I10,'') TOO SMALL ('' 
     .             ,I10,'') IN COMMON /SCRAH2/'')') 
     .              MPQKL,LENGTH*KLBAND 
         I=1 
      ENDIF 
C     CHECK CIJ(LENGTH,KLBAND) 
      IF (KLBAND.GT.IJBAND) THEN 
         WRITE(IPRT,'('' AVAILABLE STORAGE ('',I10,'') TOO SMALL ('' 
     .             ,I10,'' ) IN COMMON /SCRACH/'')') 
     .             MSCRAH,KLBAND*LENGTH 
         I=1 
      ENDIF 
      IF(I.NE.0) THEN 
         WRITE(IPRT,'( 
     .   ''      ----- FATAL MESSAGE FROM ROUTINE DIJKL1 -----''/ 
     .   '' REDUCE THE NUMBER OF C.I-ACTIVE MOLECULAR ORBITALS''/ 
     .   '' OR COMPILE WITH ADEQUATE VALUES OF THE PARAMETERS '', 
     .   '' NRELAX, MPACK'')') 
         STOP 
      ENDIF 
C 
C     FIRST 2-INDICES TRANSFORMATION OVER C.I-ACTIVE M.O. 
C     --------------------------------------------------- 
      IPQKL=1 
      IPQ=1 
      DO 50 K=1,NA 
      MOK=N1-1+K 
      DO 50 L=1,K 
      IF (.NOT.CIJRDY) THEN 
C        FORM CHARGE DISTRIBUTION MATRIX CIJ, NATI IN LAST POSITION. 
         MOL=N1-1+L 
         DO 30 IIA=1,NUMAT 
         IF (IIA.EQ.NATI) GO TO 30 
         DO 20 IP=NFIRST(IIA),NLAST(IIA) 
         DO 20 IQ=NFIRST(IIA),IP 
         CIJ(IPQ)=C(IP,MOK)*C(IQ,MOL)+C(IP,MOL)*C(IQ,MOK) 
   20    IPQ=IPQ+1 
   30    CONTINUE 
         DO 40 IP=NFIRST(NATI),NLAST(NATI) 
         DO 40 IQ=NFIRST(NATI),IP 
         CIJ(IPQ)=C(IP,MOK)*C(IQ,MOL)+C(IP,MOL)*C(IQ,MOK) 
   40    IPQ=IPQ+1 
      ENDIF 
C     COMPUTE PQKL FOR THE DISTRIBUTION KL. 
      CALL DPQTKL (CIJ(IPQKL),NBAND,W,PQKL(IPQKL),NATI,LENGTH) 
   50 IPQKL=IPQKL+LENGTH 
C 
C     SECOND 2-INDICES TRANSFORMATION OVER C.I-ACTIVE M.O. 
C     ---------------------------------------------------- 
C     FORM <IJ!KL> IN CANONICAL ORDER, STORED IN BUF. 
      CALL MTXMC (CIJ,KLBAND,PQKL,LENGTH,BUF) 
C     EXPAND BUF INTO WIJKL. 
      NIJKL=1 
      DO 60 I=1,NA 
      DO 60 J=1,I 
      DO 60 K=1,I 
      IF(K.EQ.I) THEN 
         LL=J 
      ELSE 
         LL=K 
      ENDIF 
      DO 60 L=1,LL 
      VAL=BUF(NIJKL) 
      NIJKL=NIJKL+1 
      WIJKL(I,J,K,L)=VAL 
      WIJKL(I,J,L,K)=VAL 
      WIJKL(J,I,K,L)=VAL 
      WIJKL(J,I,L,K)=VAL 
      WIJKL(K,L,I,J)=VAL 
      WIJKL(K,L,J,I)=VAL 
      WIJKL(L,K,I,J)=VAL 
   60 WIJKL(L,K,J,I)=VAL 
      RETURN 
      END 
      SUBROUTINE DPQTKL (C34,NBAND,W,PQ34,NATI,LENGTH) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION C34(*),NBAND(*),W(*),PQ34(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
     3       /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
C------------------------------------------------------------------ 
C    PQTKL WORKS OUT  IN MNDO OR MINDO FORMALISMS THE FIRST 2-INDICES 
C          TRANSFORMATION RUNNING OVER THE NON VANISHING 2-ELECTRONS 
C          INTEGRALS DERIVATIVES WITH RESPECT TO A CARTESIAN COORDINATE 
C          OF THE ATOM # NATI. 
C  INPUT 
C     C34     : CHARGE-DISTRIBUTION VECTOR BETWEEN TWO M.O. '3' & '4'. 
C     NBAND(I): NUMBER OF COUPLES OF A.O BELONGING TO ATOM # I. 
C     W     : 2-CENTRES 2-ELECTRONS INTEGRALS DERIVATIVES IN A.O. BASIS, 
C             STORED ACCORDING TO ROUTINE DHCORE. 
C     NATI  : # OF THE MOVING ATOM. 
C     LENGTH: LENGTH OF THE CHARGE-DISTRIBUTION VECTOR C34. 
C  OUTPUT 
C     PQ34(PQ) : <P(1),Q(1)!d(1/R12)!C3(2),C4(2)> WHERE P ,Q  ARE A.O. 
C                                                   AND C3,C4 ARE M.O. 
C                P AND Q RUN IN CANONICAL ORDER OVER THE A.O BELONGING 
C                TO AN ATOM 'A' ONLY (BASIC ASSUMPTION OF MNDO SCHEME) 
C                AND 'A' .NE. 'NATI' RUNS OVER THE ATOMS OF THE SYSTEM. 
C     D.L. (DEWAR GROUP) 1986 
C---------------------------------------------------------------------- 
      DIMENSION LD(9),PTOT(NUMATM) 
      LOGICAL MINDO 
      DATA LD /0,2,5,9,14,20,27,35,44/ 
       SAVE
C 
      MINDO=INDEX(KEYWRD,'MINDO') .NE. 0 
      LS=LENGTH-NBAND(NATI)+1 
      DO 10 I=1,LENGTH 
   10 PQ34(I)=0.D0 
      IF (MINDO) THEN 
C        WE ARE IN MINDO OPTION. 
C        ----------------------- 
C        PTOTNA = CHARGE ON ATOM NATI. 
         IA=NFIRST(NATI) 
         IC=NLAST(NATI) 
         PTOTNA=0.D0 
         DO 20 L=1,IC-IA+1 
   20    PTOTNA=PTOTNA+C34(LS+LD(L)) 
C        PTOT(KK) = CHARGE ON ATOM KK, SPARKLES AND NATI EXCLUDED. 
         KK=0 
         LL=1 
         DO 40 JJ=1,NUMAT 
         JA=NFIRST(JJ) 
         JC=NLAST (JJ) 
         IF (JC.LT.JA.OR.JJ.EQ.NATI) GO TO 40 
         KK=KK+1 
         PTOT(KK)=0.D0 
C        DISTRIBUTE CHARGE OF NATI. 
         GMINDO=W(KK)*PTOTNA 
         DO 30 L=1,JC-JA+1 
         PQ34(LL+LD(L))=PQ34(LL+LD(L))+GMINDO 
   30    PTOT(KK)=PTOT(KK)+C34(LL+LD(L)) 
         LL=LL+NBAND(JJ) 
   40    CONTINUE 
C        DISTRIBUTE CHARGES OF ATOMS B .NE. NATI. 
         GMINDO=DOT(W,PTOT,KK) 
         DO 50 L=1,IC-IA+1 
   50    PQ34(LS+LD(L))=PQ34(LS+LD(L))+GMINDO 
      ELSE 
C        WE ARE IN MNDO OR AM1 OPTION. 
C        ----------------------------- 
         IPQRS=1 
C        LOOP OVER CHARGE DISTRIBUTION OF ATOMS  B .NE. NATI . 
         IJOLD=LS-1 
         CALL MXM (C34,1,W,IJOLD,PQ34(LS),NBAND(NATI)) 
C        DISTRIBUTE THE CHARGE DISTRIBUTION OF NATI. 
         DO 60 I=LS,LENGTH 
         CALL SAXPY (IJOLD,C34(I),W(IPQRS),1,PQ34,1) 
   60    IPQRS=IPQRS+IJOLD 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DIJKL2 (DC,N,NA,DIJKL,WIJKL,NMECI) 
      IMPLICIT REAL (A-H,O-Z) 
C-------------------------------------------------------------------- 
C     RELAXATION OF 2-ELECTRONS INTEGRALS IN M.O BASIS. 
C 
C   INPUT 
C     DC(N,NA) : C.I-ACTIVE M.O DERIVATIVES IN M.O BASIS, IN COLUMN. 
C     N        : TOTAL NUMBER OF M.O. 
C     NA       : NUMBER OF C.I-ACTIVE M.O. 
C     DIJKL(I,J,KL) : <I(1),J(1)!K(2),L(2)> WITH 
C                     I              OVER     ALL    M.O. 
C                     J,KL CANONICAL OVER C.I-ACTIVE M.O. 
C     NMECI    : MAX. SIZE OF WIJKL. (NA <= NMECI). 
C   OUTPUT 
C     WIJKL(I,J,K,L)= d< I(1),J(1) ! K(2),L(2) > 
C                   = <dI,J!K,L> + <I,dJ!K,L> + <I,J!dK,L> + <I,J!K,dL> 
C                     WITH I,J,K,L OVER ALL C.I-ACTIVE M.O. 
C     D.L. (DEWAR GROUP) 1986 
C--------------------------------------------------------------------- 
      DIMENSION DC(N,*),WIJKL(NMECI,NMECI,NMECI,NMECI) 
      DIMENSION DIJKL(N,NA,*) 
      LOGICAL LIJ,LKL 
       SAVE
C 
      IJ=0 
      DO 10 I=1,NA 
      DO 10 J=1,I 
      IJ=IJ+1 
      LIJ=I.EQ.J 
      KL=0 
      DO 10 K=1,I 
      IF(K.EQ.I) THEN 
         LL=J 
      ELSE 
         LL=K 
      ENDIF 
      DO 10 L=1,LL 
      KL=KL+1 
      LKL=K.EQ.L 
      VAL=               SDOT(N,DC(1,I),1,DIJKL(1,J,KL),1) 
      IF(LIJ.AND.LKL.AND.J.EQ.K) THEN 
         VAL=VAL*4.D0 
      ELSE 
         IF(LIJ) THEN 
            VAL=VAL*2.D0 
         ELSE 
            VAL=VAL+     SDOT(N,DC(1,J),1,DIJKL(1,I,KL),1) 
         ENDIF 
         VAL2=           SDOT(N,DC(1,K),1,DIJKL(1,L,IJ),1) 
         IF(LKL) THEN 
            VAL=VAL+VAL2*2.D0 
         ELSE 
            VAL=VAL+VAL2+SDOT(N,DC(1,L),1,DIJKL(1,K,IJ),1) 
         ENDIF 
      ENDIF 
      WIJKL(I,J,K,L)=VAL 
      WIJKL(I,J,L,K)=VAL 
      WIJKL(J,I,K,L)=VAL 
      WIJKL(J,I,L,K)=VAL 
      WIJKL(K,L,I,J)=VAL 
      WIJKL(K,L,J,I)=VAL 
      WIJKL(L,K,I,J)=VAL 
   10 WIJKL(L,K,J,I)=VAL 
      RETURN 
      END 
      SUBROUTINE INTERP(N,NP,NQ,MODE,E,FP,CP,VEC,FOCK,P,H,VECL) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION FP(MPACK), CP(N,N) 
      DIMENSION VEC(N,N), FOCK(N,N), 
     1          P(N,N), H(N*N), VECL(N*N) 
********************************************************************** 
* 
* INTERP: AN INTERPOLATION PROCEDURE FOR FORCING SCF CONVERGENCE 
*         ORIGINAL THEORY AND FORTRAN WRITTEN BY R.N. CAMP AND 
*         H.F. KING, J. CHEM. PHYS. 75, 268 (1981) 
********************************************************************** 
* 
* ON INPUT N     = NUMBER OF ORBITALS 
*          NP    = NUMBER OF FILLED LEVELS 
*          NQ    = NUMBER OF EMPTY LEVELS 
*          MODE  = 1, DO NOT RESET. 
*          E     = ENERGY 
*          FP    = FOCK MATRIX, AS LOWER HALF TRIANGLE, PACKED 
*          CP    = EIGENVECTORS OF FOCK MATRIX OF ITERATION -1 
*                  AS PACKED ARRAY OF N*N COEFFICIENTS 
* 
* ON OUTPUT CP   = BEST GUESSED SET OF EIGENVECTORS 
*           MODE = 2 OR 3 - USED BY CALLING PROGRAM 
********************************************************************** 
      DIMENSION THETA(MAXORB), IA(MAXORB) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON/FIT/NPNTS,IDUM2,XLOW,XHIGH,XMIN,EMIN,DEMIN,X(12),F(12), 
     1 DF(12) 
      LOGICAL FIRST, DEBUG, DEBUG1 
      CHARACTER*80 KEYWRD 
      DATA ZERO,FF,RADMAX/0.0,0.9,1.5708/,FIRST/.TRUE./ 
       SAVE
      IF(FIRST)THEN 
         DEBUG=(INDEX(KEYWRD,'INTERP').NE.0) 
         DEBUG1=(INDEX(KEYWRD,'DEBUG').NE.0.AND.DEBUG) 
         FIRST=.FALSE. 
         DO 10 I=1,MAXORB 
   10    IA(I)=(I*I-I)/2 
      ENDIF 
C#      WRITE(6,'(''  FOCK MATRIX AT ENTRANCE TO INTERP'')') 
C#      CALL VECPRT(FP,N) 
C 
C     RADMAX=MAXIMUM ROTATION ANGLE (RADIANS).  1.5708 = 90 DEGREES. 
C         FF=FACTOR FOR CONVERGENCE TEST FOR 1D SEARCH. 
C 
      MINPQ=MIN0(NP,NQ) 
      MAXPQ=MAX0(NP,NQ) 
      NP1=NP+1 
      NP2=MAX0(1,NP/2) 
      IF(MODE.EQ.2) GO TO 110 
C 
C     (MODE=1 OR 3 ENTRY) 
C     TRANSFORM FOCK MATRIX TO CURRENT MO BASIS. 
C     ONLY THE OFF DIAGONAL OCC-VIRT BLOCK IS COMPUTED. 
C     STORE IN FOCK ARRAY 
C 
      II=0 
      DO 50 I=1,N 
         I1=I+1 
         DO 40 J=1,NQ 
            DUM=ZERO 
            DO 20 K=1,I 
   20       DUM=DUM+FP(II+K)*CP(K,J+NP) 
            IF(I.EQ.N) GO TO 40 
            IK=II+I+I 
            DO 30 K=I1,N 
               DUM=DUM+FP(IK)*CP(K,J+NP) 
   30       IK=IK+K 
   40    P(I,J)=DUM 
   50 II=II+I 
      DO 80 I=1,NP 
         DO 70 J=1,NQ 
            DUM=ZERO 
            DO 60 K=1,N 
   60       DUM=DUM+CP(K,I)*P(K,J) 
            FOCK(I,J)=DUM 
   70    CONTINUE 
   80 CONTINUE 
      IF(MODE.EQ.3) GO TO 100 
C 
C     CURRENT POINT BECOMES OLD POINT (MODE=1 ENTRY) 
C 
      DO 90 I=1,N 
         DO 90 J=1,N 
   90 VEC(I,J)=CP(I,J) 
      EOLD=E 
      XOLD=1.0 
C#      WRITE(6,'(''  MODE=2 - CARRY ON - NO CHANGE MADE'')') 
      MODE=2 
      RETURN 
C 
C     (MODE=3 ENTRY) 
C     FOCK CORRESPONDS TO CURRENT POINT IN CORRESPONDING REPRESENTATION. 
C     VEC DOES NOT HOLD CURRENT VECTORS. VEC SET IN LAST MODE=2 ENTRY. 
C 
  100 NPNTS=NPNTS+1 
      IF(DEBUG)WRITE(6,'(''   INTERPOLATED ENERGY:'',F13.6)')E*23.061D0 
      IPOINT=NPNTS 
      GO TO 500 
C 
C    (MODE=2 ENTRY) CALCULATE THETA, AND U, V, W MATRICES. 
C                   U ROTATES CURRENT INTO OLD MO. 
C                   V ROTATES CURRENT INTO CORRESPONDING CURRENT MO. 
C                   W ROTATES OLD INTO CORRESPONDING OLD MO. 
C 
  110 J1=1 
      DO 140 I=1,N 
         IF(I.EQ.NP1) J1=NP1 
         DO 130 J=J1,N 
            P(I,J)=ZERO 
            DO 120 K=1,N 
  120       P(I,J)=P(I,J)+CP(K,I)*VEC(K,J) 
  130    CONTINUE 
  140 CONTINUE 
C 
C     U = CP(DAGGER)*VEC IS NOW IN P ARRAY. 
C     VEC IS NOW AVAILABLE FOR TEMPORARY STORAGE. 
C 
      IJ=0 
      DO 170 I=1,NP 
         DO 160 J=1,I 
            IJ=IJ+1 
            H(IJ)=(I*1.D-17+J*1.D-18) 
            DO 150 K=NP1,N 
  150       H(IJ)=H(IJ)+P(I,K)*P(J,K) 
  160    CONTINUE 
  170 CONTINUE 
C#      CALL VECPRT(H,NP) 
      CALL HQRII(H,NP,NP,THETA,VECL) 
C#      WRITE(6,*)'  AFTER HQRII' 
C#      CALL MATOUT(VECL,THETA,NP,NP,NP) 
      DO 180 I=NP,1,-1 
         IL=I*NP-NP 
         DO 180 J=NP,1,-1 
  180 VEC(J,I)=VECL(J+IL) 
      DO 200 I=1,NP2 
         DUM=THETA(NP1-I) 
         THETA(NP1-I)=THETA(I) 
         THETA(I)=DUM 
         DO 190 J=1,NP 
            DUM=VEC(J,NP1-I) 
            VEC(J,NP1-I)=VEC(J,I) 
  190    VEC(J,I)=DUM 
  200 CONTINUE 
      DO 210 I=1,MINPQ 
         THETA(I)=DMAX1(THETA(I),ZERO) 
         THETA(I)=DMIN1(THETA(I),1.D0) 
  210 THETA(I)=ASIN(SQRT(THETA(I))) 
C 
C     THETA MATRIX HAS NOW BEEN CALCULATED, ALSO UNITARY VP MATRIX 
C     HAS BEEN CALCULATED AND STORED IN FIRST NP COLUMNS OF VEC MATRIX. 
C     NOW COMPUTE WQ 
C 
      DO 240 I=1,NQ 
         DO 230 J=1,MINPQ 
            VEC(I,NP+J)=ZERO 
            DO 220 K=1,NP 
  220       VEC(I,NP+J)=VEC(I,NP+J)+P(K,NP+I)*VEC(K,J) 
  230    CONTINUE 
  240 CONTINUE 
      CALL SCHMIT(VEC(1,NP1),NQ,N) 
C 
C     UNITARY WQ MATRIX NOW IN LAST NQ COLUMNS OF VEC MATRIX. 
C     TRANSPOSE NP BY NP BLOCK OF U STORED IN P 
C 
      DO 260 I=1,NP 
         DO 250 J=1,I 
            DUM=P(I,J) 
            P(I,J)=P(J,I) 
  250    P(J,I)=DUM 
  260 CONTINUE 
C 
C     CALCULATE WP MATRIX AND HOLD IN FIRST NP COLUMNS OF P 
C 
      DO 300 I=1,NP 
         DO 270 K=1,NP 
  270    H(K)=P(I,K) 
         DO 290 J=1,NP 
            P(I,J)=ZERO 
            DO 280 K=1,NP 
  280       P(I,J)=P(I,J)+H(K)*VEC(K,J) 
  290    CONTINUE 
  300 CONTINUE 
      CALL SCHMIB(P,NP,N) 
C 
C     CALCULATE VQ MATRIX AND HOLD IN LAST NQ COLUMNS OF P MATRIX. 
C 
      DO 340 I=1,NQ 
         DO 310 K=1,NQ 
  310    H(K)=P(NP+I,NP+K) 
         DO 330 J=NP1,N 
            P(I,J)=ZERO 
            DO 320 K=1,NQ 
  320       P(I,J)=P(I,J)+H(K)*VEC(K,J) 
  330    CONTINUE 
  340 CONTINUE 
      CALL SCHMIB(P(1,NP1),NQ,N) 
C 
C     CALCULATE (DE/DX) AT OLD POINT 
C 
      DEDX=ZERO 
      DO 370 I=1,NP 
         DO 360 J=1,NQ 
            DUM=ZERO 
            DO 350 K=1,MINPQ 
  350       DUM=DUM+THETA(K)*P(I,K)*VEC(J,NP+K) 
  360    DEDX=DEDX+DUM*FOCK(I,J) 
  370 CONTINUE 
C 
C     STORE OLD POINT INFORMATION FOR SPLINE FIT 
C 
      DEOLD=-4.0*DEDX 
      X(2)=XOLD 
      F(2)=EOLD 
      DF(2)=DEOLD 
C 
C     MOVE VP OUT OF VEC ARRAY INTO FIRST NP COLUMNS OF P MATRIX. 
C 
      DO 380 I=1,NP 
         DO 380 J=1,NP 
  380 P(I,J)=VEC(I,J) 
      K1=0 
      K2=NP 
      DO 410 J=1,N 
         IF(J.EQ.NP1) K1=NP 
         IF(J.EQ.NP1) K2=NQ 
         DO 400 I=1,N 
            DUM=ZERO 
            DO 390 K=1,K2 
  390       DUM=DUM+CP(I,K1+K)*P(K,J) 
  400    VEC(I,J)=DUM 
  410 CONTINUE 
C#      IF(DEBUG1)WRITE(6,'(''  EIGENVECTORS IN VEC'')') 
C#      CALL MATOUT(VEC,0.D0,N,N,N) 
C#      IF(DEBUG1)CALL MATOUT(VEC,0.D0,6,6,N) 
C 
C     CORRESPONDING CURRENT MO VECTORS NOW HELD IN VEC. 
C     COMPUTE VEC(DAGGER)*FP*VEC 
C     STORE OFF-DIAGONAL BLOCK IN FOCK ARRAY. 
C 
  420 II=0 
      DO 460 I=1,N 
         I1=I+1 
         DO 450 J=1,NQ 
            DUM=ZERO 
            DO 430 K=1,I 
  430       DUM=DUM+FP(II+K)*VEC(K,J+NP) 
            IF(I.EQ.N) GO TO 450 
            IK=II+I+I 
            DO 440 K=I1,N 
               DUM=DUM+FP(IK)*VEC(K,J+NP) 
  440       IK=IK+K 
  450    P(I,J)=DUM 
  460 II=II+I 
      DO 490 I=1,NP 
         DO 480 J=1,NQ 
            DUM=ZERO 
            DO 470 K=1,N 
  470       DUM=DUM+VEC(K,I)*P(K,J) 
            FOCK(I,J)=DUM 
  480    CONTINUE 
  490 CONTINUE 
C 
C     SET LIMITS ON RANGE OF 1-D SEARCH 
C 
      NPNTS=2 
      IPOINT=1 
      XNOW=ZERO 
      XHIGH=RADMAX/THETA(1) 
      XLOW=-0.5*XHIGH 
C 
C     CALCULATE (DE/DX) AT CURRENT POINT AND 
C     STORE INFORMATION FOR SPLINE FIT 
C     ***** JUMP POINT FOR MODE=3 ENTRY ***** 
C 
  500 DEDX=ZERO 
      DO 510 K=1,MINPQ 
  510 DEDX=DEDX+THETA(K)*FOCK(K,K) 
      DENOW=-4.0*DEDX 
      ENOW=E 
      IF(IPOINT.LE.12) GO TO 530 
C#      WRITE(6,9990) IPOINT 
  520 FORMAT(//34H EXCESSIVE DATA PNTS FOR SPLINE./ 
     1,9H IPOINT =,I3,15H MAXIMUM IS 12.) 
c      CALL SYSTEM(52) 
C 
C     PERFORM 1-D SEARCH AND DETERMINE EXIT MODE. 
C 
  530 X(IPOINT)=XNOW 
      F(IPOINT)=ENOW 
      DF(IPOINT)=DENOW 
      CALL SPLINE 
      IF((EOLD-ENOW).GT.FF*(EOLD-EMIN).OR.IPOINT.GT.10) GO TO 560 
C 
C     (MODE=3 EXIT) RECOMPUTE CP VECTORS AT PREDICTED MINIMUM. 
C 
      XNOW=XMIN 
C#      IF(DEBUG1)WRITE(6,'(''  EIGENVECTORS OF CP BEFORE ROTATION'')') 
C#      CALL MATOUT(CP,0.D0,N,N,N) 
C#      IF(DEBUG1)CALL MATOUT(CP,0.D0,6,6,N) 
C#      IF(DEBUG1)WRITE(6,'(''  EIGENVECTORS OF VEC BEFORE ROTATION'')') 
C#      IF(DEBUG1)CALL MATOUT(VEC,0.D0,6,6,N) 
C#      CALL MATOUT(VEC,0.D0,N,N,N) 
      DO 550 K=1,MINPQ 
         CK=COS(XNOW*THETA(K)) 
         SK=SIN(XNOW*THETA(K)) 
         IF(DEBUG)WRITE(6,'('' ROTATION ANGLE:'',F12.4)')SK*57.29578 
         DO 540 I=1,N 
            CP(I,K)   =CK*VEC(I,K)-SK*VEC(I,NP+K) 
  540    CP(I,NP+K)=SK*VEC(I,K)+CK*VEC(I,NP+K) 
  550 CONTINUE 
C#      IF(DEBUG1)WRITE(6,'(''  EIGENVECTORS AFTER ROTATION'')') 
C#      IF(DEBUG1)CALL MATOUT(CP,0.D0,6,6,N) 
C#      CALL MATOUT(CP,0.D0,N,N,N) 
      MODE=3 
C#      WRITE(6,'(''  MODE=3 - DO NOT DIAGONALIZE  - RECALCULATE P'')') 
      RETURN 
C 
C     (MODE=2 EXIT) CURRENT VECTORS GIVE SATISFACTORY ENERGY IMPROVEMENT 
C     CURRENT POINT BECOMES OLD POINT FOR THE NEXT 1-D SEARCH. 
C 
  560 IF(MODE.EQ.2) GO TO 580 
      DO 570 I=1,N 
         DO 570 J=1,N 
  570 VEC(I,J)=CP(I,J) 
      MODE=2 
  580 ROLD=XOLD*THETA(1)*57.29578 
      RNOW=XNOW*THETA(1)*57.29578 
      RMIN=XMIN*THETA(1)*57.29578 
      IF(DEBUG)WRITE(6,600) XOLD,EOLD*23.061,DEOLD,ROLD 
     1,             XNOW,ENOW*23.061,DENOW,RNOW 
     2,             XMIN,EMIN*23.061,DEMIN,RMIN 
      EOLD=ENOW 
C#      WRITE(6,'(''  MODE=2 - NEW VECTORS CALC''''D'')') 
C#      IF(NPNTS.LE.2) RETURN 
      IF(NPNTS.LE.200) RETURN 
      WRITE(6,610) 
      DO 590 K=1,NPNTS 
  590 WRITE(6,620) K,X(K),F(K),DF(K) 
      WRITE(6,630) 
      RETURN 
  600 FORMAT( 
     1/14X,3H X ,10X,6H F(X) ,9X,7H DF/DX ,21H   ROTATION (DEGREES), 
     2/10H      OLD ,F10.5,3F15.10, 
     3/10H  CURRENT ,F10.5,3F15.10, 
     4/10H PREDICTED,F10.5,3F15.10/) 
  610 FORMAT(3H  K,10H     X(K) ,15H       F(K)    ,10H     DF(K)) 
  620 FORMAT(I3,F10.5,2F15.10) 
  630 FORMAT(10X) 
      END 
      SUBROUTINE SPLINE 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     FIT F(X) BY A CUBIC SPLINE GIVEN VALUES OF THE FUNCTION 
C     AND ITS FIRST DERIVATIVE AT N PNTS. 
C     SUBROUTINE RETURNS VALUES OF XMIN,FMIN, AND DFMIN 
C     AND MAY REORDER THE DATA. 
C     CALLING PROGRAM SUPPLIES ALL OTHER VALUES IN THE 
C     COMMON BLOCK. 
C     XLOW AND XHIGH SET LIMITS ON THE INTERVAL WITHIN WHICH 
C     TO SEARCH.  SUBROUTINE MAY FURTHER REDUCE THIS INTERVAL. 
C 
      COMMON/FIT/N,IDUM2,XLOW,XHIGH,XMIN,FMIN,DFMIN,X(12),F(12),DF(12) 
      LOGICAL SKIP1,SKIP2 
      DATA CLOSE, BIG, HUGE, USTEP, DSTEP/1.0E-8,500.0,1.0E+10,1.0,2.0/ 
       SAVE
C 
C     SUBROUTINE ASSUMES THAT THE FIRST N-1 DATA PNTS HAVE BEEN 
C     PREVIOUSLY ORDERED,  X(I).LT.X(I+1) FOR I=1,2,...,N-2 
C     NOW MOVE NTH POINT TO ITS PROPER PLACE. 
C 
      XMIN=X(N) 
      FMIN=F(N) 
      DFMIN=DF(N) 
      N1=N-1 
      K=N1 
   10 IF(X(K).LT.XMIN) GO TO 20 
      X(K+1)=X(K) 
      F(K+1)=F(K) 
      DF(K+1)=DF(K) 
      K=K-1 
      IF(K.GT.0) GO TO 10 
   20 X(K+1)=XMIN 
      F(K+1)=FMIN 
      DF(K+1)=DFMIN 
C 
C     DEFINE THE INTERVAL WITHIN WHICH WE TRUST THE SPLINE FIT. 
C     USTEP =  UP HILL STEP SIZE FACTOR 
C     DSTEP = DOWN HILL STEP SIZE FACTOR 
C 
      IF(DF(1).GT.0.0) STEP=DSTEP 
      IF(DF(1).LE.0.0) STEP=USTEP 
      XSTART=X(1)-STEP*(X(2)-X(1)) 
      XSTART=DMAX1(XSTART,XLOW) 
      IF(DF(N).GT.0.0) STEP=USTEP 
      IF(DF(N).LE.0.0) STEP=DSTEP 
      XSTOP=X(N)+STEP*(X(N)-X(N1)) 
      XSTOP=DMIN1(XSTOP,XHIGH) 
C 
C     SEARCH FOR MINIMUM 
C 
      DO 110 K=1,N1 
         SKIP1=K.NE.1 
         SKIP2=K.NE.N1 
         IF(F(K).GE.FMIN) GO TO 30 
         XMIN=X(K) 
         FMIN=F(K) 
         DFMIN=DF(K) 
   30    DX=X(K+1)-X(K) 
C 
C     SKIP INTERVAL IF PNTS ARE TOO CLOSE TOGETHER 
C 
         IF(DX.LE.CLOSE) GO TO 110 
         X1=0.0 
         IF(K.EQ.1) X1=XSTART-X(1) 
         X2=DX 
         IF(K.EQ.N1) X2=XSTOP-X(N1) 
C 
C     (A,B,C)=COEF OF (CUBIC,QUADRATIC,LINEAR) TERMS 
C 
         DUM=(F(K+1)-F(K))/DX 
         A=(DF(K)+DF(K+1)-DUM-DUM)/(DX*DX) 
         B=(DUM+DUM+DUM-DF(K)-DF(K)-DF(K+1))/DX 
         C=DF(K) 
C 
C     XK = X-X(K) AT THE MINIMUM WITHIN THE KTH SUBINTERVAL 
C     TEST FOR PATHOLOGICAL CASES. 
C 
         BB=B*B 
         AC3=(A+A+A)*C 
         IF(BB.LT.AC3) GO TO 90 
         IF( B.GT.0.0) GO TO 40 
         IF(ABS(B).GT.HUGE*ABS(A)) GO TO 90 
         GO TO 50 
   40    IF(BB.GT.BIG*ABS(AC3)) GO TO 60 
C 
C     WELL BEHAVED CUBIC 
C 
   50    XK=(-B+SQRT(BB-AC3))/(A+A+A) 
         GO TO 70 
C 
C     CUBIC IS DOMINATED BY QUADRATIC TERM 
C 
   60    R=AC3/BB 
         XK=-(((0.039063*R+0.0625)*R+0.125)*R+0.5)*C/B 
   70    IF(XK.LT.X1.OR.XK.GT.X2) GO TO 90 
   80    FM=((A*XK+B)*XK+C)*XK+F(K) 
         IF(FM.GT.FMIN) GO TO 90 
         XMIN=XK+X(K) 
         FMIN=FM 
         DFMIN=((A+A+A)*XK+B+B)*XK+C 
C 
C     EXTRAPOLATE TO END OF INTERVAL IF K=1 AND/OR K=N1 
C 
   90    IF(SKIP1) GO TO 100 
         SKIP1=.TRUE. 
         XK=X1 
         GO TO 80 
  100    IF(SKIP2) GO TO 110 
         SKIP2=.TRUE. 
         XK=X2 
         GO TO 80 
  110 CONTINUE 
      RETURN 
      END 
      SUBROUTINE SCHMIT(U,N,NDIM) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION U(NDIM,NDIM) 
      DATA ZERO,SMALL,ONE/0.0,0.01,1.0/ 
       SAVE
      II=0 
      DO 110 K=1,N 
         K1=K-1 
C 
C     NORMALIZE KTH COLUMN VECTOR 
C 
         DOT = ZERO 
         DO 10 I=1,N 
   10    DOT=DOT+U(I,K)*U(I,K) 
         IF(DOT.EQ.ZERO) GO TO 100 
         SCALE=ONE/SQRT(DOT) 
         DO 20 I=1,N 
   20    U(I,K)=SCALE*U(I,K) 
   30    IF(K1.EQ.0) GO TO 110 
         NPASS=0 
C 
C     PROJECT OUT K-1 PREVIOUS ORTHONORMAL VECTORS FROM KTH VECTOR 
C 
   40    NPASS=NPASS+1 
         DO 70 J=1,K1 
            DOT=ZERO 
            DO 50 I=1,N 
   50       DOT=DOT+U(I,J)*U(I,K) 
            DO 60 I=1,N 
   60       U(I,K)=U(I,K)-DOT*U(I,J) 
   70    CONTINUE 
C 
C     SECOND NORMALIZATION (AFTER PROJECTION) 
C     IF KTH VECTOR IS SMALL BUT NOT ZERO THEN NORMALIZE 
C     AND PROJECT AGAIN TO CONTROL ROUND-OFF ERRORS. 
C 
         DOT=ZERO 
         DO 80 I=1,N 
   80    DOT=DOT+U(I,K)*U(I,K) 
         IF(DOT.EQ.ZERO) GO TO 100 
         IF(DOT.LT.SMALL.AND.NPASS.GT.2) GO TO 100 
         SCALE=ONE/SQRT(DOT) 
         DO 90 I=1,N 
   90    U(I,K)=SCALE*U(I,K) 
         IF(DOT.LT.SMALL) GO TO 40 
         GO TO 110 
C 
C     REPLACE LINEARLY DEPENDENT KTH VECTOR BY A UNIT VECTOR. 
C 
  100    II=II+1 
C     IF(II.GT.N) STOP 
         U(II,K)=ONE 
         GO TO 30 
  110 CONTINUE 
      RETURN 
      END 
      SUBROUTINE SCHMIB(U,N,NDIM) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     SAME AS SCHMIDT BUT WORKS FROM RIGHT TO LEFT. 
C 
      DIMENSION U(NDIM,NDIM) 
      DATA ZERO,SMALL,ONE/0.0,0.01,1.0/ 
       SAVE
      N1=N+1 
      II=0 
      DO 110 K=1,N 
         K1=K-1 
C 
C     NORMALIZE KTH COLUMN VECTOR 
C 
         DOT = ZERO 
         DO 10 I=1,N 
   10    DOT=DOT+U(I,N1-K)*U(I,N1-K) 
         IF(DOT.EQ.ZERO) GO TO 100 
         SCALE=ONE/SQRT(DOT) 
         DO 20 I=1,N 
   20    U(I,N1-K)=SCALE*U(I,N1-K) 
   30    IF(K1.EQ.0) GO TO 110 
         NPASS=0 
C 
C     PROJECT OUT K-1 PREVIOUS ORTHONORMAL VECTORS FROM KTH VECTOR 
C 
   40    NPASS=NPASS+1 
         DO 70 J=1,K1 
            DOT=ZERO 
            DO 50 I=1,N 
   50       DOT=DOT+U(I,N1-J)*U(I,N1-K) 
            DO 60 I=1,N 
   60       U(I,N1-K)=U(I,N1-K)-DOT*U(I,N1-J) 
   70    CONTINUE 
C 
C     SECOND NORMALIZATION (AFTER PROJECTION) 
C     IF KTH VECTOR IS SMALL BUT NOT ZERO THEN NORMALIZE 
C     AND PROJECT AGAIN TO CONTROL ROUND-OFF ERRORS. 
C 
         DOT=ZERO 
         DO 80 I=1,N 
   80    DOT=DOT+U(I,N1-K)*U(I,N1-K) 
         IF(DOT.EQ.ZERO) GO TO 100 
         IF(DOT.LT.SMALL.AND.NPASS.GT.2) GO TO 100 
         SCALE=ONE/SQRT(DOT) 
         DO 90 I=1,N 
   90    U(I,N1-K)=SCALE*U(I,N1-K) 
         IF(DOT.LT.SMALL) GO TO 40 
         GO TO 110 
C 
C     REPLACE LINEARLY DEPENDENT KTH VECTOR BY A UNIT VECTOR. 
C 
  100    II=II+1 
C     IF(II.GT.N) STOP 
         U(II,N1-K)=ONE 
         GO TO 30 
  110 CONTINUE 
      RETURN 
      END 
      SUBROUTINE ITER  (H, W, WJ, WK, EE, LGRAD, RESTOR) 
      IMPLICIT REAL (A-H,O-Z) 
      REAL MECI 
       INCLUDE "SIZES"
      PARAMETER (MPULAY=(MORB2*(NRELAX-8)-98)/4) 
      DIMENSION H(*), W(*), WJ(*), WK(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM), NORBS, NELECS 
     2               ,NALPHA, NBETA, NCLOSE, NOPEN, NDUMY, FRACT 
     3       /MOLORB/ DUMMY(MAXORB),PDIAG(MAXORB) 
     4       /KEYWRD/ KEYWRD 
     5       /NUMSCF/ NSCF,FROZEN 
     6       /FOKMAT/ F(MPACK), FB(MPACK) 
     7       /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
     8       /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) 
      COMMON /LAST  / LAST 
     1       /MESAGE/ IFLEPO,IITER 
     2       /ATHEAT/ ATHEAT 
     3       /ENUCLR/ ENUCLR 
     4       /CITERM/ XI,XJ,XK 
     5       /REPATH/ LATOM,LPARAM,REACT(100) 
     6       /NUMCAL/ NUMCAL 
     7       /TIME  / TIME0 
     8       /PRECI / SCFCV,SCFTOL,DUM(9),KDUM(MAXPAR) 
     9       /OPTIM / IMP,IMP0,LEC,IPRT 
      COMMON /SCRAH2/ POLD(MPULAY),  POLD2(MPULAY),  POLD3(49) 
     1               ,PBOLD(MPULAY), PBOLD2(MPULAY), PBOLD3(49) 
     2               ,AR1(MORB2), AR2(MORB2), AR3(MORB2), AR4(MORB2) 
     3               ,BR1(MORB2), BR2(MORB2), BR3(MORB2), BR4(MORB2) 
C 
C    NOTE... /SCRAH2/ IS A WORK AREA REQUIRED BY THE VARIOUS CONVERGERS. 
C                     IT IS ALSO USED IN THE ITERATIVE COMPUTATION OF 
C                     THE DERIVATIVES OF THE M.O IN ROUTINE 'DERI2'. 
C*********************************************************************** 
C 
C                        ITER GENERATES A SCF FIELD 
C     ON INPUT : 
C              LGRAD=.T. IF THE GRADIENT IS TO BE COMPUTED, IMPLYING A 
C                        LARGE NUMBER OF <IJ!KL> TO BE CALCULATED WHEN 
C                        CALLING MECI (ANALYTICAL GRADIENT ONLY). 
C                    .F. OTHERWISE. 
C              RESTOR=.T. RESET THE DENSITY MATRICES WITH THE DIAGONAL 
C                         APPROXIMATION AND ITERATE 
C                     .F. START WITH THE PREVIOUS DENSITY MATRICES 
C     ON OUTPUT : 
C              IITER=  2  IF NOT CONVERGED, 1 OTHERWISE 
C              EE      ELECTRONIC ENERGY (EV) INCLUDING C.I. CORRECTION 
C 
C THE MAIN ARRAYS USED IN ITER ARE: 
C            P      ONLY EVER CONTAINS THE TOTAL DENSITY MATRIX 
C            PA     ONLY EVER CONTAINS THE ALPHA DENSITY MATRIX 
C            PB     ONLY EVER CONTAINS THE BETA DENSITY MATRIX 
C            C      ONLY EVER CONTAINS THE EIGENVECTORS 
C            H      ONLY EVER CONTAINS THE ONE-ELECTRON MATRIX 
C            F      STARTS OFF CONTAINING THE ONE-ELECTRON MATRIX, 
C                   AND IS USED TO HOLD THE FOCK MATRIX 
C            W      ONLY EVER CONTAINS THE TWO-ELECTRON MATRIX 
C 
C THE MAIN INTEGERS CONSTANTS IN ITER ARE: 
C 
C            LINEAR SIZE OF PACKED TRIANGLE = NORBS*(NORBS+1)/2 
C 
C THE MAIN  VARIABLES ARE 
C            NITER  NUMBER OF ITERATIONS EXECUTED 
C            SELCON=SCFCRT*SCFTOL CONVERGENCE THRESHOLD (KCAL) 
C 
C  PRINCIPAL REFERENCES: 
C 
C   ON MNDO: "GROUND STATES OF MOLECULES. 38. THE MNDO METHOD. 
C             APPROXIMATIONS AND PARAMETERS." 
C             DEWAR, M.J.S., THIEL,W., J. AM. CHEM. SOC.,99,4899,(1977). 
C   ON SHIFT: "UNCONDITIONAL CONVERGENCE IN SCF THEORY: A GENERAL LEVEL 
C             SHIFT TECHNIQUE" 
C             CARBO, R., HERNANDEZ, J.A., SANZ, F., CHEM. PHYS. LETT., 
C             47, 581, (1977) 
C   ON HALF-ELECTRON: "MINDO/3 COMPARISON OF THE GENERALISED S.C.F. 
C             COUPLING OPERATOR AND "HALF-ELECTRON" METHODS FOR 
C             CALCULATING THE ENERGIES AND GEOMETRIES OF OPEN SHELL 
C             SYSTEMS" 
C             DEWAR, M.J.S., OLIVELLA, S., J.CHEM.SOC.FARAD.TRANS. 2 
C                                         ,75,829,(1979). 
C   ON PULAY'S CONVERGER: "CONVERGENCE ACCELERATION OF ITERATIVE 
C             SEQUENCES. THE CASE OF SCF ITERATION", PULAY, P., 
C             CHEM. PHYS. LETT, 73, 393, (1980). 
C   ON PSEUDODIAGONALISATION: "FAST SEMIEMPIRICAL CALCULATIONS", 
C             STEWART. J.J.P., CSASZAR, P., PULAY, P., J. COMP. CHEM., 
C             3, 227, (1982) 
C 
C*********************************************************************** 
      CHARACTER KEYWRD*80, ABPRT(3)*5 
      LOGICAL PRTFOK,PRTEIG,PRTDEN, DEBUG, PRTENG, TIMES, CI 
     1       ,UHF, NEWDG, HALFE, FORCE, PRT1EL, PRTPL, LGRAD, RESTOR 
     2       ,EXCITD, MINPRT, FRST, OKPULY, OKPULA, READY, PRTVEC 
     3       ,CAMKIN, SOMCON, ALLCON, MAKEA, MAKEB, INCITR, FROZEN 
      DATA    ICALCN/0/,ABPRT/'     ','ALPHA',' BETA'/ 
      SAVE
C 
C  INITIALIZE 
C 
      EOLD=1.D2 
      READY=.FALSE. 
      IF (ICALCN.NE.NUMCAL) THEN 
         ICALCN=NUMCAL 
         LINEAR=(NORBS*(NORBS+1))/2 
C 
C    DEBUG KEY-WORDS WORKED OUT 
C 
         DEBUG=INDEX(KEYWRD,'ITE') .NE. 0 
         MINPRT=INDEX(KEYWRD,'SADD')+LATOM.EQ.0 .OR. DEBUG 
         PRTEIG=INDEX(KEYWRD,'EIGS') .NE. 0 
         PRTENG=INDEX(KEYWRD,'ENER') .NE. 0 
         PRTPL =INDEX(KEYWRD,' PL ') .NE. 0 
         IF( INDEX(KEYWRD,'DEBU').NE. 0 ) THEN 
            PRT1EL=INDEX(KEYWRD,'1ELE') .NE. 0 
            PRTDEN=INDEX(KEYWRD,'DENS') .NE. 0 
            PRTFOK=INDEX(KEYWRD,'FOCK') .NE. 0 
            PRTVEC=INDEX(KEYWRD,'VECT') .NE. 0 
         ELSE 
            PRT1EL=.FALSE. 
            PRTDEN=.FALSE. 
            PRTFOK=.FALSE. 
            PRTVEC=.FALSE. 
         ENDIF 
C 
C INITIALIZE SOME LOGICALS AND CONSTANTS 
C 
         FROZEN=.FALSE. 
         NEWDG =.FALSE. 
         PL    =1.D0 
         IFILL=0 
         BSHIFT=0.D0 
         ITRMAX = 200 
         NMOS=0 
         NCIS=0 
         NA2EL=NCLOSE 
         NSCF=0 
         NA1EL=NALPHA+NOPEN 
         NB2EL=0 
         NB1EL=NBETA+NOPEN 
C 
C  USE KEY-WORDS TO ASSIGN VARIOUS CONSTANTS 
C 
         IF(INDEX(KEYWRD,'C.I.=') .NE. 0) 
     1      NMOS=READA(KEYWRD,INDEX(KEYWRD,'C.I.=')+5) 
         IF(INDEX(KEYWRD,'MICR')  .NE. 0) 
     1      NCIS=READA(KEYWRD,INDEX(KEYWRD,'MICR')) 
         IF(INDEX(KEYWRD,'FILL=') .NE. 0) 
     1      IFILL=-READA(KEYWRD,INDEX(KEYWRD,'FILL=')) 
         IF(INDEX(KEYWRD,'SHIF')  .NE. 0) 
     1      BSHIFT=-READA(KEYWRD,INDEX(KEYWRD,'SHIF')) 
         IF(INDEX(KEYWRD,'ITRY=') .NE. 0) 
     1      ITRMAX=READA(KEYWRD,INDEX(KEYWRD,'ITRY')) 
         CAMKIN=(INDEX(KEYWRD,'KING')+INDEX(KEYWRD,'CAMP') .NE. 0) 
         CI    =(INDEX(KEYWRD,'MICR')+INDEX(KEYWRD,'C.I.') .NE. 0) 
         UHF   =(INDEX(KEYWRD,'UHF') .NE. 0) 
         EXCITD=(INDEX(KEYWRD,'EXCI') .NE. 0) 
         TIMES =(INDEX(KEYWRD,'TIME') .NE. 0) 
         FORCE =(INDEX(KEYWRD,'FORC') .NE. 0) 
         OKPULA=(INDEX(KEYWRD,'PULA') .NE. 0) 
         ALLCON=(OKPULA.OR.(BSHIFT.NE.0.D0).OR.CAMKIN) 
         SOMCON=ALLCON 
C 
C   SET UP C.I. PARAMETERS 
C   NMOS IS NO. OF M.O.S USED IN C.I. 
C   NCIS IS CHANGE IN SPIN, OR NUMBER OF STATES 
C 
         IF(NMOS.EQ.0) NMOS=NOPEN-NCLOSE 
         IF(NCIS.EQ.0) THEN 
            IF(INDEX(KEYWRD,'TRIP')+INDEX(KEYWRD,'QUAR').NE.0)NCIS=1 
            IF(INDEX(KEYWRD,'QUIN')+INDEX(KEYWRD,'SEXT').NE.0)NCIS=2 
         ENDIF 
         TRANS=0.1D0 
         IF(INDEX(KEYWRD,'REST')+INDEX(KEYWRD,'OLDE') 
     1      .NE. 0) THEN 
            REWIND 10 
            READ(10)(PA(I),I=1,LINEAR) 
            IF( UHF) THEN 
               READ(10)(PB(I),I=1,LINEAR) 
               DO 10 I=1,LINEAR 
   10          P(I)=PA(I)+PB(I) 
            ELSE 
               DO 20 I=1,LINEAR 
   20          P(I)=PA(I)*2.D0 
            ENDIF 
            ELSEIF(INDEX(KEYWRD,'OLDM') .NE. 0) THEN 
              REWIND 15 
              CALL VECRED(PA,NORBS,15) 
              IF(UHF) THEN 
                    CALL VECRED(PB,NORBS,15) 
                    DO 18 I=1,LINEAR 
   18               P(I)=PA(I)+PB(I) 
              ELSE 
                    DO 19 I=1,LINEAR 
                    P(I)=PA(I) 
   19               PA(I)=PA(I)/2.0D0 
              ENDIF 
         ELSE 
            DO 30 I=1,LINEAR 
            P(I)=0.D0 
            PA(I)=0.D0 
   30       PB(I)=0.D0 
            W1=NA1EL/(NA1EL+1.D-6+NB1EL) 
            W2=1.D0-W1 
            IF(W1.LT.1.D-6)W1=0.5D0 
            IF(W2.LT.1.D-6)W2=0.5D0 
            RANDOM=1.0D0 
            IF(UHF.AND.NA1EL.EQ.NB1EL) RANDOM=1.1D0 
            J=0 
            DO 40 I=1,NORBS 
            J=J+I 
            P(J)=PDIAG(I) 
            PA(J)=P(J)*W1*RANDOM 
            RANDOM=1.D0/RANDOM 
   40       PB(J)=P(J)*W2*RANDOM 
            CALL SCOPY (LINEAR,PB,1,PBOLD,1) 
            CALL SCOPY (LINEAR,PA,1,POLD ,1) 
         ENDIF 
         HALFE=(NOPEN .NE. NCLOSE) 
         IF( HALFE ) THEN 
            IF(NOPEN-NCLOSE.EQ.1) THEN 
               IHOMO=(NCLOSE-1)*NORBS+1 
               ILUMO=IHOMO+NORBS 
            ELSE 
               IPART1=NCLOSE*NORBS+1 
               IPART2=IPART1+NORBS 
            ENDIF 
         ENDIF 
C 
C   DETERMINE THE SELF-CONSISTENCY CRITERION 
C 
C        DEFAULT VALUE (EV) 
         SCFCRT=0.00001D0 
         IF( FORCE .OR. 
     .       INDEX(KEYWRD,'POLA') + 
     .       INDEX(KEYWRD,'LTRD') + 
     .       INDEX(KEYWRD,'NEWT') .NE. 0) 
     .                                 SCFCRT=SCFCRT*0.01D0 
         IF(INDEX(KEYWRD,'PREC').NE.0) SCFCRT=SCFCRT*0.01D0 
C        OR STATED BY THE USER 
         I=INDEX(KEYWRD,'SCFC') 
         IF(I.NE.0) THEN 
            SCFCRT=MAX(READA(KEYWRD,I),1.D-11) 
            WRITE(IPRT,'('' SCF CRITERION ='',1PD7.1,'' EV'')')SCFCRT 
         ELSE IF (DEBUG) THEN 
            WRITE(IPRT,'('' SCF CRITERION ='',1PD7.1,'' EV'')')SCFCRT 
         ENDIF 
         LAST=0 
         SCFTOL=1.D0 
C 
C   STATISTICAL ESTIMATE OF THE ERROR ON THE ELECTRONIC ENERGY 
C 
C        ROUNDING-OFF ERROR ("5D-13"ONLY IS MACHINE DEPENDANT) 
         K=0 
         SCFCV=0.D0 
         DO 51 I=1,NORBS 
         K=K+I 
   51    SCFCV=SCFCV+H(K)**2 
         SCFCV=SQRT(SCFCV/NORBS) 
         SCFCV=(34.5915D0*NELECS*SCFCV)*5.0D-13 
C        NOW WE USE THE TWO FOLLOWING EMPIRICAL LAWS (LEAST SQUARE FIT) 
C        => LOG10(SCFCV)= 0.7174 * LOG10(SCFCRT) + 0.0913 
C                WITH COVARIANCE MATRIX : 
C                                       .0082662800 
C                                       .0413313999 .2397221193 
C        => LOG10(SCFCV)= 1.0968 * LOG10(PLTEST) + 0.5742 
C        WHERE SCFCV  IS AN ESTIMATE OF THE ENERGY DROP OUT (KCAL) ... 
C                     ASSUMING THAT ROUNDOFF IS NEGLIGIBLE. 
C                     ('converged' energy - true one) = SCFCV) 
C              PLTEST IS THE CONVERGENCE THRESHOLD ON DIAGONAL ELEMENTS 
C                     OF THE TOTAL DENSITY MATRIX. 
C        THUS,GIVEN SCFCRT,ONE GETS A REASONABLE VALUE OF PLTEST AND 
C        A VALUE FOR THE STANDARD DEVIATION OF THE ENERGY ,SCFCV, 
C        (via covariance matrix) 
C        FOR FURTHER USE IN GRADIENT AND HESSIAN EVALUATION. 
         SCFLOG=LOG10(SCFCRT) 
         EE=1.D1**(0.66358D0*SCFLOG-0.29045D0) 
         SIGMA=EE*SQRT ( 
     .   (.0082662800D0*SCFLOG+0.0826627998D0)*SCFLOG+.2397221193D0 ) 
         IF(DEBUG) WRITE(IPRT,FMT='('' ROUNDING-OFF ERROR'',1PD8.1, 
     .   '' KCAL/MOLE''/ 
     .   '' ENERGY DROPOUT'',D8.1,'' WITH STANDARD DEVIATION'',D8.1, 
     .   '' KCAL/MOLE'')') 
     .   SCFCV,EE,SIGMA 
         IF(EE.LT.3.D0*SCFCV) WRITE(IPRT,FMT='('' ==> THERE IS A RISK'' 
     .,'' OF INFINITE LOOPING WITH  SCFCRT ='',1PD8.1)')SCFCRT 
         SCFCV=SIGMA+SCFCV+EE 
C 
C   END OF INITIALIZATION SECTION. 
C 
      END IF 
C 
C   RESTORE DENSITY MATRICES IF NEEDED 
C 
      IF (RESTOR) THEN 
         IF(DEBUG)WRITE(IPRT,'(''RESTORE ALL DENSITY MATRICES'')') 
         NEWDG=.FALSE. 
         DO 52 I=1,LINEAR 
         P (I)=0.D0 
         PA(I)=0.D0 
   52    PB(I)=0.D0 
         RANDOM=1.D0 
         IF(UHF.AND.NA1EL.EQ.NB1EL) RANDOM=1.1D0 
         J=0 
         DO 53 I=1,NORBS 
         J=J+I 
         P(J)=PDIAG(I) 
         PA(J)=P(J)*W1*RANDOM 
         RANDOM=1.D0/RANDOM 
   53    PB(J)=P(J)*W2*RANDOM 
         CALL SCOPY (LINEAR,PB,1,PBOLD,1) 
         CALL SCOPY (LINEAR,PA,1,POLD ,1) 
      ENDIF 
C 
C   THE FOLLOWING INITIALIZATION OPERATIONS DONE EVERY CALL TO ITER 
C 
      MAKEA=.TRUE. 
      MAKEB=.TRUE. 
      PL=1.D0 
      IF(NEWDG) NEWDG=(ABS(BSHIFT).LT.0.001D0) 
      IF(LAST.EQ.1) NEWDG=.FALSE. 
C   SCFTOL IS MANAGED BY THE ACTIVATED OPTIMIZATION ROUTINE 
C   SELCON AND PLTEST ARE COUPLED BY THE TWO PRECEEDING EMPIRICAL LAWS 
      SELCON=SCFCRT*23.061D0 
      IF(SCFTOL.GT.1.D0) SELCON=MIN(SELCON*SCFTOL,0.023D0) 
      PLTEST=1.D1**(0.6050D0*LOG10(SELCON)-1.6129D0) 
      IF(DEBUG)WRITE(IPRT,'(''  SELCON, SCFTOL, PLTEST'',3F16.9)') 
     .                       SELCON, SCFTOL, PLTEST 
      CALL SECOND (TITER1) 
      IF(PRT1EL) THEN 
         WRITE(IPRT,'(10X,''ONE-ELECTRON MATRIX AT ENTRANCE TO ITER'')') 
         CALL VECPRT(H,NORBS) 
      ENDIF 
      IREDY=0 
   60 NITER=0 
      FRST=.TRUE. 
      IF(CAMKIN) THEN 
         MODEA=1 
         MODEB=1 
      ELSE 
         MODEA=0 
         MODEB=0 
      ENDIF 
********************************************************************** 
*                                                                    * 
*                                                                    * 
*                START THE SCF LOOP HERE                             * 
*                                                                    * 
*                                                                    * 
********************************************************************** 
      INCITR=.TRUE. 
   70 INCITR=(MODEA.NE.3.AND.MODEB.NE.3) 
      IF(INCITR)NITER=NITER+1 
      OKPULY=OKPULA.AND.(PL.LT.2.D-2).AND.IREDY.GT.2 
      IF(NITER.EQ.ITRMAX.AND..NOT.ALLCON) THEN 
************************************************************************ 
*                                                                      * 
*                   SWITCH ON ALL CONVERGERS                           * 
*                                                                      * 
************************************************************************ 
         WRITE(IPRT,'(//,'' ALL CONVERGERS ARE NOW FORCED ON'',/ 
     1          '' SHIFT=1000, PULAY ON, CAMP-KING ON'',/ 
     2          '' AND ITERATION COUNTER RESET'',//)') 
         ALLCON=.TRUE. 
         BSHIFT=-1000.2 
         IREDY=-4 
         EOLD=100.D0 
         OKPULA=.TRUE. 
         NEWDG=.FALSE. 
         CAMKIN=(.NOT.HALFE) 
         GOTO 60 
      ENDIF 
************************************************************************ 
*                                                                      * 
*                        MAKE THE ALPHA FOCK MATRIX                    * 
*                                                                      * 
************************************************************************ 
      IF(BSHIFT .NE. 0.D0) THEN 
         L=0 
         SHIFT=BSHIFT*(NITER+1.D0)**(-1.5D0) 
         DO 90 I=1,NORBS 
            DO 80 J=1,I 
               L=L+1 
   80       F(L)=H(L)+SHIFT*PA(L) 
   90    F(L)=F(L)-SHIFT 
      ELSE 
         CALL SCOPY (LINEAR,H,1,F,1) 
      ENDIF 
  110 CALL FOCK2(F,P,PA,W, WJ, WK,NUMAT,NFIRST,NMIDLE,NLAST) 
      CALL FOCK1(F,P,PA,PB) 
************************************************************************ 
*                                                                      * 
*                        MAKE THE BETA FOCK MATRIX                     * 
*                                                                      * 
************************************************************************ 
      IF (UHF) THEN 
         IF(SHIFT .NE. 0.D0) THEN 
            L=0 
            DO 130 I=1,NORBS 
               DO 120 J=1,I 
                  L=L+1 
  120          FB(L)=H(L)+SHIFT*PB(L) 
  130       FB(L)=FB(L)-SHIFT 
         ELSE 
            CALL SCOPY (LINEAR,H,1,FB,1) 
         ENDIF 
         CALL FOCK2(FB,P,PB,W, WJ, WK,NUMAT,NFIRST,NMIDLE,NLAST) 
         CALL FOCK1(FB,P,PB,PA) 
      ENDIF 
      IF (FROZEN.AND..NOT.RESTOR) GO TO 240 
      IF(PRTFOK) THEN 
         WRITE(IPRT,150)NITER 
  150    FORMAT('   FOCK MATRIX ON ITERATION',I3) 
         CALL VECPRT (F,NORBS) 
      END IF 
************************************************************************ 
*                                                                      * 
*                        CALCULATE THE ENERGY IN KCAL/MOLE             * 
*                                                                      * 
************************************************************************ 
      EE=HELECT(NORBS,PA,H,F) 
      IF(UHF)THEN 
         EE=EE+HELECT(NORBS,PB,H,FB) 
      ELSE 
         EE=EE*2.D0 
      ENDIF 
      ESCF=(EE+ENUCLR + SHIFT*(NOPEN-NCLOSE)*0.25D0)*23.061D0+ATHEAT 
      IF(INCITR)THEN 
         DIFF=ESCF-EOLD 
         IF(PL.LT.PLTEST.AND. 
     1   ABS(DIFF).LT.SELCON .AND. READY) THEN 
************************************************************************ 
*                                                                      * 
*          SELF-CONSISTENCY TEST, EXIT MODE FROM ITERATIONS            * 
*                                                                      * 
************************************************************************ 
            IF (ABS(SHIFT) .LT. 1.D-10) GOTO 240 
            SHIFT=0.D0 
            CALL SCOPY (LINEAR,H,1,F,1) 
            MAKEA=.TRUE. 
            MAKEB=.TRUE. 
            GOTO 110 
         ENDIF 
         READY=(IREDY.GT.0.AND.ABS(DIFF).LT.SELCON*10.D0) 
         IREDY=IREDY+1 
      ENDIF 
      IF(PRTPL) THEN 
         IF(ABS(ESCF).GT.99999.D0) ESCF=99999.D0 
         IF(ABS(DIFF).GT.9999.D0)DIFF=0.D0 
         IF(INCITR) 
     1    WRITE(IPRT,'('' ITERATION'',I3,'' PLS='',2E10.3,'' ENERGY  '', 
     2F14.7,'' DELTAE'',F13.7)')NITER,PL,PLB,ESCF,DIFF 
      ENDIF 
      IF(INCITR)EOLD=ESCF 
************************************************************************ 
*                                                                      * 
*                        INVOKE THE CAMP-KING CONVERGER                * 
*                                                                      * 
************************************************************************ 
      IF(NITER.GT.2 .AND. CAMKIN .AND. MAKEA) 
     1CALL INTERP(NORBS,NA1EL,NORBS-NA1EL, MODEA, ESCF/23.061D0, 
     2F, C, AR1, AR2, AR3, AR4, AR1) 
      MAKEB=.FALSE. 
      IF(MODEA.EQ.3)GOTO 180 
      MAKEB=.TRUE. 
      IF( NEWDG ) THEN 
************************************************************************ 
*                                                                      * 
*                        INVOKE PULAY'S CONVERGER                      * 
*                                                                      * 
************************************************************************ 
         IF(OKPULY.AND.MAKEA) 
     1CALL PULAY(F,PA,NORBS,POLD,POLD2,POLD3,JALP,IALP,MPULAY,FRST,PL) 
************************************************************************ 
*                                                                      * 
*           DIAGONALIZE THE ALPHA OR RHF SECULAR DETERMINANT           * 
* WHERE POSSIBLE, USE THE PULAY-STEWART METHOD, OTHERWISE USE BEPPU'S  * 
*                                                                      * 
************************************************************************ 
         IF (HALFE.OR.CAMKIN) THEN 
            CALL HQRII(F,NORBS,NORBS,EIGS,C) 
         ELSE 
            CALL DIAG (F,C,NA1EL,EIGS,NORBS,NORBS) 
         ENDIF 
      ELSE 
         CALL HQRII(F,NORBS,NORBS,EIGS,C) 
      END IF 
      J=1 
      IF(PRTVEC) THEN 
         J=1 
         IF(UHF)J=2 
         WRITE(IPRT,'(//10X,A, 
     1'' EIGENVECTORS AND EIGENVALUES ON ITERATION'',I3)') 
     2   ABPRT(J),NITER 
         CALL MATOUT(C,EIGS,NORBS,NORBS,NORBS) 
      ELSE 
         IF (PRTEIG) WRITE(IPRT,170)ABPRT(J),NITER,(EIGS(I),I=1,NORBS) 
      ENDIF 
  170 FORMAT(10X,A,'  EIGENVALUES ON ITERATION',I3,/10(6F13.6,/)) 
  180 IF(IFILL.NE.0)CALL SWAP(C,NORBS,NORBS,NA2EL,IFILL) 
************************************************************************ 
*                                                                      * 
*            CALCULATE THE ALPHA OR RHF DENSITY MATRIX                 * 
*                                                                      * 
************************************************************************ 
      IF(UHF)THEN 
         CALL DENSIT( C,NORBS, NORBS, NA2EL,NA1EL, FRACT, PA) 
      ELSE 
         CALL DENSIT( C,NORBS, NORBS, NA2EL,NA1EL, FRACT, P) 
      ENDIF 
      IF(MODEA.NE.3.AND..NOT. (NEWDG.AND.OKPULY)) 
     1    CALL CNVG(P, POLD, POLD2, NORBS, NITER, PL) 
************************************************************************ 
*                                                                      * 
*                       UHF-SPECIFIC CODE                              * 
*                                                                      * 
************************************************************************ 
      IF( UHF )THEN 
************************************************************************ 
*                                                                      * 
*                        INVOKE THE CAMP-KING CONVERGER                * 
*                                                                      * 
************************************************************************ 
         IF(NITER.GT.2 .AND. CAMKIN .AND. MAKEB ) 
     1CALL INTERP(NORBS,NB1EL,NORBS-NB1EL, MODEB, ESCF/23.061D0, 
     2FB, CBETA, BR1, BR2, BR3, BR4, BR1) 
         MAKEA=.FALSE. 
         IF(MODEB.EQ.3) GOTO 190 
         MAKEA=.TRUE. 
************************************************************************ 
*                                                                      * 
*                        INVOKE PULAY'S CONVERGER                      * 
*                                                                      * 
************************************************************************ 
         IF( NEWDG.AND.OKPULY.AND.MAKEB) THEN 
            CALL PULAY(FB,PB,NORBS,PBOLD,PBOLD2, 
     1               PBOLD3,JBET,IBET,MPULAY,FRST,PLB) 
************************************************************************ 
*                                                                      * 
*           DIAGONALIZE THE ALPHA OR RHF SECULAR DETERMINANT           * 
* WHERE POSSIBLE, USE THE PULAY-STEWART METHOD, OTHERWISE USE BEPPU'S  * 
*                                                                      * 
************************************************************************ 
            CALL DIAG (FB,CBETA,NB1EL,EIGB,NORBS,NORBS) 
         ELSE 
            CALL HQRII(FB,NORBS,NORBS,EIGB,CBETA) 
         END IF 
         IF(PRTVEC) THEN 
            WRITE(IPRT,'(//10X,A,'' EIGENVECTORS AND EIGENVALUES ON '', 
     1''ITERATION'',I3)')ABPRT(3),NITER 
            CALL MATOUT(CBETA,EIGB,NORBS,NORBS,NORBS) 
         ELSE 
            IF (PRTEIG) WRITE(IPRT,170)ABPRT(3),NITER, 
     1                                 (EIGB(I),I=1,NORBS) 
         ENDIF 
************************************************************************ 
*                                                                      * 
*                CALCULATE THE BETA DENSITY MATRIX                     * 
*                                                                      * 
************************************************************************ 
  190    CALL DENSIT( CBETA,NORBS, NORBS, NB2EL, NB1EL, FRACT, PB) 
         IF( .NOT. (NEWDG.AND.OKPULY)) 
     1CALL CNVG(PB, PBOLD, PBOLD2, NORBS, NITER, PLB) 
      ENDIF 
************************************************************************ 
*                                                                      * 
*                   CALCULATE THE TOTAL DENSITY MATRIX                 * 
*                                                                      * 
************************************************************************ 
      IF(UHF) THEN 
         DO 200 I=1,LINEAR 
  200    P(I)=PA(I)+PB(I) 
      ELSE 
         DO 210 I=1,LINEAR 
         PA(I)=P(I)*0.5D0 
  210    PB(I)=PA(I) 
      ENDIF 
      IF(PRTDEN) THEN 
         WRITE(IPRT,'('' DENSITY MATRIX ON ITERATION'',I4)')NITER 
         CALL VECPRT (P,NORBS) 
      END IF 
      NEWDG=(PL.LT.TRANS .OR. NEWDG) 
      IF (NITER .GT. ITRMAX) THEN 
         IF(MINPRT)WRITE (IPRT,220) 
  220    FORMAT (//10X,'""""""ITER : UNABLE TO ACHIEVE SELF-CONSISTENCE' 
     1,/) 
         WRITE (IPRT,230) DIFF,PL 
  230    FORMAT (//,10X,'DELTAE= ',E12.4,5X,'DELTAP= ',E12.4,///) 
         IFLEPO=9 
         IITER=2 
         CALL WRITE (TIME0,ESCF) 
         RETURN 
      END IF 
      GO TO 70 
********************************************************************** 
*                                                                    * 
*                                                                    * 
*                      END THE SCF LOOP HERE                         * 
*                NOW CALCULATE THE ELECTRONIC ENERGY                 * 
*                                                                    * 
*                                                                    * 
********************************************************************** 
*          SELF-CONSISTENCE ACHEIVED. 
* 
  240 EE=HELECT(NORBS,PA,H,F) 
      IITER=1 
      IF(UHF) THEN 
         EE=EE+HELECT(NORBS,PB,H,FB) 
      ELSE 
         EE=EE*2.D0 + SHIFT*(NOPEN-NCLOSE)*0.25D0 
      ENDIF 
      IF( NSCF.EQ.0 .OR. ABS(SHIFT) .GT. 1.D-5 .OR. CI .OR. HALFE ) THEN 
C 
C  PUT F AND FB INTO POLD IN ORDER TO NOT DESTROY F AND FB 
C  AND DO EXACT DIAGONALISATIONS 
         CALL SCOPY (LINEAR,F,1,POLD,1) 
         CALL HQRII(POLD,NORBS,NORBS,EIGS,C) 
         IF(UHF) THEN 
            CALL SCOPY (LINEAR,FB,1,POLD,1) 
            CALL HQRII(POLD,NORBS,NORBS,EIGB,CBETA) 
         ENDIF 
         IF(CI.OR.HALFE) 
     .   EE=EE+MECI(EIGS,C,CBETA,EIGB, NORBS,NMOS,NCIS,.FALSE.,.TRUE.) 
      ENDIF 
      IF(.NOT.FROZEN) NSCF=NSCF+1 
      CALL SECOND (TITER2) 
      IF(TIMES) WRITE(IPRT,'('' TIME FOR SCF CALCULATION'',F8.2, 
     1''    INTEGRAL'',F8.2)')TITER2-TITER1,TITER2-TIME0 
      IF(DEBUG)WRITE(IPRT,'('' NO. OF ITERATIONS ='',I3)')NITER 
      IF(SOMCON.OR.(ALLCON.AND.ABS(BSHIFT+1000.2).LT.0.01))THEN 
         CAMKIN=.FALSE. 
         ALLCON=.FALSE. 
         SOMCON=.FALSE. 
         NEWDG=.FALSE. 
         BSHIFT=0.D0 
         OKPULA=.FALSE. 
      ENDIF 
      IF(HALFE) BSHIFT=0.D0 
      RETURN 
C 
      END 
      SUBROUTINE LINMIN(XPARAM,STEP,PVECT,NVAR,FUNCT,OKF,OKC) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XPARAM(NVAR),PVECT(NVAR) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /NUMCAL/ NUMCAL 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT 
C********************************************************************* 
C 
C  LINMIN DOES A LINE MINIMISATION (DFP ALGORITHM) 
C 
C  ON INPUT:  XPARAM = STARTING COORDINATE OF SEARCH. 
C             STEP   = 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 MINIMISED. 
C             ISOK   = NOT IMPORTANT. 
C 
C  ON OUTPUT: XPARAM = COORDINATE OF MINIMUM OF FUNCTI0N. 
C             STEP   = NEW STEP SIZE, USED IN NEXT CALL OF LINMIN. 
C             PVECT  = UNCHANGED, OR NEGATED, DEPENDING ON STEP. 
C             FUNCT  = FINAL, MINIMUM VALUE OF THE FUNCTION. 
C             OKF    = TRUE IF LINMIN IMPROVED FUNCT, FALSE OTHERWISE. 
C             OKC    = TRUE IF LINMIN FOUND THE MINIMUM, FALSE OTHERWISE 
C 
C********************************************************************** 
      CHARACTER*80 KEYWRD 
      DIMENSION PHI(3), VT(3) 
      DIMENSION XSTOR(300) 
      INTEGER LEFT,RIGHT,CENTER 
      LOGICAL PRINT,OKF,OKC,FAIL 
      DATA ICALCN /0/ 
       SAVE
C 
      IF (ICALCN.NE.NUMCAL) THEN 
         DROP=0.002D0 
         IF(INDEX(KEYWRD,'PREC') .NE. 0) DROP=DROP*0.01D0 
         XMAXM  = 0.4D0 
         I      = 2 
         STEP   = 1.D0 
         MAXLIN = 15 
         XCRIT  = 0.0001D0 
         IF(INDEX(KEYWRD,'FORCE') .NE. 0) THEN 
            I=3 
            XCRIT=0.00001D0 
         ENDIF 
C 
         YMAXST  = 0.4D0 
         EPS=10**(-I) 
         TEE=EPS 
         PRINT=(INDEX(KEYWRD,'LINM') .NE. 0).OR.(IMP.GE.2) 
         ICALCN=NUMCAL 
      END IF 
      XMAXM=0.D0 
      DO 10 I=1,NVAR 
         PABS=ABS(PVECT(I)) 
   10 XMAXM=MAX(XMAXM,PABS) 
      XMINM=XMAXM 
      XMAXM=YMAXST/XMAXM 
      FIN=FUNCT 
      SSQLST=FUNCT 
      IQUIT=0 
      PHI(1)=FUNCT 
      VT(1)=0.0D00 
      VT(2)=STEP/4.0D00 
      IF (VT(2).GT.XMAXM) VT(2)=XMAXM 
      FMAX=FUNCT 
      FMIN=FUNCT 
      STEP=VT(2) 
      DO 20 I=1,NVAR 
   20 XPARAM(I)=XPARAM(I)+STEP*PVECT(I) 
      CALL COMPFG(XPARAM,PHI(2),FAIL,GRAD,.FALSE.) 
      IF(FAIL) STOP 
      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, 
     1STEP,ALFS,NVAR) 
      IF (PHI(1).LE.PHI(2)) GO TO 30 
      GO TO 40 
   30 VT(3)=-VT(2) 
      LEFT=3 
      CENTER=1 
      RIGHT=2 
      GO TO 50 
   40 VT(3)=2.0D00*VT(2) 
      LEFT=1 
      CENTER=2 
      RIGHT=3 
   50 STLAST=VT(3) 
      STEP=STLAST-STEP 
      DO 60 I=1,NVAR 
   60 XPARAM(I)=XPARAM(I)+STEP*PVECT(I) 
      CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
      IF(FAIL) STOP 
      IF(FUNCT.GT.FMAX) FMAX=FUNCT 
      IF(FUNCT.LT.FMIN) FMIN=FUNCT 
      IF (FUNCT.LT.SQSTOR) CALL EXCHNG (FUNCT,SQSTOR,ENERGY, 
     1ESTOR,XPARAM,XSTOR,STEP,ALFS,NVAR) 
      IF (FUNCT.LT.FIN) IQUIT=1 
      PHI(3)=FUNCT 
      IF (PRINT)WRITE (IPRT,230) VT(1),PHI(1),VT(2),PHI(2),VT(3),PHI(3) 
      OKC=.TRUE. 
      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-20)THEN 
            ALPHA=-(PHI(1)*ALPHA+PHI(2)*BETA+PHI(3)*GAMMA)/(ALPHA*BETA*G 
     1AMM   A) 
         ELSE 
            GOTO 190 
         ENDIF 
         BETA=((PHI(1)-PHI(2))/GAMMA)-ALPHA*(VT(1)+VT(2)) 
         IF (ALPHA) 70,70,100 
   70    IF (PHI(RIGHT).GT.PHI(LEFT)) GO TO 80 
         STEP=3.0D00*VT(RIGHT)-2.0D00*VT(CENTER) 
         GO TO 90 
   80    STEP=3.0D00*VT(LEFT)-2.0D00*VT(CENTER) 
   90    S=STEP-STLAST 
         IF (ABS(S).GT.XMAXM) S=SIGN(XMAXM,S)*(1+0.01*(XMAXM/S)) 
         STEP=S+STLAST 
         GO TO 110 
  100    STEP=-BETA/(2.0D00*ALPHA) 
         S=STEP-STLAST 
         XXM=2.0D00*XMAXM 
         IF (ABS(S).GT.XXM) S=SIGN(XXM,S)*(1+0.01*(XXM/S)) 
         STEP=S+STLAST 
  110    CONTINUE 
         IF (ICTR.LE.3) GO TO 120 
         AABS=ABS(S*XMINM) 
         IF (AABS.LT.XCRIT) GO TO 190 
  120    CONTINUE 
         DO 130 I=1,NVAR 
  130    XPARAM(I)=XPARAM(I)+S*PVECT(I) 
         FUNOLD=FUNCT 
         CALL COMPFG (XPARAM,FUNCT,FAIL,GRAD,.FALSE.) 
         IF(FAIL) STOP 
         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,STEP,ALFS,NVAR) 
         IF (FUNCT.LT.FIN) IQUIT=1 
         IF (PRINT) WRITE (IPRT,240) VT(LEFT),PHI(LEFT), 
     1                            VT(CENTER),PHI(CENTER), 
     2                            VT(RIGHT),PHI(RIGHT),STEP,FUNCT 
C 
C TEST TO EXIT FROM LINMIN IF NOT DROPPING IN VALUE OF FUNCTION FAST. 
C 
         TINY = MAX((SSQLST-FMIN)*0.2D0 , DROP) 
         TINY = MIN(TINY,0.5D0) 
         IF(PRINT) WRITE(IPRT,'(''  TINY'',F12.6)')TINY 
         IF(ABS(FUNOLD-FUNCT) .LT. TINY .AND. IQUIT .EQ. 1) GOTO 190 
         IF ((ABS(STEP-STLAST).LE.EPS*ABS(STEP+STLAST)+TEE). 
     1   AND.(IQUIT.EQ.1)) GO TO 190 
         STLAST=STEP 
         IF ((STEP.GT.VT(RIGHT)).OR.(STEP.GT.VT(CENTER) 
     1        .AND.FUNCT.LT.PHI(CENTER)).OR.(STEP.GT.VT(LEFT) 
     2        .AND.STEP.LT.VT(CENTER).AND.FUNCT.GT.PHI(CENTER))) 
     3         GOTO 140 
         VT(RIGHT)=STEP 
         PHI(RIGHT)=FUNCT 
         GO TO 150 
  140    VT(LEFT)=STEP 
         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 
      OKC=.FALSE. 
  190 CONTINUE 
      CALL EXCHNG (SQSTOR,FUNCT,ESTOR,ENERGY,XSTOR,XPARAM, 
     1             ALFS,STEP,NVAR) 
      OKF = (FUNCT.LT.SSQLST) 
      IF (FUNCT.GE.SSQLST) RETURN 
      IF (STEP) 200,220,220 
  200 STEP=-STEP 
      DO 210 I=1,NVAR 
  210 PVECT(I)=-PVECT(I) 
  220 CONTINUE 
      RETURN 
C 
  230 FORMAT ( 11H ---QLINMN ,/5X, 'LEFT   ...',2F17.8/5X, 
     1 'CENTER ...',2F17.8/5X, 'RIGHT  ...',2F17.8/) 
  240 FORMAT (5X,'LEFT    ...',2F17.8/5X,'CENTER  ...',2F17.8/5X, 
     1'RIGHT   ...',2F17.8/5X, 'NEW     ...',2F17.8/) 
C 
      END 
      SUBROUTINE LOCAL(C,MDIM,NOCC,EIG) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION C(MDIM,MDIM), EIG(MAXORB) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
C********************************************************************** 
C 
C   LOCALISATION SUBROUTINE 
C ON INPUT 
C        C = EIGENVECTORS IN AN MDIM*MDIM MATRIX 
C        NOCC = NUMBER OF FILLED LEVELS 
C        NORBS = NUMBER OF ORBITALS 
C        NUMAT = NUMBER OF ATOMS 
C        NLAST   = INTEGER ARRAY OF ATOM ORBITAL COUNTERS 
C        NFIRST   = INTEGER ARRAY OF ATOM ORBITAL COUNTERS 
C 
C       SUBROUTINE MAXIMISES )PSI#**4 
C       REFERENCE_ 
C       A NEW RAPID METHOD FOR ORBITAL LOCALISATION, P.G. PERKINS AND 
C       J.J.P. STEWART, J.C.S. FARADAY (II) 77, 000, (1981). 
C 
C       MODIFIED AND CORRECTED TO AVOID SIGMA-PI ORBITAL MIXING BY 
C       JUAN CARLOS PANIAGUA, UNIVERSITY OF BARCELONA, MAY 1983. 
C 
C********************************************************************** 
      COMMON /SCRACH/ COLD(MAXORB,MAXORB),XDUMY(MAXPAR**2-MAXORB*MAXORB) 
      DIMENSION EIG1(MAXORB),PSI1(MAXORB),PSI2(MAXORB), 
     1          CII(MAXORB), REFEIG(MAXORB),IEL(20) 
      CHARACTER*2 ELEMNT(99) 
      DATA ELEMNT/'H','HE', 
     1 'LI','BE','B','C','N','O','F','NE', 
     2 'NA','MG','AL','SI','P','S','CL','AR', 
     3 'K','CA','SC','TI','V','CR','MN','FE','CO','NI','CU', 
     4 'ZN','GA','GE','AS','SE','BR','KR', 
     5 'RB','SR','Y','ZR','NB','MO','TC','RU','RH','PD','AG', 
     6 'CD','IN','SN','SB','TE','I','XE', 
     7 'CS','BA','LA','CE','PR','ND','PM','SM','EU','GD','TB','DY', 
     8 'HO','ER','TM','YB','LU','HF','TA','W','RE','OS','IR','PT', 
     9 'AU','HG','TL','PB','BI','PO','AT','RN', 
     1 'FR','RA','AC','TH','PA','U','NP','PU','AM','CM','BK','CF','XX'/ 
       SAVE
      NITER=100 
      EPS=1.0D-7 
      DO 10 I=1,NORBS 
         REFEIG(I)=EIG(I) 
         DO 10 J=1,NORBS 
   10 COLD(I,J)=C(I,J) 
      ITER=0 
   20 CONTINUE 
      SUM=0.D0 
      ITER=ITER+1 
      DO 90 I=1,NOCC 
         DO 80 J=1,NOCC 
            IF(J.EQ.I) GOTO 80 
            XIJJJ=0.0D0 
            XJIII=0.0D0 
            XIIII=0.0D0 
            XJJJJ=0.0D0 
            XIJIJ=0.0D0 
            XIIJJ=0.0D0 
            DO 30 K=1,NORBS 
               PSI1(K)=C(K,I) 
   30       PSI2(K)=C(K,J) 
C NOW FOLLOWS THE RATE-DETERMINING STEP FOR THE CALCULATION 
            DO 50 K1=1,NUMAT 
               KL=NFIRST(K1) 
               KU=NLAST(K1) 
               DIJ=0.D0 
               DII=0.D0 
               DJJ=0.D0 
               DO 40 K=KL,KU 
                  DIJ=DIJ+PSI1(K)*PSI2(K) 
                  DII=DII+PSI1(K)*PSI1(K) 
                  DJJ=DJJ+PSI2(K)*PSI2(K) 
   40          CONTINUE 
               XIJJJ=XIJJJ+DIJ*DJJ 
               XJIII=XJIII+DIJ*DII 
               XIIII=XIIII+DII*DII 
               XJJJJ=XJJJJ+DJJ*DJJ 
               XIJIJ=XIJIJ+DIJ*DIJ 
               XIIJJ=XIIJJ+DII*DJJ 
   50       CONTINUE 
            AIJ=XIJIJ-(XIIII+XJJJJ-2.0D0*XIIJJ)/4.0D0 
            BIJ=XJIII-XIJJJ 
            CA=SQRT(AIJ*AIJ+BIJ*BIJ) 
            SA=AIJ+CA 
            IF(SA.LT.1.0D-14) GO TO 80 
            SUM=SUM+SA 
            CA=-AIJ/CA 
            CA=(1.0D0+SQRT((1.0D0+CA)/2.0D0))/2.0D0 
            IF((2.0D0*CA-1.0D0)*BIJ.LT.0.0D0)CA=1.0D0-CA 
            SA=SQRT(1.0D0-CA) 
            CA=SQRT(CA) 
            DO 60 K=1,NORBS 
               C(K,I)=CA*PSI1(K)+SA*PSI2(K) 
   60       C(K,J)=-SA*PSI1(K)+CA*PSI2(K) 
   70       FORMAT(2I4,2F10.5) 
   80    CONTINUE 
   90 CONTINUE 
      DO 110 I=1,NOCC 
         DO 110 J=1,NUMAT 
            IL=NFIRST(J) 
            IU=NLAST(J) 
            X=0.0 
            DO 100 K=IL,IU 
  100       X=X+C(K,I)**2 
  110 SUM1=SUM1+X*X 
      IF(SUM.GT.EPS.AND.ITER.LT.NITER) GO TO 20 
      WRITE(6,120)ITER,SUM1 
  120 FORMAT(/10X,'NUMBER OF ITERATIONS =',I4/ 
     110X,'LOCALISATION VALUE =',F14.9,/) 
      WRITE(6,130) 
  130 FORMAT(3X,'NUMBER OF CENTERS',20X,'( COMPOSITION OF ORBITALS)'//) 
      DO 160 I=1,NOCC 
         SUM=0.D0 
         DO 150 J=1,NOCC 
            CO=0.D0 
            DO 140 K=1,NORBS 
  140       CO=CO+COLD(K,J)*C(K,I) 
  150    SUM=SUM+CO*CO*EIG(J) 
  160 EIG1(I)=SUM 
      DO 190 I=1,NOCC 
         X=100.D0 
         DO 170 J=I,NOCC 
            IF (X.LT.EIG1(J))  GOTO  170 
            X=EIG1(J) 
            I1=J 
  170    CONTINUE 
         EIG(I)=EIG1(I1) 
         X=EIG1(I1) 
         EIG1(I1)=EIG1(I) 
         EIG1(I)=X 
         DO 180 J=1,NORBS 
            X=C(J,I1) 
            C(J,I1)=C(J,I) 
  180    C(J,I)=X 
  190 CONTINUE 
      DO 260 I=1,NOCC 
         X=0.D0 
         DO 210 K1=1,NUMAT 
            KL=NFIRST(K1) 
            KU=NLAST(K1) 
            DII=0.D0 
            DO 200 K=KL,KU 
  200       DII=DII+C(K,I)**2 
            X=X+DII*DII 
  210    PSI1(K1)=DII*100.D0 
         X=1/X 
         DO 230 II=1,NUMAT 
            SUM=0.D0 
            DO 220 J=1,NUMAT 
               IF(PSI1(J).LT.SUM) GOTO 220 
               SUM=PSI1(J) 
               K=J 
  220       CONTINUE 
            PSI1(K)=0.D0 
            CII(II)=SUM 
            IEL(II)=K 
            IF(SUM.LT.1.D0) GOTO 240 
  230    CONTINUE 
  240    CONTINUE 
         II=II-1 
         WRITE(6,250)X,(ELEMNT(NAT(IEL(K))),IEL(K),CII(K),K=1,II) 
  250    FORMAT(F10.4,4(5(3X,A2,I3,F6.2),/10X)) 
  260 CONTINUE 
  270 FORMAT(//20X,20H LOCALISED ORBITALS   ,//) 
      WRITE(6,270) 
      CALL MATOUT(C,EIG,NOCC,NORBS,MDIM) 
  280 FORMAT(10F12.6) 
      DO 290 I=1,NOCC 
         EIG(I)=REFEIG(I) 
         DO 290 J=1,NORBS 
  290 C(J,I)=COLD(J,I) 
      RETURN 
      END 
      SUBROUTINE LOCMIN(M,X,N,P,EFS,ITRAP,ESCF) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION X(*), P(*), EFS(*) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,AREA(MAXPAR*(2*MAXPAR+2)) 
     .               ,ALF,SSQ,PN,IDUM(5),NCOUNT,WORK1(3*MAXPAR) 
     .               ,XSTOR(MAXPAR),GSTOR(MAXPAR),PHI(3),VT(3) 
      INTEGER LEFT,RIGHT,CENTER 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST, DEBUG, LOWER, FAIL 
      DATA FIRST /.TRUE./ 
************************************************************************ 
* 
*    LOCMIN IS CALLED BY NLLSQ ONLY. IT IS A LINE-SEARCH PROCEDURE FOR 
*    LOCATING A MINIMUM OF THE GRADIENT NORM OF THE FUNCTION COMPFG. 
*    SEE NLLSQ FOR MORE DETAILS. 
* 
************************************************************************ 
       SAVE
      IF(FIRST) THEN 
         FIRST=.FALSE. 
         XMAXM=1.D9 
C 
C THE ABOVE LINE IS TO TRY TO PREVENT OVERFLOW IN NLLSQ 
C 
         EPS=1.D-5 
         DEBUG=INDEX(KEYWRD,'LOCMIN').NE.0 
         TEE=1.D-2 
         YMAXST=0.005D0 
         XCRIT=0.0002D0 
         MXCNT2=30 
      ENDIF 
      XMAXM=1.D-11 
      DO 10 I=1,N 
   10 XMAXM=MAX(XMAXM,ABS(P(I))) 
      XMINM=XMAXM 
      XMAXM=YMAXST/XMAXM 
      FIN = SSQ 
      LOWER = .FALSE. 
      T=ALF 
      PHI(1) = SSQ 
      VT(1) = 0.0D0 
      VT(2) = T/4.0D0 
      IF(VT(2).GT.XMAXM) VT(2)=XMAXM 
      T = VT(2) 
      CALL SAXPY (N,T,P,1,X,1) 
      CALL COMPFG(X,ESCF,FAIL,EFS,.TRUE.) 
      IF(FAIL) STOP 
      PHI(2)=DOT(EFS,EFS,N) 
      CALL EXCHNG(PHI(2),SQSTOR,ENERGY,ESTOR,X,XSTOR,T,ALFS,N) 
      CALL SCOPY (N,EFS,1,GSTOR,1) 
      IF (PHI(1) .LE. PHI(2)) THEN 
         VT(3) = -VT(2) 
         LEFT = 3 
         CENTER = 1 
         RIGHT = 2 
      ELSE 
         VT(3)=2.0D0*VT(2) 
         LEFT = 1 
         CENTER = 2 
         RIGHT = 3 
      ENDIF 
      TLAST = VT(3) 
      T = TLAST-T 
      CALL SAXPY (N,T,P,1,X,1) 
      FLAST=PHI(2) 
      CALL COMPFG(X,ESCF,FAIL,EFS,.TRUE.) 
      IF(FAIL) STOP 
      F=DOT(EFS,EFS,N) 
      IF(F.LT.SQSTOR) CALL EXCHNG(F,SQSTOR,ENERGY,ESTOR,X, 
     1XSTOR,T,ALFS,N) 
      CALL SCOPY (M,EFS,1,GSTOR,1) 
      IF(F.LT.FIN) LOWER = .TRUE. 
      NCOUNT = NCOUNT+2 
      PHI(3) = F 
      IF (DEBUG.OR.IMP.GT.1) 
     .        WRITE (IPRT,1000) VT(1),PHI(1),VT(2),PHI(2),VT(3),PHI(3) 
      MXCT=MXCNT2 
      DO 500 ICTR=3,MXCT 
         XMAXM=XMAXM*3.D0 
         ALPHA = VT(2) - VT(3) 
         BETA = VT(3) - VT(1) 
         GAMMA = VT(1)-VT(2) 
         IF(ALPHA.EQ.0.D0)ALPHA=1.D-20 
         IF(BETA.EQ.0.D0)BETA=1.D-20 
         IF(GAMMA.EQ.0.D0)GAMMA=1.D-20 
         ABG =-(PHI(1)*ALPHA+PHI(2)*BETA+PHI(3)*GAMMA)/ALPHA 
         ABG=ABG/BETA 
         ABG=ABG/GAMMA 
         ALPHA=ABG 
         BETA = ((PHI(1)-PHI(2))/GAMMA)-ALPHA*(VT(1)+VT(2)) 
         IF (ALPHA.LE.0.D0) THEN 
            IF (PHI(RIGHT) .LE. PHI(LEFT)) THEN 
               T = 3.0D0*VT(RIGHT)-2.0D0*VT(CENTER) 
            ELSE 
               T = 3.0D0*VT(LEFT)-2.0D0*VT(CENTER) 
            ENDIF 
            S=T-TLAST 
            T=S+TLAST 
         ELSE 
            T = -BETA/(2.0D0*ALPHA) 
            S=T-TLAST 
            IF (S) 20,600,30 
   20       AMDIS=VT(LEFT)-TLAST-XMAXM 
            GO TO 40 
   30       AMDIS=VT(RIGHT)-TLAST+XMAXM 
   40       IF(ABS(S).GT.ABS(AMDIS)) S=AMDIS 
            T=S+TLAST 
         ENDIF 
         IF(ICTR.GT.3.AND.ABS(S*XMINM).LT.XCRIT) THEN 
            IF(DEBUG.OR.IMP.GT.2) 
     .      WRITE(IPRT,'('' EXIT DUE TO SMALL PROJECTED STEP'')') 
            GO TO 600 
         ENDIF 
         T=S+TLAST 
         CALL SAXPY (N,S,P,1,X,1) 
         FLAST=F 
         CALL COMPFG(X,ESCF,FAIL,EFS,.TRUE.) 
         IF(FAIL) STOP 
         F=DOT(EFS,EFS,N) 
         IF(F.LT.SQSTOR) CALL EXCHNG(F,SQSTOR,ENERGY,ESTOR,X,XSTOR, 
     1T,ALFS,N) 
         CALL SCOPY (M,EFS,1,GSTOR,1) 
         IF(F.LT.FIN) LOWER = .TRUE. 
         NCOUNT = NCOUNT+1 
         IF (DEBUG.OR.IMP.GT.1) 
     .    WRITE (IPRT,1010) VT(LEFT),PHI(LEFT),VT(CENTER),PHI(CENTER), 
     .  VT(RIGHT),PHI(RIGHT),T,F 
C 
C    TEST FOR EXCITED STATES AND POTHOLES 
C 
         ITRAP=0 
         IF(ABS(VT(CENTER)).GT.1.D-10) GOTO 50 
         IF(ABS(T)/(ABS(VT(LEFT))+1.D-15).GT.0.3333) GOTO 50 
         IF(2.5D0*F-PHI(RIGHT)-PHI(LEFT).LT.0.5D0*PHI(CENTER)) GOTO 50 
C 
C   WE ARE STUCK ON A FALSE MINIMUM 
C 
         ITRAP=1 
         GOTO 600 
  50    CONTINUE 
* 
* NOW FOR THE MAIN STOPPING TESTS.  LOCMIN WILL STOP IF:- 
*     THE ERROR FUNCTION HAS BEEN REDUCED, AND 
*     THE RATE OF DROP OF THE ERROR FUNCTION IS LESS THAN 0.5% PER STEP 
*     AND 
*     (A) THE RATIO OF THE PROPOSED STEP TO THE TOTAL STEP IS LESS THAN 
*         EPS,   OR 
*     (B) THE LAST DROP IN ERROR FUNCTION WAS LESS THAN 5%OFTHETOTALDROP 
*         DURING THIS CALL TO LOCMIN. 
* 
         IF(DEBUG)WRITE(IPRT,'('' F/FLAST'',F13.6)')F/FLAST 
         IF( LOWER  .AND. F/FLAST .GT. 0.995D0) THEN 
            IF((ABS(T-TLAST).LE.EPS*ABS(T+TLAST)+TEE)) THEN 
               IF(DEBUG.OR.IMP.GT.1) 
     1       WRITE(IPRT,'('' EXIT AS STEP IS ABSOLUTELY SMALL '')') 
               GO TO 600 
            ENDIF 
            SUM=MIN(ABS(F-PHI(1)),ABS(F-PHI(2)),ABS(F-PHI(3))) 
            SUM2=(FIN-SQSTOR)*0.05D0 
            IF(SUM .LT. SUM2) THEN 
               IF(DEBUG.OR.IMP.GT.1) 
     1        WRITE(IPRT,'('' EXIT DUE TO HAVING REACHED BOTTOM'')') 
               GOTO 600 
            ENDIF 
         ENDIF 
         TLAST = T 
         IF ((T .GT. VT(RIGHT)) .OR. (T .GT. VT(CENTER) .AND. F .LT. 
     1  PHI(CENTER)) .OR. (T .GT. VT(LEFT) .AND. T .LT. VT(CENTER) .AND. 
     2  F .GT. PHI(CENTER))) THEN 
            VT (LEFT) =T 
            PHI(LEFT) =F 
         ELSE 
            VT (RIGHT)=T 
            PHI(RIGHT)=F 
         ENDIF 
         IF (VT(CENTER) .GE. VT(RIGHT)) THEN 
            I = CENTER 
            CENTER = RIGHT 
            RIGHT = I 
         ENDIF 
         IF (VT(LEFT ) .GE. VT(CENTER)) THEN 
            I = LEFT 
            LEFT = CENTER 
            CENTER = I 
         ENDIF 
         IF (VT(CENTER) .GE. VT(RIGHT)) THEN 
            I = CENTER 
            CENTER = RIGHT 
            RIGHT = I 
         ENDIF 
  500 CONTINUE 
C 
  600 CALL EXCHNG(SQSTOR,F,ESTOR,ENERGY,XSTOR,X,ALFS,T,N) 
      CALL SCOPY (M,GSTOR,1,EFS,1) 
      SSQ=(F) 
      ALF=T 
      IF (T.LT.0.D0) THEN 
         T = -T 
         DO 610 I=1,N 
  610    P(I) = -P(I) 
      ENDIF 
      ALF=T 
      RETURN 
 1000 FORMAT(' ---LOCMIN'/5X,'LEFT   ...',2F19.6/5X,'CENTER ...', 
     1  2F19.6/5X,'RIGHT  ...',2F19.6/' ') 
 1010 FORMAT(5X,'LEFT   ...',2F19.6/5X,'CENTER ...',2F19.6/5X, 
     1  'RIGHT  ...',2F19.6/5X,'NEW    ...',2F19.6/' ') 
      END 
      SUBROUTINE LTRD(IND,X,F,G,N) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C-------------------- 
C     MAIN ROUTINE FOR OPTIMIZATION BY NEWTON-LIKE METHOD : 
C      - MINIMIZATION OF THE ENERGY         IND=1 ==>(IND=5 OR 7) 
C                OR 
C      - MINIMIZATION OF THE GRADIENT NORM  IND=2 ==>(IND=6 OR 8) . 
C------------ 
C     THE HESSIAN IS CALCULATED BY AN USUAL FINITE DIFFERENCE FORMULA 
C     ACCORDING TO THE NATURE OF THE GRADIENT AND IOPT OPTION : 
C      - NUMERICAL DERIVATION OF AN ANALYTICAL GRADIENT IF IND =5,6 
C                OR 
C      - DIRECT USE OF THE ENERGY IF IND =7,8 . 
C                         IN EACH CASE ... 
C     THE LENGTH OF THE INCREMENT IS UPDATED TO INSURE A GIVEN PRECISION 
C                ON DIAGONAL ELEMENTS OF THE HESSIAN, 
C     AND A STATISTICAL ERROR ON THE EIGENVALUES IS PROVIDED. 
C------------ 
C     THE ONE-DIMENSIONAL DIRECTION OF OPTIMISATION IS SELECTED 
C     AMONG THE FOLLOWING POSSIBILITIES : 
C      - STEEPEST DESCENT ( INSURING STABILITY ) 
C      - FULL NEWTON      ( INSURING QUADRATIC TERMINATION ) 
C      - EIGENVECTOR ASSOCIATED TO A NEGATIVE EIGENVALUE 
C                         ( INSURING STABILITY NEAR AN INFLEXION ) 
C------------ 
C     THE ONE-DIMENSIONAL OPTIMISATION PROCEEDES BY UP TO 3 DEGREE 
C     POLYNOMIAL EXTRAPOLATION AND TRY TO AVOID SOME USUAL PITFALL 
C     OF MOST SIMILAR PROCEDURE... 
C--------------------- 
C     REQUIRED SUBROUTINES : 
C        LDATA  : GENERAL OPTIONS 
C        POINT1 : HESSIAN MATRIX (ANALYTICAL-NUMERICAL) 
C        POINT3 : HESSIAN MATRIX (NUMERICAL -NUMERICAL) 
C        FINDS  : SELECT THE OPTIMISATION DIRECTION S 
C        STAT   : MAIN SUBROUTINE FOR OPTIMISATION IN S DIRECTION 
C        STAT1,SELECT,STATUS : MONODIMENSIONAL OPTIMISATION 
C        DOT,SUPDOT,DIAGIV,CARDAN : MATHEMATICAL PACKAGE 
C        COMPFG : ENERGY AND GRADIENT 
C        SAVOPT : SAVE/RESTART ROUTINE 
C---------------------- 
C        THE COMMON/OPTIM/        INCLUDES THE WHOLE DATA REQUIRED, 
C                  /PRECI/ PROVIDES THE ESTIMATED ERRORS ON 
C        THE ENERGY (SCFCV) , THE GRADIENT COMPONENTS (EG(3)) , 
C        AN ESTIMATE OF THE DIAGONAL CURVATURES (ESTIM(3)) , 
C        THE MAXIMUM STEP LENGTH ARE DEFINED HERE. 
C        THE SUBROUTINE COMPFG MUST RETURN ALSO THE FLAG "FAIL" : 
C                 FAIL = .T.  : SCF CONVERGED 
C                      = .F.    OTHERWISE. 
C        NOTE...THIS STRUCTURE ALLOWS TO OVERLAY THIS BRANCH (LDATA, 
C        POINT1&3,FINDS,STAT1,SELECT,STATUS,DOT,SUPDOT,DIAGIV,CARDAN) 
C        WITH THE ENERGY AND GRADIENT SECTION (COMPFG). 
C        MOREOVER,ONLY THIS SUBROUTINE MUST BE MODIFIED FOR 
C        IMPLEMENTATION IN ANOTHER PACKAGE. 
C---------------------- 
C        LABORATOIRE DE CHIMIE STRUCTURALE 
C                    FACULTE DES SCIENCES 
C                    AVENUE DE L'UNIVERSITE 
C                                              PAU (64000)-FRANCE- 
C        REFERENCE : D.LIOTARD THESIS PAU (1979) 
C 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .               ,P(MAXPAR*MAXPAR),STEP(MAXPAR),SEUIL(2) 
     .               ,ESTIM2(3),PMIN(3),PMAX2(3),EG2(3),EPS1,ERROR 
     .               ,SAVE1,SAVE2,FCUR1,FCUR2 
     .               ,I1,I2,IROUTE,ITYP,ICURV,IOPT,NOPT,LFINAL,LBIS(2) 
     .               ,SAV1(MAXPAR,2),SAV2(3),ISAVE,ISAV2 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     .               ,NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA 
     .               ,NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /DENSTY/ PT(MPACK),PA(MPACK),PB(MPACK) 
      COMMON /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
      COMMON /MESAGE/ IFLEPO 
      COMMON /SCFOK / FAIL 
      COMMON /TIME  / TIME0 
      COMMON /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
      DIMENSION PREF(MPACK),PREFA(MPACK),PREFB(MPACK) 
      DIMENSION X(1),G(1),S(1) 
      EQUIVALENCE (S(1),HNEW(1)) 
      LOGICAL FAIL,LFINAL,REST,UHF 
       SAVE
C     ... 
C     BEGIN INITIALIZATION 
C     ... 
      LINEAR=NORBS*(NORBS+1)/2 
      UHF=NALPHA.NE.0 
      FAIL=.FALSE. 
      TLEFT=3600. 
      I=INDEX(KEYWRD,' T=') 
      IF(I.NE.0) TLEFT=READA(KEYWRD,I) 
      IND=IND+4 
      IF(INDEX(KEYWRD,'DERINU') .NE. 0 ) IND=IND+2 
      IOPT=1 
      EPS=1.D0 
      LIMIT=5 
      IF(INDEX(KEYWRD,'PRECI') .NE. 0) THEN 
         IOPT=2 
         EPS=EPS*0.1D0 
         LIMIT=LIMIT*3 
      ENDIF 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF(IMP.NE.0)IMP=READA(KEYWRD,IMP) 
      I=INDEX(KEYWRD,'CYCLES=') 
      IF(I.NE.0) LIMIT=READA(KEYWRD,I) 
      I=INDEX(KEYWRD,'GNORM=') 
      IF(I.NE.0) EPS=ABS(READA(KEYWRD,I)) 
      REST=INDEX(KEYWRD,'REST').NE.0 
C     FOR SAVE/RESTART : EQUIVALENCED /OPTIM/ I1(MAXPAR,LEN1),I2(LEN2) 
      LEN1=2*(MAXPAR+4) 
      LEN2=2*(MAXHES+23) + 16 
C     ... 
C     COMPLETE INITIALIZATION, OR RESTART 
C     ... 
      IF ( REST ) THEN 
         CALL SAVOPT(LEN1,LEN2,.TRUE.) 
         CALL SCOPY (N,SAV1(1,1),1,X,1) 
         CALL SCOPY (N,SAV1(1,2),1,G,1) 
         F=     SAV2(1) 
         SCFCV= SAV2(2) 
         SCFTOL=SAV2(3) 
         ITERAT=ISAV2 
         READ (10) (PREFA(I),I=1,LINEAR) 
         IF (UHF) READ (10) (PREFB(I),I=1,LINEAR) 
         REWIND 10 
         IF (UHF) THEN 
            DO 2 I=1,LINEAR 
    2       PREF(I)=PREFA(I)+PREFB(I) 
            ELSE 
            DO 3 I=1,LINEAR 
    3       PREF(I)=PREFA(I)*2.D0 
         ENDIF 
      ELSE IF (MAXPAR.LT.20) THEN 
              WRITE(IPRT,130) 
              STOP 
           ELSE 
              CALL COMPFG (X,F,FAIL,GNEW,.TRUE.) 
              PMAX2(1)=0.015D0 
              PMIN (1)=0.001D0 
              PMAX2(2)=0.045D0 
              PMIN (2)=0.01D0 
              PMAX2(3)=0.061D0 
              PMIN (3)=0.01D0 
              DO 4 I=1,3 
              EG2(I)=EG(I) 
    4         ESTIM2(I)=ESTIM(I)*0.5D0 
              CALL LDATA (NOPT,IOPT,ITERAT,N,LIMIT,EPS,IND) 
              IFLEPO=13 
              AK=0.D0 
              ITERAT=0 
      ENDIF 
C     ... 
C     BEGINNING OF ITERATIVE LOOP 
C     ... 
      IF ( REST ) GO TO (21,32,34,41),ISAVE 
   10 ITERAT=ITERAT+1 
      IF(FAIL) GO TO 50 
      CALL SCOPY (LINEAR,PT,1,PREF,1) 
      CALL SCOPY (LINEAR,PA,1,PREFA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PB,1,PREFB,1) 
C     ... 
C     NEW HESSIAN EVALUATION 
C     ---------------------- 
      IF(IND.GT.6) GO TO 30 
C 
C     ANALYTICAL- NUMERICAL METHODS 
      CALL POINT1(P,X,F,N,EPS,ITERAT,LIMIT,G) 
   20 CALL SECOND (TFLY) 
      IF(0.9D0*TLEFT.LT.(TFLY-TIME0)) THEN 
         ISAVE=1 
         GO TO 70 
      ENDIF 
      CALL SCOPY (LINEAR,PREF,1,PT,1) 
      CALL SCOPY (LINEAR,PREFA,1,PA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
   21 CALL COMPFG (X,FCUR1,FAIL,G,.TRUE.) 
      IF(FAIL) GO TO 61 
      IF (IOPT .EQ.2) THEN 
         X(I1)=SAVE1-STEP(I1) 
         LCI=N*(I1-1)+1 
         CALL SCOPY (LINEAR,PREF,1,PT,1) 
         CALL SCOPY (LINEAR,PREFA,1,PA,1) 
         IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
         CALL COMPFG(X,FCUR2,FAIL,P(LCI),.TRUE.) 
         IF(FAIL) GO TO 62 
      ENDIF 
      CALL POINT2(P,X,F,N,EPS,ITERAT,LIMIT,G) 
      GO TO (20,40),IROUTE 
      GO TO 60 
C 
C     TWICE NUMERICAL METHODS 
   30 CALL POINT3(P,X,F,N,EPS,ITERAT,LIMIT,G) 
   31 X(I1)=SAVE1+STEP(I1) 
      CALL SECOND (TFLY) 
      IF (0.99D0*TLEFT.LT.TFLY-TIME0) THEN 
         ISAVE=2 
         GO TO 70 
      ENDIF 
      CALL SCOPY (LINEAR,PREF,1,PT,1) 
      CALL SCOPY (LINEAR,PREFA,1,PA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
   32 CALL COMPFG (X,FCUR1,FAIL,G,.FALSE.) 
      IF(FAIL) GO TO 64 
      X(I1)=SAVE1-STEP(I1) 
      CALL SCOPY (LINEAR,PREF,1,PT,1) 
      CALL SCOPY (LINEAR,PREFA,1,PA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
      CALL COMPFG (X,FCUR2,FAIL,G,.FALSE.) 
      IF(FAIL) GO TO 65 
      CALL POINT4(P,X,F,N,EPS,ITERAT,LIMIT,G) 
      GO TO (31,33,40) IROUTE 
      GO TO 60 
   33 X(I1)=SAVE1+STEP(I1) 
      X(I2)=SAVE2+STEP(I2) 
      CALL SECOND (TFLY) 
      IF (TLEFT.LT.TFLY-TIME0) THEN 
         ISAVE=3 
         GO TO 70 
      ENDIF 
      CALL SCOPY (LINEAR,PREF,1,PT,1) 
      CALL SCOPY (LINEAR,PREFA,1,PA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
   34 CALL COMPFG(X,FCUR1,FAIL,G,.FALSE.) 
      IF (FAIL) GO TO 64 
      IF(IOPT.EQ.2) THEN 
         X(I1)=SAVE1-STEP(I1) 
         X(I2)=SAVE2-STEP(I2) 
         CALL SCOPY  (LINEAR,PREF,1,PT,1) 
         CALL SCOPY  (LINEAR,PREFA,1,PA,1) 
         IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
         CALL COMPFG (X,FCUR2,FAIL,G,.FALSE.) 
         IF (FAIL) GO TO 65 
      ENDIF 
      CALL POINT5(P,X,F,N,EPS,ITERAT,LIMIT,G) 
      GO TO (31,33,40),IROUTE 
      GO TO 60 
C     ... 
C     CONVERGENCE : ITERAT.GE.LIMIT  OR  RMS GRADIENT OK 
C     -------------------------------------------------- 
   40 RMS=SQRT(DOT(GNEW,GNEW,N)/FLOAT(N)) 
      IF(ITERAT.GE.LIMIT.OR.RMS.LT.EPS) GO TO 50 
C     ... 
C     SELECT THE 1-D DIRECTION OF OPTIMIZATION 
C     ---------------------------------------- 
      CALL SECOND (TFLY) 
      IF (0.8D0*TLEFT.LT.TFLY-TIME0) THEN 
         ISAVE=4 
         GO TO 70 
      ENDIF 
   41 CALL FINDS (P,X,F,N,ICURV,G,NOPT,AK) 
C     ... 
C     1-D OPTIMIZATION (ON ENERGY OR GRADIENT NORM) 
C     --------------------------------------------- 
      CALL STAT(AK,N,X,F,EPS) 
      GO TO 10 
C     ... 
C     END OF ITERATIVE LOOP 
C     ... 
   50 IMP=IMP0 
C     RESTORE THE BEST GEOMETRY AND RELATED DATA EVERYWHERE 
      CALL COMPFG (X,F,FAIL,G,.FALSE.) 
      CALL SCOPY (N,GNEW,1,G,1) 
      IF(RMS.GT.EPS) THEN 
C        OPTIMIZATION NOT COMPLETED. 
         IND=1 
         IFLEPO=12 
      ELSE 
C        OPTIMIZATION COMPLETED. 
         IF(MOD(IND,2).EQ.0)THEN 
            IFLEPO=11 
         ELSE 
            IFLEPO=10 
         ENDIF 
         IND=0 
C        BACK TRANSFORM THE HESSIAN ONTO CARTESIAN COORDINATES, 
C        AND COMPUTE CONTRIBUTIONS TO ZERO POINT ENERGY, IF POSSIBLE. 
         CALL ZPE 
      ENDIF 
      RETURN 
C     ... 
C     ERRORS SECTION 
C     ... 
   60 WRITE (IPRT,120) IROUTE 
      FAIL=.TRUE. 
      GO TO 50 
   61 INTNL=1 
      GO TO 63 
   62 INTNL=2 
   63 WRITE(IPRT,100) INTNL,I1,STEP(I1) 
      RETURN 
   64 INTNL=1 
      GO TO 66 
   65 INTNL=2 
   66 WRITE(IPRT,110) INTNL,I1,I2,STEP(I1),STEP(I2) 
      RETURN 
C     ... 
C     SAVE SECTION 
C     ... 
   70 CALL SCOPY (N,X,1,SAV1(1,1),1) 
      CALL SCOPY (N,G,1,SAV1(1,2),1) 
      SAV2(1)=F 
      SAV2(2)=SCFCV 
      SAV2(3)=SCFTOL 
      ISAV2=ITERAT 
      CALL SCOPY (LINEAR,PREFA,1,PA,1) 
      IF (UHF) CALL SCOPY (LINEAR,PREFB,1,PB,1) 
      CALL SAVOPT (LEN1,LEN2,.FALSE.) 
  100 FORMAT(' AT POINT',I2,' OF HESSIAN ROW',I3,' WITH STEP',1PD8.1) 
  110 FORMAT(' AT POINT',I2,5X,2I4,' OF HESSIAN WITH STEPS',1P,2D8.1) 
  120 FORMAT(' ABNORMAL VALUE OF IROUTE =',I5,' IN LTRD . STOP') 
  130 FORMAT(' THE ORGANIZATION OF THE COMMON /OPTIM/ IN ''LTRD'' NEEDS 
     .THE VALUE OF'/' THE PARAMETER ''MAXPAR'' TO EXCEED 19. SORRY]') 
      END 
      SUBROUTINE LDATA(NOPT,IOPT,ITERAT,N,LIMIT,EPS,IND) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,P(MAXPAR*MAXPAR),STEP(MAXPAR),SEUIL(2) 
     .              ,ESTIM(3),PMIN(3),PMAX(3),EG(3) 
      COMMON /PRECI/ SCFCV,SCFTOL,EGDUM(9),KTYP(MAXPAR) 
      DIMENSION PAS(3),DERI(2),DERIV(2) 
C     REFERENCE RELATIVE ERROR ON HESSIAN DIAGONAL ELEMENTS 
C               ACCORDING TO IOPT OPTION : 
      DATA REL1,REL2 
     1/1.D-1,1.D-2/ 
      DATA DERI /8H ONESTEP ,8H TWOSTEP /,DERIV /8HANAL-NUM,8HNUM-NUM / 
       SAVE
C 
      SEUIL(1)=REL1 
      SEUIL(2)=REL2 
C 
C     ESTABLISH REFERENCE STEPS FOR HESSIAN MATRIX EVALUATION 
C     EG      : ESTIMATE OF ABSOLUTE ERROR ON GRADIENT COMPONENTS 
C     ESTIM   : ESTIMATE OF HESSIAN DIAGONAL ELEMENTS 
C               (USUAL ORDER OF MAGNITUDE) 
C     REL1,2  : WISHED RELATIVE ERROR ACCORDING TO IOPT OPTION 
C     PMAX    : MAXIMUM ALLOWED INCREMENT LENGTH IN ALL CASE 
      GO TO (10,15),IOPT 
   10 IF (IND.EQ.7) GO TO 12 
      DO 11 I=1,3 
   11 PAS(I)=MIN(PMAX(I),MAX(PMIN(I),3.D0*(EG(I)+SQRT( 
     . EG(I)**2+0.67D0*REL1*SCFCV*ESTIM(I)))/(REL1*ESTIM(I)))) 
      GO TO 20 
   12 DO 13 I=1,3 
   13 PAS(I)=MIN(PMAX(I),MAX(PMIN(I),SQRT(SCFCV*2.D0/(REL1*ESTIM(I))))) 
      GO TO 20 
   15 DO 16 I=1,3 
      PMAX(I)=1.4D0*PMAX(I) 
   16 PAS(I)=MIN(PMAX(I),MAX(PMIN(I),EG(I)/(ESTIM(I)*REL2))) 
C     COMPLETE INITIALIZATION 
   20 DER=DERIV(1) 
      IF(IND.GT.6) DER=DERIV(2) 
      EPSMAX=0.D0 
      DO 21 I=1,N 
      STEP(I)=PAS(KTYP(I)) 
   21 EPSMAX=EPSMAX+EG(KTYP(I))**2 
      EPS=MAX(EPS,5.D0*SQRT(EPSMAX/FLOAT(N))) 
      IF (IND.EQ.5.OR.IND.EQ.7) GO TO 22 
      NOPT=11 
      WRITE(IPRT,101) N,LIMIT,DERI(IOPT),DER,EPS 
      WRITE(IPRT,104) SCFCV,EG,PMAX,PMIN 
      RETURN 
   22 WRITE(IPRT,102) N,LIMIT,DERI(IOPT),DER,EPS 
      WRITE(IPRT,104) SCFCV,EG,PMAX,PMIN 
      NOPT=2 
      RETURN 
  101 FORMAT(//' CRITICAL POINT RESEARCH IN',I3,' VARIABLES', 
     . 2X,'ITE MAX:',I4/ 
     .' SECOND DERIVATIVES BY THE',A8,' METHOD  (',A8,')'/ 
     .' REQUIRED CONVERGENCE ON RMS GRADIENT',1PD9.1) 
  102 FORMAT(//' MINIMIZATION IN',I3,' VARIABLES', 
     . 2X,'ITE MAX:',I4/ 
     .' SECOND DERIVATIVES BY THE',A8,' METHOD  (',A8,')'/ 
     .' REQUIRED CONVERGENCE ON RMS GRADIENT',1PD9.1) 
  104 FORMAT(' ERROR ON ENERGY     :',1P,D10.2/7X,'ON DERIVATIVES:', 
     . 3D10.2/' LARGEST ALLOWED STEP:',0P,3F10.6 
     . /' LOWEST  ALLOWED STEP:',3F10.6) 
      END 
      SUBROUTINE POINT1(P,XNEW,FNEW,N,EPS,ITERAT,LIMIT,GRAD) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C     ----- ANALYTICAL-NUMERICAL METHODS ----- 
C     ENERGY,GRADIENT AND SECOND DERIVATIVES AT CURRENT POINT XNEW , 
C     CONVERGENCE ON RMS GRADIENT : SQRT(<G!G>/N), 
C     LOCAL CURVATURE INFORMATION . 
C     S DIRECTION BY SECOND ORDER METHODS (MINIMUM OR STAT. POINT) , 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,PDUM(MAXPAR*MAXPAR),STEP(MAXPAR),SEUIL(2) 
     .              ,ESTIM(3),PMIN(3),PMAX(3),EG(3) 
     .              ,EPS1,ERROR,SAVE,SAVE2,FCUR,FCUR2 
     .              ,M,M2,IROUTE,ITYP,ICURV,IOPT,NOPT,LFINAL,LBIS(2) 
     .              ,V(MAXHES),VEIG(MAXPAR),STI(MAXPAR),STIEG(MAXPAR) 
      COMMON /PRECI/ SCFCV,SCFTOL,EGDUM(9),KTYP(MAXPAR) 
      COMMON /TIME / TIME0 
      DIMENSION XNEW(N),GRAD(N),P(N,N) 
      LOGICAL LFINAL,BIS 
      EQUIVALENCE (LBIS(1),BIS) 
       SAVE
C     T       : MINIMUM ALLOWED STEP 
C     X       : MAXIMUM ALLOWED STEP 
C     Y       : PREVIOUS STEP 
C     Z       : RELATIVE ERROR (OBSERVED) 
C     ZREF    : ZREF RELATIVE ERROR (WISHED) 
C     STEP CORRECTION FOR HESSIAN MATRIX EVALUATION ... 
      ADJUST(T,X,Y,Z,ZREF)=MAX(T,MIN(X,Y*MAX(0.20D0,1.2D0*Z/ZREF))) 
C 
C     ... 
C     ENERGY AND GRADIENT AT NEW CURRENT POINT XNEW 
C     ... 
      GG=DOT(GNEW,GNEW,N) 
      RMS=SQRT(GG/FLOAT(N)) 
      LFINAL=ITERAT.GE.LIMIT .OR. RMS.LT.EPS 
      IF(LFINAL) IMP=MAX0(IMP,3) 
      IF(IMP.GT.0) THEN 
         CALL SECOND (TFLY) 
         WRITE(IPRT,109) ITERAT,TFLY-TIME0 
         WRITE(IPRT,104) FNEW,GG,RMS,(GNEW(I),I=1,N) 
         WRITE(IPRT,100) XNEW 
      ENDIF 
C     ... 
C     SECOND DERIVATIVES (CORDE OR SECANT METHOD) 
C     ... 
      BIS=.FALSE. 
    1 ERROR=0.D0 
      IROUTE=1 
      M=0 
   10 M=M+1 
      IF(M.GT.N) GO TO 30 
      ITYP=KTYP(M) 
      SAVE=XNEW(M) 
   11 XNEW(M)=SAVE+STEP(M) 
      RETURN 
C     ( EVALUATION OF ENERGY AND GRADIENT AT POINT SAVE+STEP IF IOPT=1 
C        AND POINT SAVE-STEP IF IOPT=2 ) 
      ENTRY POINT2(P,XNEW,FNEW,N,EPS,ITERAT,LIMIT,GRAD) 
      IF(IOPT.EQ.2) THEN 
C        2-POINTS METHOD 
         DO 20 K=1,N 
   20    P(K,M)=(GRAD(K)-P(K,M))/(2.D0*STEP(M)) 
         SAUF=DABS(P(M,M)) 
         IF(SAUF.LT.5.D-2*ESTIM(ITYP)) GO TO 22 
         SAUF=EG(ITYP)/(STEP(M)*SAUF) 
         PAS=STEP(M) 
         IF(.NOT.BIS.AND.(SAUF.LT.0.1D0*SEUIL(2).OR.SAUF.GT.SEUIL(2))) 
     .   STEP(M)=ADJUST(PMIN(ITYP),STEP(M),PMAX(ITYP),SAUF,SEUIL(2)) 
      ELSE 
C        1-POINT METHOD 
         DO 21 K=1,N 
   21    P(K,M)=(GRAD(K)-GNEW(K))/STEP(M) 
         P(M,M)=-2.D0*(P(M,M)+3.D0*(GNEW(M)*STEP(M)+(FNEW-FCUR)) / 
     .                (STEP(M)**2)   ) 
         PDIAG=DABS(P(M,M)) 
         IF(PDIAG.LT.5.D-2*ESTIM(ITYP)) GO TO 22 
         SAUF=6.D0*(EG(ITYP)*STEP(M)+SCFCV)/(PDIAG*STEP(M)**2) 
         PAS=STEP(M) 
         IF(.NOT.BIS.AND.(SAUF.LT.0.1D0*SEUIL(1).OR.SAUF.GT.SEUIL(1))) 
     .      THEN 
            STEP(M)=3.D0*(EG(ITYP)+SQRT(EG(ITYP)**2+0.55D0*SEUIL(1) 
     .                 *SCFCV*PDIAG))/(0.8D0*SEUIL(1)*PDIAG) 
            STEP(M)=MAX(PMIN(ITYP),0.2D0*PAS,MIN(PMAX(ITYP),STEP(M))) 
         ENDIF 
      ENDIF 
C     HESSIAN STEP ADJUSTEMENT TO INSURE RELATIVE ERROR ON DIAGONAL 
      IF(PAS.NE.STEP(M)) GO TO 11 
      ERROR=MAX(ERROR,SAUF) 
   22 XNEW(M)=SAVE 
      GO TO 10 
   30 IF (N.GT.1) THEN 
C        PREPARE ERRORS COMPUTATION AND SYMMETRISE THE HESSIAN 
         DO 31 I=1,N 
         J=KTYP(I) 
   31    STIEG(I)=EG(J) 
         DO 32 I=1,N 
         STI(I)=STEP(I)**IOPT 
   32    STIEG(I)=STIEG(I)*STI(I) 
         DO 33 I=2,N 
         STII=STI(I) 
         I1=I-1 
CDIR$ IVDEP 
         DO 33 J=1,I1 
         STIJ=STII+STI(J) 
         P(J,I)=(P(I,J)*STII+P(J,I)*STI(J))/STIJ 
   33    P(I,J)=P(J,I) 
      ENDIF 
C     SAVE HESSIAN BEFORE DESTROYED BY DIAGONALIZATION ROUTINE 
      KI=0 
      DO 34 I=1,N 
      DO 34 J=1,I 
      KI=KI+1 
   34 HNEW(KI)=P(J,I) 
      IROUTE=2 
C     ... 
C     LOCAL CURVATURE INFORMATION 
C     ... 
C     DIAGONALIZE THE HESSIAN 
   40 CALL DIAGIV(P,N,N,GRAD,EPS1) 
C     COMPUTE THE INDEX (NUMBER OF NEGATIVE EIGENVALUES) 
      ICURV=0 
      DO 41 I=1,N 
      IF (GRAD(I).LE.-EPS1) ICURV=ICURV+1 
   41 CONTINUE 
   42 JCURV=MIN0(N,ICURV+1) 
      IF (ITERAT.GE.LIMIT) JCURV=N 
      IF(IMP.GT.0) THEN 
C        ... 
C        PRINTOUT ( PART 1/3 ) 
C        ... 
         WRITE(IPRT,102) ERROR 
         WRITE(IPRT,111) ICURV,EPS1,(GRAD(I),I=1,JCURV) 
      ENDIF 
C     ... 
C     STANDARD DEVIATION ON EIGENVALUES DUE TO GRADIENT ERRORS 
C     ... 
      DENER=SCFCV*FLOAT(2-IOPT) 
      FACTOR=1.D0 
      IF (IOPT.EQ.1) FACTOR=3.D0 
      DO 44 I=1,N 
   44 VEIG(I)=FACTOR*(STIEG(I)+DENER/STEP(I))/STEP(I) 
      V(1)=VEIG(1) 
      FACTOR=FLOAT(3-IOPT)*2.D0 
      IF (N.GT.1) THEN 
         K=1 
         DO 46 I=2,N 
         STIEGI=STIEG(I) 
         STPI=STEP(I) 
         STII=STI(I) 
         I1=I-1 
         DO 45 J=1,I1 
         K=K+1 
   45    V(K)=(STIEGI/STEP(J)+STIEG(J)/STPI)/(STII+STI(J)) 
         K=K+1 
   46    V(K)=VEIG(I) 
      ENDIF 
      DO 47 I=1,N 
   47 VEIG(I)=0.D0 
      K=0 
      DO 48 I=1,N 
      DO 48 J=1,I 
      K=K+1 
      VK2=V(K)*V(K) 
      DO 48 L=1,N 
   48 VEIG(L)=VEIG(L)+VK2*(P(I,L)*P(J,L))**2 
CDIR$ IVDEP 
      DO 49 L=1,N 
      VEIG(L)=FACTOR*SQRT(VEIG(L)) 
   49 V(L)=VEIG(L)/(DABS(GRAD(L))+EPS1) 
C     PRINTOUT ( PART 2/3 ) 
      IF(IMP.GT.0) WRITE(IPRT,112) (VEIG(L),L=1,JCURV) 
C     ... 
C     PREPARE LARGER STEPS IF POOR ACCURACY ON EIGENVALUES 
C     ... 
      SAUF=0.D0 
      DO 50 I=1,N 
      VEIG(I)=STEP(I) 
   50 SAUF=MAX(SAUF,V(I)) 
      IF(BIS .OR. SAUF.LT.2.5D0*SEUIL(IOPT)) GO TO 60 
      DO 51 I=1,N 
      STEP(I)=MIN(PMAX(KTYP(I)),STEP(I)*SAUF/SEUIL(IOPT)) 
   51 BIS=BIS .OR. STEP(I).GT.VEIG(I) 
C     RESTART IF REQUIRED (LAST ITERATION ONLY) 
      IF(LFINAL.AND.BIS) GO TO 1 
C     ... 
C     PRINTOUT ( PART 3/3 ) 
C     ... 
   60 IF(IMP.LT.2) GO TO 70 
      KI=MIN0(N,4) 
      WRITE(IPRT,101)(I,I=1,KI) 
      KI=0 
      DO 61 I=1,N 
      IK=KI+1 
      KI=KI+I 
   61 WRITE(IPRT,103) I,VEIG(I),(HNEW(J),J=IK,KI) 
      IF(IMP.LT.3) GO TO 70 
      WRITE(IPRT,106) 
      DO 62 I=1,JCURV 
   62 WRITE(IPRT,107) I,(P(J,I),J=1,N) 
C     ... 
   70 RETURN 
C     ... 
  100 FORMAT(' COORD',1P,6D12.4/(6X,6D12.4)) 
  101 FORMAT(/' MATRIX OF SECOND DERIVATIVES'/7X,'STEP',2X, 
     1 4(I6,6X),I6,' .....') 
  102 FORMAT(/' HESSIAN MATRIX : DIAGONAL TERM ERROR <',2PF9.3,' %') 
  103 FORMAT(1X,I3,1PD9.1,5D12.4/(13X,5D12.4)) 
  104 FORMAT(' ENERGY',1PD15.8,5X,'<G!G>',1PD15.8,5X 
     1 ,'RMS GRAD',D13.5/ 
     2 ' GRAD ',6D12.4/(6X,6D12.4)) 
  106 FORMAT(/' AND EIGENVECTORS :') 
  107 FORMAT(1X,I3,1P,7D10.2/(4X,7D10.2)) 
  109 FORMAT('1ITER',I4,5X,'ELAPSED TIME :',F8.2,' SECOND') 
  111 FORMAT(' NUMBER OF NEGATIVES EIGENVALUES',I5, 
     1 ' PRECISION:',1PD10.2/ 
     2 ' FIRST EIGENVALUES :',1P,6D10.2/(8D10.2) ) 
  112 FORMAT(' STANDARD DEVIATION:', 1P,6D10.2/(8D10.2)) 
      END 
      SUBROUTINE POINT3(P,XNEW,FNEW,N,EPS,ITERAT,LIMIT,GRAD) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C     ----- NUMERICAL-NUMERICAL METHODS ----- 
C     ENERGY,GRADIENT AND SECOND DERIVATIVES AT CURRENT POINT XNEW , 
C     CONVERGENCE ON RMS GRADIENT : SQRT(<G!G>/N), 
C     LOCAL CURVATURE INFORMATION . 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,PDUM(MAXPAR*MAXPAR),STEP(MAXPAR),SEUIL(2) 
     .              ,ESTIM(3),PMIN(3),PMAX(3),EG(3) 
     .              ,EPS1,ERROR,SAVE1,SAVE2,FCUR1,FCUR2 
     .              ,M1,M2,IROUTE,ITYP,ICURV,IOPT,NOPT,LFINAL,LBIS(2) 
     .              ,V(MAXPAR),VEIG(MAXPAR) 
      COMMON /TIME / TIME0 
      COMMON /PRECI/ SCFCV,SCFTOL,EGDUM(9),KTYP(MAXPAR) 
      DIMENSION XNEW(N),GRAD(N),P(N,N) 
      LOGICAL LFINAL,BIS 
      EQUIVALENCE (LBIS(1),BIS) 
       SAVE
C     T       : MINIMUM ALLOWED STEP 
C     X       : MAXIMUM ALLOWED STEP 
C     Y       : PREVIOUS STEP 
C     Z       : RELATIVE ERROR (OBSERVED) 
C     ZREF    : RELATIVE ERROR (WISHED) 
C     STEP CORRECTION FOR HESSIAN MATRIX EVALUATION ... 
      ADJUST(T,X,Y,Z,ZREF)= 
     . MAX(T,MIN(X,Y*SQRT(MAX(0.01D0,1.2D0*Z/ZREF)))) 
C 
C     ... 
C     ENERGY AND GRADIENT AT NEW CURRENT POINT XNEW 
C     ... 
      GG=DOT(GNEW,GNEW,N) 
      RMS=SQRT(GG/FLOAT(N)) 
      LFINAL=ITERAT.GE.LIMIT .OR. RMS.LT.EPS 
      IF(LFINAL) IMP=MAX0(IMP,3) 
      IF(IMP.GT.0) THEN 
         CALL SECOND (TFLY) 
         WRITE(IPRT,109) ITERAT,TFLY-TIME0 
         WRITE(IPRT,104) FNEW,GG,RMS,(GNEW(I),I=1,N) 
         WRITE(IPRT,100) XNEW 
      ENDIF 
C     ... 
C     SECOND DERIVATIVES (CORDE OR SECANT METHOD)-DIAGONAL TERMS 
C     ... 
      BIS=.FALSE. 
   10 ERROR=0.D0 
      IROUTE=1 
      M1=0 
   11 M1=M1+1 
      IF(M1.GT.N) GO TO 20 
      ITYP=KTYP(M1) 
      SAVE1=XNEW(M1) 
   12 RETURN 
C     ( EVALUATION OF ENERGY AT POINT SAVE+STEP 
C        AND POINT SAVE-STEP ) 
      ENTRY POINT4(P,XNEW,FNEW,N,EPS,ITERAT,LIMIT,GRAD) 
      P(M1,M1)=(FCUR1+FCUR2-2.D0*FNEW)/STEP(M1)**2 
      SAUF=DABS(P(M1,M1)) 
      IF (SAUF.LT.5.D-2*ESTIM(ITYP)) GO TO 13 
      SAUF=SCFCV*2.D0/(SAUF*STEP(M1)**2) 
C     HESSIAN STEP ADJUSTEMENT TO INSURE RELATIVE ERROR ON DIAGONAL 
      PAS=STEP(M1) 
      IF(.NOT.BIS.AND.(SAUF.LT..1D0*SEUIL(IOPT).OR.SAUF.GT.SEUIL(IOPT))) 
     . STEP(M1)=ADJUST(PMIN(ITYP),PAS,PMAX(ITYP),SAUF,SEUIL(IOPT)) 
      IF(PAS.NE.STEP(M1)) GO TO 12 
      ERROR=MAX(ERROR,SAUF) 
   13 GRAD(M1)=FCUR1 
      XNEW(M1)=SAVE1 
      GO TO 11 
C     ... 
C     OFF-DIAGONAL TERMS (CORDE OR SECANT METHOD) 
C     ... 
   20 IROUTE=2 
      IF(IOPT.EQ.2) THEN 
         DO 21 I=1,N 
   21    GRAD(I)=P(I,I)*STEP(I)**2 
      ENDIF 
      M1=1 
   22 M1=M1+1 
      IF(M1.GT.N) GO TO 30 
      SAVE1=XNEW(M1) 
      M2=0 
   23 M2=M2+1 
      IF(M2.GE.M1) GO TO 24 
      SAVE2=XNEW(M2) 
      RETURN 
C     ( EVALUATION OF ENERGY AT POINT SAVE+STEP AND POINT SAVE-STEP 
C     IF IOPT=2 ) 
      ENTRY POINT5 (P,XNEW,FNEW,N,EPS,ITERAT,LIMIT,GRAD) 
      IF(IOPT.EQ.1) THEN 
         P(M2,M1)=(FCUR1+FNEW-GRAD(M1)-GRAD(M2))/(STEP(M1)*STEP(M2)) 
      ELSE 
         P(M2,M1)=(FCUR1+FCUR2-FNEW*2.D0-GRAD(M1)-GRAD(M2)) 
     .            /(STEP(M1)*STEP(M2)*2.D0) 
      ENDIF 
      XNEW(M2)=SAVE2 
      GO TO 23 
   24 XNEW(M1)=SAVE1 
      GO TO 22 
C     ... 
C     SAVE THE HESSIAN BEFORE DESTROYED BY DIAGONALIZATION ROUTINE 
C     ... 
   30 KI=0 
      DO 31 I=1,N 
CDIR$ IVDEP 
      DO 31 J=1,I 
      KI=KI+1 
      P(I,J)=P(J,I) 
   31 HNEW(KI)=P(J,I) 
      IROUTE=3 
C     ... 
C     LOCAL CURVATURE INFORMATION 
C     ... 
C     DIAGONALIZATION 
      CALL DIAGIV(P,N,N,GRAD,EPS1) 
C     HESSIAN' INDEX (NUMBER OF NEGATIVE EIGENVALUES) 
      ICURV=0 
      DO 32 I=1,N 
      IF (GRAD(I).LT.-EPS1) ICURV=ICURV+1 
   32 CONTINUE 
      JCURV=MIN0(N,ICURV+1) 
      IF (ITERAT.GE.LIMIT) JCURV=N 
      IF(IMP.GT.0) THEN 
C        ... 
C        PRINTOUT ( PART 1/3 ) EIGENVALUES 
C        ... 
         WRITE(IPRT,102) ERROR 
         WRITE(IPRT,111) ICURV,EPS1,(GRAD(I),I=1,JCURV) 
      ENDIF 
C     ... 
C     STANDARD DEVIATION ON EIGENVALUES DUE TO ENERGIES ERRORS 
C     ... 
      DO 41 I=1,N 
      D1=0.D0 
      D2=0.D0 
      D3=0.D0 
      D4=0.D0 
      DO 40 J=1,N 
      SAUF=P(J,I)/STEP(J) 
      SAUF2=SAUF*SAUF 
      D1=D1+SAUF 
      D2=D2+SAUF2 
      D3=D3+SAUF*SAUF2 
   40 D4=D4+SAUF2*SAUF2 
      IF(IOPT.EQ.1) THEN 
         VEIG(I)=D4*4.00D0-D1*D3*4.00D0+D2*D2*2.00D0 
      ELSE 
         VEIG(I)=D4*7.50D0-D1*D3*8.00D0+D2*D2*2.25D0 
      ENDIF 
   41 CONTINUE 
CDIR$ IVDEP 
      DO 42 L=1,N 
      VEIG(L)=SCFCV*SQRT(DABS(VEIG(L))) 
   42 V(L)=VEIG(L)/(DABS(GRAD(L))+EPS1) 
C     PRINTOUT ( PART 2/3 ) STANDARD DEVIATION 
      IF(IMP.GT.0) WRITE(IPRT,112) (VEIG(L),L=1,JCURV) 
C     ... 
C     PREPARE LARGER STEPS IF POOR ACCURACY ON EIGENVALUES 
C     ... 
      SAUF=0.D0 
      DO 43 I=1,N 
      VEIG(I)=STEP(I) 
   43 SAUF=MAX(SAUF,V(I)) 
      IF(BIS .OR. SAUF.LT.2.5D0*SEUIL(IOPT)) GO TO 50 
      DO 44 I=1,N 
      STEP(I)=MIN(PMAX(KTYP(I)),STEP(I)*SQRT(SAUF/SEUIL(IOPT))) 
   44 BIS=BIS .OR. STEP(I).GT.VEIG(I) 
C     RESTART IF REQUIRED (LAST ITERATION ONLY) 
      IF (LFINAL.AND.BIS) GO TO 10 
C     ... 
C     PRINTOUT ( PART 3/3 ) HESSIAN MATRIX AND EIGENVECTORS 
C     ... 
   50 IF(IMP.LT.2) GO TO 60 
      KI=MIN0(N,6) 
      WRITE(IPRT,101)(I,I=1,KI) 
      KI=0 
      DO 51 I=1,N 
      IK=KI+1 
      KI=KI+I 
   51 WRITE(IPRT,103) I,VEIG(I),(HNEW(J),J=IK,KI) 
      IF(IMP.LT.3) GO TO 60 
      WRITE(IPRT,106) 
      DO 52 I=1,JCURV 
   52 WRITE(IPRT,107) I,(P(J,I),J=1,N) 
   60 RETURN 
  100 FORMAT(' COORD',1P,6D12.4/(6X,6D12.4)) 
  101 FORMAT(/' MATRIX OF SECOND DERIVATIVES'/7X,'STEP',2X, 
     * 5(I6,6X),I6,' .....') 
  102 FORMAT(/' HESSIAN MATRIX : DIAGONAL TERM ERROR <',2PF9.3,' %') 
  103 FORMAT(1X,I3,1PD9.1,5D12.4/(13X,5D12.4)) 
  104 FORMAT(' ENERGY',1PD15.8,5X,'<G!G>',1PD15.8,5X 
     1 ,'RMS GRAD',D13.5/ 
     2 ' GRAD ',6D12.4/(6X,6D12.4)) 
  106 FORMAT(/' AND EIGENVECTORS :') 
  107 FORMAT(1X,I3,1P,7D10.2/(4X,7D10.2)) 
  109 FORMAT('1ITER',I4,5X,'ELAPSED TIME :',F8.2,' SECOND') 
  111 FORMAT('NUMBER OF NEGATIVES EIGENVALUES',I5, 
     1 ' PRECISION:',1PD10.2/ 
     2 ' FIRST EIGENVALUES :',1P,6D10.2/(8D10.2) ) 
  112 FORMAT(' STANDARD DEVIATION:', 1P,6D10.2/(8D10.2)) 
      END 
      SUBROUTINE FINDS(P,XNEW,FNEW,N,ICURV,GRAD,NOPT,AK) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     ... 
C     FIND S DIRECTION   GRADIENT OR NEWTON OR EIGENVECTORS 
C                            AND ... 
C     ESTABLISH SECOND ORDER PREVISION AND CONDITIONS : 
C     USUALLY EUCLIDAN GRADIENT NORM DECREASE  (IN FIRST ORDER) ALONG 
C     S DIRECTION FOR A POSITIVE STEP AK. 
C     EXCEPTION : EIGENVECTOR DIRECTION. 
C     ... 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,G(MAXPAR,10),G0(MAXPAR),G1(MAXPAR),G2(MAXPAR) 
     .              ,CURENT(MAXPAR),X(10),EI(10),GGI(10),E(10) 
     .              ,WW(10),GR(5),ER(4),SOL(3),VAL(3),A(3,3) 
     .              ,IPOLYN(10),INFLEX,ISTAT ,NSOL,IMPROV,NPOINT,NPTMAX 
     .              ,IESNO,NOIES,FINAL 
      COMMON /PRECI/ SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
      DIMENSION XNEW(N),GRAD(N),P(N,N),BARAT(3) 
      LOGICAL INFLEX,IMPROV,FINAL 
      DATA BARAT/8HGRADIENT,8HNEWTON  ,8HEIGENVEC/ 
       SAVE
C 
      IF (ICURV.GT.0.AND.NOPT.EQ.2) THEN 
C 
C        SELECT THE HIGHEST NEGATIVE EIGENVECTOR OF THE HESSIAN 
         STII=GRAD(ICURV) 
         DO 10 I=1,N 
   10    GRAD(I)=P(I,ICURV) 
         AK=DOT(GNEW,GRAD,N) 
         IBARAT=3 
         ISTAT=3 
         IF (DABS(STII).LE.AK*AK) THEN 
            AK=-1.D2*SCFCV/AK 
         ELSE 
            AK=-(SQRT(AK*AK-2.D2*SCFCV*STII)-AK)/STII 
         ENDIF 
      ELSE 
         JCURV=MAX0(1,ICURV) 
         IF(MIN(DABS(GRAD(JCURV)),DABS(GRAD(MIN0(N,ICURV+1)))).GT.1.D6 
     .                            *EPS1) GO TO 30 
C 
C        GRADIENT OF THE EUCLIDIAN GRADIENT NORM 
         IBARAT=1 
         ISTAT=2 
         CALL SUPDOT(GRAD,HNEW,GNEW,N,1) 
         AK=DOT(GNEW,GRAD,N)/DOT(GRAD,GRAD,N) 
      ENDIF 
      DO 20 I=1,N 
   20 GRAD(I)=AK*GRAD(I) 
      INFLEX=.TRUE. 
      GO TO 50 
C 
C     FULL NEWTON-RAPHSON 
   30 IBARAT=2 
      CALL INVRT1(P,N,GRAD,EPS1) 
      DO 40 I=1,N 
   40 GRAD(I)=-DOT(GNEW,P(1,I),N) 
      INFLEX=.FALSE. 
      ISTAT=2 
   50 IF(NOPT.EQ.2) THEN 
C        ENERGY MINIMIZATION ONLY  (NOPT=2) : ASSUME A FIRST ORDER 
C        DECREASE OF ENERGY IN POSITIVE STEP DIRECTION 
         ISTAT=3 
         IF(DOT(GRAD,GNEW,N).GT.0.D0) THEN 
            DO 60 I=1,N 
   60       GRAD(I)=-GRAD(I) 
         ENDIF 
      ENDIF 
C 
C     OPTIMAL POSITIVE STEP 
      AK=1.D0 
      IF(IMP.GT.1) WRITE(IPRT,110) BARAT(IBARAT),GRAD 
      DO 70 I=1,N 
      G0(I)=GNEW(I) 
   70 G2(I)=0.D0 
      CALL SUPDOT(G1,HNEW,GRAD,N,1) 
      CALL CARDAN(G0,GRAD,GR,ER,N,SOL,VAL,NSOL,IPOLYN(2)) 
C     0.1 < AK < 2.0 ... FOR SECURITY 
      IF(IBARAT.NE.3) AK=MAX(0.1D0,MIN(SOL(1),2.D0)) 
C 
C     STORE NEW GRADIENT FOR RETURNED VALUE 
      CALL SCOPY (N,GRAD,1,HNEW,1) 
      CALL SCOPY (N,GNEW,1,GRAD,1) 
      RETURN 
C 
  110 FORMAT(/'      SELECTED DIRECTION ( ',A8,'    )',1P,4D10.2 / 
     *      (10D10.2)) 
      END 
      SUBROUTINE STAT(AK,N,XNEW,FNEW,EPS) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C..... 
C     LTRD METHOD      MAIN ROUTINE FOR POLYNOMIAL EXTRAPOLATION, 
C                      MUST NOT BE OVERLAYED WITH 'COMPFG'. 
C..... 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,G(MAXPAR,10),G0(MAXPAR),G1(MAXPAR),G2(MAXPAR) 
     .              ,CURENT(MAXPAR),X(10),EI(10),GGI(10),E(10) 
     .              ,GG(10),GR(5),ER(4),SOL(3),VAL(3),A(3,3) 
     .              ,IPOLYN(10),INFLEX,IROUTE,NSOL,IMPROV,NPOINT,NPTMAX 
     .              ,IESNO,NOIES,FINAL 
      DIMENSION XNEW(1),S(1) 
      EQUIVALENCE(S(1),HNEW(1)) 
      LOGICAL INFLEX,IMPROV,FINAL 
       SAVE
      CALL STAT1 (AK,N,XNEW,FNEW,EPS) 
      IF(FINAL) RETURN 
      CALL COMPFG (CURENT,E(NPOINT),FAIL,G(1,NPOINT),.TRUE.) 
      CALL STAT2 (AK,N,XNEW,FNEW,EPS) 
    1 IF(FINAL) RETURN 
      CALL COMPFG (CURENT,E(NPOINT),FAIL,G(1,NPOINT),.TRUE.) 
      CALL STAT3 (AK,N,XNEW,FNEW,EPS) 
      GO TO 1 
      END 
      SUBROUTINE STAT1(AK,N,XNEW,FNEW,EPS) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     IROUTE = 1 
C     OPTIMAL SEARCH ALONG THE OPTIMIZED S DIRECTION 
C     NEGATIVE STEP ARE NOT ALLOWED 
C 
C     IROUTE = 2 
C     OPTIMAL SEARCH ALONG THE S DIRECTION DEFINED BY NEWTON METHOD 
C     TRY TO AVOID DISAPOINTING STATIONARY POINT 
C     NEGATIVE STEP ARE ALLOWED 
C 
C     IROUTE = 3 
C     OPTIMAL SEARCH ALONG THE S DIRECTION DEFINED BY NEWTON METHOD 
C     ASSUME A BETTER ENERGY ( IT MUST GOES DOWN) 
C     NEGATIVE STEP ARE NOT ALLOWED 
C 
C     UP TO THREE DEGREE POLYNOMIAL INTERPOLATION IN ALL CASES 
C 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,G(MAXPAR,10),G0(MAXPAR),G1(MAXPAR),G2(MAXPAR) 
     .              ,CURENT(MAXPAR),X(10),EI(10),GGI(10),E(10) 
     .              ,GG(10),GR(5),ER(4),SOL(3),VAL(3),A(3,3) 
     .              ,IPOLYN(10),INFLEX,IROUTE,NSOL,IMPROV,NPOINT,NPTMAX 
     .              ,IESNO,NOIES,FINAL,LOWER 
      COMMON/SCFOK/ FAIL 
      DIMENSION XNEW(1),GV(MAXPAR,3),S(1) 
      EQUIVALENCE (GV(1,1),G0(1)) , (S(1),HNEW(1)) 
      LOGICAL INFLEX,IMPROV,FAIL,FINAL,LOWER 
      DATA NO,IES,INT /4H NO ,4H YES,4H ?? / 
       SAVE
C 
      LOWER=.FALSE. 
      FINAL=.FALSE. 
      NPTMAX=MAX0(5,MIN0(N-2,10)) 
C     INITIAL POINT 
      X(1)=0.D0 
      E(1)=FNEW 
      GG(1)=DOT(GNEW,GNEW,N) 
      ER(1)=FNEW 
      CALL SCOPY (N,GNEW,1,G(1,1),1) 
      NOIES=INT 
      IESNO=NO 
      IF(INFLEX) IESNO=IES 
C 
C     FIRST TRIAL POINT 
      NPOINT=2 
      CALL STATUS (XNEW,AK,N) 
      IF(.NOT.IMPROV) GO TO 40 
      RETURN 
      ENTRY STAT2(AK,N,XNEW,FNEW,EPS) 
      IF(FAIL) GO TO 50 
      GG(NPOINT)=DOT(G(1,NPOINT),G(1,NPOINT),N) 
C 
C     SECOND TRIAL POINT 
      NPOINT=3 
      X2=X(2)**2 
      DO 20 I=1,N 
   20 G2(I)=(G(I,2)-G0(I)-X(2)*G1(I))/X2 
      CALL CARDAN(GV,S,GR,ER,N,SOL,VAL,NSOL,IPOLYN(3)) 
      CALL SELECT (IESNO,NOIES,NPOINT,N,AK) 
      CALL STATUS (XNEW,AK,N) 
      IF(.NOT.IMPROV) GO TO 40 
      RETURN 
      ENTRY STAT3(AK,N,XNEW,FNEW,EPS) 
      IF(FAIL) GO TO 50 
      GG(NPOINT)=DOT(G(1,NPOINT),G(1,NPOINT),N) 
C 
C     OTHERS TRIAL POINTS 
      NPOINT=NPOINT+1 
      A(3,3)= 1.D0/((X(NPOINT-1)-X(NPOINT-3))*(X(NPOINT-2)-X(NPOINT-3))) 
      A(3,2)=-1.D0/((X(NPOINT-1)-X(NPOINT-2))*(X(NPOINT-2)-X(NPOINT-3))) 
      A(3,1)= 1.D0/((X(NPOINT-1)-X(NPOINT-2))*(X(NPOINT-1)-X(NPOINT-3))) 
      A(2,3)=-A(3,3)*(X(NPOINT-1)+X(NPOINT-2)) 
      A(2,2)=-A(3,2)*(X(NPOINT-3)+X(NPOINT-1)) 
      A(2,1)=-A(3,1)*(X(NPOINT-2)+X(NPOINT-3)) 
      A(1,3)=A(3,3)*X(NPOINT-2)*X(NPOINT-1) 
      A(1,2)=A(3,2)*X(NPOINT-1)*X(NPOINT-3) 
      A(1,1)=A(3,1)*X(NPOINT-3)*X(NPOINT-2) 
      DO 30 I=1,3 
      DO 31 K=1,N 
   31 GV(K,I)=0.D0 
      DO 30 J=1,3 
      AIJ=A(I,J) 
CDIR$ IVDEP 
      DO 30 K=1,N 
   30 GV(K,I)=GV(K,I)+AIJ*G(K,NPOINT-J) 
      CALL CARDAN(GV,S,GR,ER,N,SOL,VAL,NSOL,IPOLYN(NPOINT)) 
      ER(1)=E(NPOINT-1)-((ER(4)*X(NPOINT-1)+ER(3))*X(NPOINT-1)+ER(2)) 
     1  *X(NPOINT-1) 
      CALL SELECT(IESNO,NOIES,NPOINT,N,AK) 
      CALL STATUS (XNEW,AK,N) 
      IF(IMPROV) RETURN 
C 
C     FINAL STEP AND EDITION 
   40 FINAL=.TRUE. 
      IF(IMP.EQ.0) GO TO 47 
      WRITE(IPRT,105) IESNO,NOIES 
      WRITE(IPRT,106) 
      WRITE(IPRT,102) X(1),E(1),GG(1) 
      IF(NPOINT.EQ.2) GO TO 44 
      NPO=NPOINT-1 
      DO 41 I=2,NPO 
   41 WRITE(IPRT,103) I,X(I),IPOLYN(I),GGI(I),EI(I),E(I),GG(I) 
   44 WRITE(IPRT,104)NPOINT,X(NPOINT),IPOLYN(NPOINT),GGI(NPOINT), 
     *EI(NPOINT) 
      WRITE(IPRT,107) 
C     ESTABLISH NEW CURRENT POINT XNEW 
   47 AK=E(2) 
      IF (IROUTE.NE.3) AK=GG(2) 
      J=2 
      IF (NPOINT.LT.4) GO TO 45 
      DO 43 I=3,NPO 
      IF (IROUTE.EQ.3) GO TO 46 
      IF (GG(I).GT.AK) GO TO 43 
      J=I 
      AK=GG(I) 
      GO TO 43 
   46 IF (E(I).GT.AK) GO TO 43 
      J=I 
      AK=E(I) 
   43 CONTINUE 
   45 AK=X(J) 
      DO 42 I=1,N 
      GNEW(I)=G(I,J) 
   42 XNEW(I)=XNEW(I)+AK*S(I) 
      FNEW=E(J) 
      RETURN 
C 
C     ABNORMAL TERMINATION : SCF DIVERGENCE 
   50 WRITE(IPRT,100) NPOINT 
      NPOINT=NPOINT-1 
      IF(NPOINT.GT.1) GO TO 40 
      WRITE(IPRT,108) 
      CALL EXIT 
      RETURN 
  100 FORMAT(' ***WARNING***  DIVERGENCE AT STEP',I3,' OF POLYNOMIAL 
     1INTERPOLATION') 
  102 FORMAT(' !   1 !',F8.4,'!',33X,'!',F15.9,1PD13.4,'!') 
  103 FORMAT(' !',I4,' !',F8.4,'!',I3,1PD14.4,0PF16.9,'!',F15.9,1PD13.4, 
     1 '!') 
  104 FORMAT(' !',I4,' !',F8.4,'!',I3,1PD14.4,0PF16.9,'!',28X,'!') 
  105 FORMAT(' ASK FOR <G!G> AFTER MAX:',A4,5X,'OBSERVED:',A4) 
  106 FORMAT (/1H ,79(1H-)/ 
     2 ' !POINT!  STEP  !',11X,'INTERPOLATED',10X,'!',11X,'OBSERVED',9X, 
     4 '!'/ 
     5' !',5X,'!',8X,'!DEGREE',4X,'<G!G>',8X,'ENERGY',4X,'!',5X,'ENERGY' 
     6 ,9X,'<G!G>',3X,'!') 
  107 FORMAT(1H ,79(1H-)) 
  108 FORMAT(' IMPERATIVE STOP') 
      END 
      SUBROUTINE SELECT (IESNO,NOIES,NPOINT,N,AK) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     LTRD METHOD ... 
C     SELECT THE NEXT TRIAL STEP OF POLYNOMIAL INTERPOLATION 
C     IROUTE=2  STATIONNARY POINT RESEARCH BY NEWTON METHOD 
C     IROUTE=3  MINIMIZATION BY NEWTON METHOD 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,G(MAXPAR,10),G0(MAXPAR),G1(MAXPAR),G2(MAXPAR) 
     .              ,CURENT(MAXPAR),X(10),EI(10),GGI(10),E(10) 
     .              ,GG(10),GR(5),ER(4),SOL(3),VAL(3),D(3,3) 
     .              ,IPOLYN(10),INFLEX,IROUTE,NSOL,IMPROV,A(MAXPAR),O(2) 
     .              ,B(3),C(3),F(3),ICURV(1) 
      DIMENSION S(1) 
      EQUIVALENCE (HNEW(1),S(1)) 
      LOGICAL INFLEX,IMPROV 
      DATA NO,IES /4H NO ,4H YES / 
       SAVE
      GO TO (10,10,30),IROUTE 
   10 NOIES=NO 
      IF(SOL(1).GT.0.D0) GO TO 11 
C 
C     LONG RANGE INVESTIGATION 
      AK=2.D0*X(NPOINT-1) 
      IF(INFLEX) RETURN 
C 
C     RESEARCH OF A MINIMUM OF EUCLIDIAN NORM OF GRADIENT IN A 
C       SECOND ORDER TAYLOR EXPANSION 
      NRANG=3 
      IF(NPOINT.EQ.3) NRANG=2 
      DO 1 I=1,NRANG 
      F(I)=SQRT(GG(NPOINT-I)) 
    1 B(I)=X(NPOINT-I) 
      IF(NRANG.EQ.2) GO TO 5 
C     SOLVE THE VAN DER MONDE EQUATIONS 
      D(1,1)= 1.D0/((B(3)-B(1))*(B(2)-B(1))) 
      D(2,1)=-1.D0/((B(2)-B(1))*(B(3)-B(2))) 
      D(3,1)= 1.D0/((B(3)-B(1))*(B(3)-B(2))) 
      D(1,2)=-D(1,1)*(B(2)+B(3)) 
      D(2,2)=-D(2,1)*(B(3)+B(1)) 
      D(3,2)=-D(3,1)*(B(1)+B(2)) 
      D(1,3)=D(1,1)*B(3)*B(2) 
      D(2,3)=D(2,1)*B(1)*B(3) 
      D(3,3)=D(3,1)*B(2)*B(1) 
      DO 2 I=1,3 
    2 C(I)=DOT(D(1,I),F,3) 
      IF(DABS(C(1)).LT.DABS(C(2))*1.D-3) GO TO 5 
      IF(C(1).GT.0.D0) GO TO 3 
             AK=MIN(5.D0*B(1) , 
     1 -( C(2)+SQRT(C(2)**2-4.D0*C(1)*C(3)))/(2.D0*C(1))       ) 
      RETURN 
    3        AK=MIN(-C(2)/(2.D0*C(1)),5.D0*B(1)) 
      IF(AK.GT.0.D0) RETURN 
    4        AK=B(1)/2.D0 
      RETURN 
    5 IF(F(1).GE.F(2)) GO TO 4 
             AK=MIN((B(1)*F(2)-B(2)*F(1))/(F(2)-F(1)),5.D0*B(1)) 
      RETURN 
C 
C     SELECT ONE OF THE CARDAN SOLUTIONS 
   11 IF(NSOL.EQ.3.AND.SOL(3).GT.0.D0) GO TO 12 
             AK=SOL(1) 
      IF(NSOL.EQ.3.AND.SOL(2).GT.0.D0) NOIES=IES 
      RETURN 
   12 IF(INFLEX) GO TO 13 
             AK=SOL(3) 
      RETURN 
   13        AK=SOL(1) 
      NOIES=IES 
      RETURN 
C 
C     RESEARCH OF A MINIMUM OF ENERGY IN A THIRD ORDER TAYLOR EXPANSION 
C     THIS FORMALISM IS AVAILABLE IF THE SLOPE AT ORIGIN IS NEGATIVE 
C     AND ONLY POSITIVE STEP ARE ALLOWED 
   30 NOIES=NO 
      ISOL=IPOLYN(NPOINT) 
      GO TO (35,32,31),ISOL 
   31 DELTA=ER(3)**2-3.D0*ER(2)*ER(4) 
      IF(DELTA.LT.0.D0) GO TO 35 
      AK=(SQRT(DELTA)-ER(3))/(3.D0*ER(4)) 
      GO TO 33 
   32 AK=-ER(2)/(2.D0*ER(3)) 
   33 IF(AK.GT.0.D0) GO TO 34 
      IF(E(NPOINT-1).LT.E(1)) GO TO 35 
      AK=X(NPOINT-1)/3.D0 
   34 IF(NSOL.EQ.3.AND.SOL(2).GT.0.D0.AND.SOL(2).LE.AK) NOIES=IES 
      RETURN 
   35 AK=X(NPOINT-1)*2.D0 
      GO TO 34 
      END 
      SUBROUTINE STATUS(XNEW,AK,N) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     LTRD METHOD         POLYNOMIAL EXTRAPOLATION PART 
C     ENERGY AND GRADIENT (INTERPOLATED AND OBSERVED) 
C     AT POINT (CURENT) = (XNEW) + AK * (S) 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HNEW(MAXHES),GNEW(MAXPAR) 
     .              ,G(MAXPAR,10),G0(MAXPAR),G1(MAXPAR),G2(MAXPAR) 
     .              ,CURENT(MAXPAR),X(10),EI(10),GGI(10),E(10) 
     .              ,GG(10),GR(5),ER(4),SOL(3),VAL(3),BIDON(3,3) 
     .              ,IPOLYN(10),INFLEX,IROUTE,NSOL,IMPROV,NPOINT,NPTMAX 
     .              ,IESNO,NOIES,FINAL,LOWER 
      DIMENSION XNEW(1),S(1) 
      LOGICAL INFLEX,IMPROV,FINAL,LOWER 
      EQUIVALENCE(HNEW(1),S(1)) 
      DATA XEPSI/1.D-5/ 
       SAVE
      NPMIN=NPOINT-1 
      IF (LOWER) GO TO 1 
      IF((IROUTE.EQ.3.AND.E(NPMIN).LT.E(1)).OR. 
     .   (IROUTE.NE.3.AND.GG(NPMIN).LT.GG(1))) LOWER=.TRUE. 
    1 AK=MAX(AK,10.D0**(-NPMIN)) 
      X  (NPOINT)=AK 
      EI(NPOINT)=((ER(4)*AK+ER(3))*AK+ER(2))*AK+ER(1) 
      GGI(NPOINT)=(((GR(5)*AK+GR(4))*AK+GR(3))*AK+GR(2))*AK+GR(1) 
      IF (NPOINT.GE.10) GO TO 10 
      IF (.NOT.LOWER) GO TO 20 
      IF (NPOINT.GT.NPTMAX) GO TO 10 
      DO 2 I=1,NPMIN 
      IF(DABS(AK-X  (I)).LT.XEPSI*10.D0**(NPOINT/2)) GO TO 10 
    2 CONTINUE 
   20 IMPROV=.TRUE. 
      DO 3 I=1,N 
    3 CURENT(I)=XNEW(I)+AK*S(I) 
C     AT THIS POINT A CALL TO 'COMPFG' IS MADE IN MAIN ROUTINE 'STAT' 
      RETURN 
   10 IMPROV=.FALSE. 
      RETURN 
      END 
      SUBROUTINE CARDAN (G,DI,A,AP,NDIM,S,F,N,IDEG) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     EXTREMA OF GRADIENT NORM IN THIRD ORDER TAYLOR EXPANSION 
      DIMENSION G(MAXPAR,3),A(5),AP(4),S(3),F(3),DI(*) 
      DATA TWOPI /6.283185307179586476925286766558 D0/ 
      DATA EPS /1.D-6/ ,EPS1,EPS2 /1.D-07,1.D-13 / 
       SAVE
      DERI(Y)=((4.D0*A5*Y+3.D0*A4)*Y+2.D0*A3)*Y+A2 
C 
C 
C     COMPUTE COEFFICIENTS OF<G!G> AND ... 
C     THOSE OF ENERGY PREDICTED IN !DI> DIRECTION. 
      A1=     DOT(G(1,1),G(1,1),NDIM) 
      A2=2.D0*DOT(G(1,1),G(1,2),NDIM) 
      A3=     DOT(G(1,2),G(1,2),NDIM) + DOT(G(1,1),G(1,3),NDIM)*2.D0 
      A4=2.D0*DOT(G(1,2),G(1,3),NDIM) 
      A5=     DOT(G(1,3),G(1,3),NDIM) 
      A(1)=A1 
      A(2)=A2 
      A(3)=A3 
      A(4)=A4 
      A(5)=A5 
C     AP(1) MUST BE PREVIOUSLY DEFINED ELSEWHERE 
      AP(2)=DOT(DI,G(1,1),NDIM) 
      AP(3)=DOT(DI,G(1,2),NDIM)/2.D0 
      AP(4)=DOT(DI,G(1,3),NDIM)/3.D0 
C 
C     SOLVE THE THIRD DEGREE PROBLEM 
      TR=1.D0/3.D0 
      IF(DABS(A5).LT.EPS2  ) GO TO 30 
      IDEG=3 
      C=4.D0*A5 
      FLEX=-A4/C 
      P=(3.D0*A4*FLEX+2.D0*A3)/C 
      Q=DERI(FLEX)/C 
      IF(DABS(P).LT.EPS1) GO TO 42 
      E=SQRT(DABS(P)/3.D0) 
      T=-Q/(2.D0*(E**3)) 
      IF(P.GT.0.D0.OR.DABS(T).GT.1.D0) GO TO 43 
      B=ACOS(T) 
      DO 40 I=1,3 
   40 S(I)=2.D0*E*DCOS((B+TWOPI*FLOAT(I-2))/3.D0)+FLEX 
      N=3 
C     CLASS THE ROOTS IN DESCENDING ORDER 
      DO 41 I=1,2 
      SS=S(I) 
      K=I+1 
      DO 41 J=K,3 
      IF(SS.GE.S(J)) GO TO 41 
      SS=S(J) 
      S(J)=S(I) 
      S(I)=SS 
   41 CONTINUE 
      GO TO 10 
   42 S(1)=FLEX 
      IF(DABS(Q).GT.EPS2) S(1)=S(1)+DSIGN(DABS(Q)**TR,-Q) 
      GO TO 44 
   43 Q=Q/2.D0 
      T=(P**3)/27.D0+Q**2 
      IF(T.LT.EPS2) GO TO 42 
      T=SQRT(T) 
      S(1)=FLEX 
      P=T-Q 
      IF(DABS(P).GT.EPS2) S(1)=S(1)+DSIGN(DABS(P)**TR,P) 
      P=T+Q 
      IF(DABS(P).GT.EPS2) S(1)=S(1)-DSIGN(DABS(P)**TR,P) 
   44 N=1 
      GO TO 10 
   30 IF(DABS(A3).LT.EPS2  ) GO TO 20 
      IDEG=2 
      N=1 
      S(1)=-A2/(2.D0*A3) 
      GO TO 10 
   20 IDEG=1 
      N=1 
      S(1)=-A1/A2 
   10 DO 11 I=1,N 
      IF(DABS(S(I)).LT.EPS ) S(I)=0.D0 
   11 F(I)=(((A(5)*S(I)+A(4))*S(I)+A(3))*S(I)+A(2))*S(I)+A(1) 
      RETURN 
      END 
      SUBROUTINE MATOUT (A,B,NC,NR,NDIM) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION A(NDIM,NDIM), B(NDIM) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ELEMTS/ ELEMNT(107) 
C********************************************************************** 
C 
C      MATOUT PRINTS A SQUARE MATRIX OF EIGENVECTORS AND EIGENVALUES 
C 
C    ON INPUT A CONTAINS THE MATRIX TO BE PRINTED. 
C             B CONTAINS THE EIGENVALUES. 
C             NC NUMBER OF MOLECULAR ORBITALS TO BE PRINTED. 
C             NR IS THE SIZE OF THE SQUARE ARRAY TO BE PRINTED. 
C             NDIM IS THE ACTUAL SIZE OF THE SQUARE ARRAY "A". 
C             NFIRST AND NLAST CONTAIN ATOM ORBITAL COUNTERS. 
C             NAT = ARRAY OF ATOMIC NUMBERS OF ATOMS. 
C 
C 
C*********************************************************************** 
      CHARACTER*2 ELEMNT, ATORBS(9), ITEXT(MAXORB), JTEXT(MAXORB) 
      DIMENSION NATOM(MAXORB) 
      DATA ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/ 
       SAVE
      IF(NUMAT.EQ.0)GOTO 30 
      IF(NLAST(NUMAT).NE.NR) GOTO 30 
      DO 20 I=1,NUMAT 
         JLO=NFIRST(I) 
         JHI=NLAST(I) 
         L=NAT(I) 
         K=0 
         DO 10 J=JLO,JHI 
            K=K+1 
            ITEXT(J)=ATORBS(K) 
            JTEXT(J)=ELEMNT(L) 
            NATOM(J)=I 
   10    CONTINUE 
   20 CONTINUE 
      GOTO 50 
   30 CONTINUE 
      NR=ABS(NR) 
      DO 40 I=1,NR 
         ITEXT(I)='  ' 
         JTEXT(I)='  ' 
   40 NATOM(I)=I 
   50 CONTINUE 
      KA=1 
      KC=6 
   60 KB=MIN0(KC,NC) 
      WRITE (6,100) (I,I=KA,KB) 
      IF(B(1).NE.0.D0)WRITE (6,110) (B(I),I=KA,KB) 
      WRITE (6,120) 
      LA=1 
      LC=40 
   70 LB=MIN0(LC,NR) 
      DO 80 I=LA,LB 
         IF(ITEXT(I).EQ.' S')WRITE(6,120) 
         WRITE (6,130) ITEXT(I),JTEXT(I),NATOM(I),(A(I,J),J=KA,KB) 
   80 CONTINUE 
      IF (LB.EQ.NR) GO TO 90 
      LA=LC+1 
      LC=LC+40 
      WRITE (6,140) 
      GO TO 70 
   90 IF (KB.EQ.NC) RETURN 
      KA=KC+1 
      KC=KC+6 
      IF (NR.GT.25) WRITE (6,140) 
      GO TO 60 
  100 FORMAT (////,3X,9H ROOT NO.,I5,9I12) 
  110 FORMAT (/8X,10F12.5) 
  120 FORMAT (2H  ) 
  130 FORMAT (1H ,2(1X,A2),I3,F10.5,10F12.5) 
  140 FORMAT (1H1) 
      END 
      FUNCTION MECI(EIGS,COEFF,WORK,EIGA,N,NMOS,KDELTA,PRNT1,LGRAD) 
*********************************************************************** 
* 
*                 PROGRAM MECI 
* 
*   A MULTI-ELECTRON CONFIGURATION INTERACTION CALCULATION 
* 
*   WRITTEN BY JAMES J. P. STEWART, AT THE 
*              FRANK J. SEILER RESEARCH LABORATORY 
*              USAFA, COLORADO SPRINGS, CO 80840 
* 
*              1985 
* 
*   REVISED BY D.LIOTARD (M.J.S. DEWAR GROUP, SEPTEMBER 1986) : 
*   1)  <IJ!KL> CALCULATION, 
*   2)  DENSITY MATRIX C.I.-CORRECTION, 
*   3)  CONNECTION WITH ANALYTICAL GRADIENT CALCULATION. 
*********************************************************************** 
C 
      IMPLICIT REAL(A-H,O-Z) 
      REAL MECI 
       INCLUDE "SIZES"
      DIMENSION EIGA(MAXORB), EIGS(MAXORB), COEFF(N,N), WORK(N,N) 
      LOGICAL DEBUG, PRTVEC, PRNT1, PRNT, FIRST, LSPIN, LSPIN1, 
     1 FIRST1, PRNT2, SING, DOUB, TRIP, QUAR, QUIN, SEXT, LGRAD 
      CHARACTER KEYWRD*80, TSPIN(7)*8 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS, 
     2                NDUMMY(2), NCLOSE, NOPEN, NDUMY, FRACT 
     3       /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NWDUM(NUMATM+1) 
     4       /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 
     5       /LAST  / LAST 
     6       /OPTIM / IMP,IMP0,LEC,IPRT 
     7       /KEYWRD/ KEYWRD 
      COMMON /SPQR  / ISPQR(NMECI**2,NMECI),ISDUM(3) 
     1       /BASEOC/ OCCA(NMECI),NFA(NMECI+2) 
     2       /CIDATA/ VECTCI(NMECI**2),XX,NELEC,NCI2,LAB 
     3               ,NALPHA(NMECI**2) 
     4               ,MICROA(NMECI,NMECI**2),MICROB(NMECI,NMECI**2) 
     5       /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
      COMMON /SCRAH1/ CIMAT(NMECI**4),CONF(NMECI**4),EIG(NMECI**2) 
     1               ,DIAG(2*NMECI**2),SPIN(NMECI**2) 
     2               ,NPERMA(NMECI,6*NMECI),NPERMB(NMECI,6*NMECI) 
     3       /SCRAH2/ DIJKL(NRELAX*MORB2) 
      DIMENSION W(1) 
      EQUIVALENCE (W,WJ) 
      DATA TSPIN/'SINGLET ','DOUBLET ','TRIPLET ','QUARTET ','QUINTET ', 
     1           'SEXTET  ','SEPTET  '/ 
      DATA FIRST/.TRUE./, FIRST1/.TRUE./ 
       SAVE
C 
C     DEBUG KEYWRD AND INITIALIZE. 
C     ---------------------------- 
      IF(FIRST)THEN 
         FIRST=.FALSE. 
         LSPIN1=(INDEX(KEYWRD,'ESR').NE.0) 
         DEBUG=(INDEX(KEYWRD,'DEBU').NE.0) 
         PRNT2=(INDEX(KEYWRD,'MECI').NE.0) 
         LROOT=1 
         IF(INDEX(KEYWRD,'EXCI').NE.0)LROOT=2 
         I=INDEX(KEYWRD,'ROOT') 
         IF(I.NE.0)LROOT=READA(KEYWRD,I) 
         PRTVEC=(INDEX(KEYWRD,'VECT').NE.0) 
C        OCCUPANCY OF C.I-ACTIVE M.O 
         J=(NCLOSE+NOPEN+1)/2-(NMOS-1)/2 
         L=0 
         DO 10 I=J,NCLOSE 
            L=L+1 
   10    OCCA(L)=1 
         DO 20 I=NCLOSE+1,NOPEN 
            L=L+1 
   20    OCCA(L)=FRACT*0.5D0 
         DO 30 I=NOPEN+1,J+NMOS 
            L=L+1 
   30    OCCA(L)=0.D0 
C        REQUIRED MULTIPLICITY. 
         SING=(INDEX(KEYWRD,'SING')+ 
     1         INDEX(KEYWRD,'EXCI')+ 
     2         INDEX(KEYWRD,'BIRA').NE.0) 
         DOUB=(INDEX(KEYWRD,'DOUB').NE.0) 
         TRIP=(INDEX(KEYWRD,'TRIP').NE.0) 
         QUAR=(INDEX(KEYWRD,'QUAR').NE.0) 
         QUIN=(INDEX(KEYWRD,'QUIN').NE.0) 
         SEXT=(INDEX(KEYWRD,'SEXT').NE.0) 
         SMULT=-.5D0 
         IF(SING) SMULT=0.00D0 
         IF(DOUB) SMULT=0.75D0 
         IF(TRIP) SMULT=2.00D0 
         IF(QUAR) SMULT=3.75D0 
         IF(QUIN) SMULT=6.00D0 
         IF(SEXT) SMULT=8.75D0 
C        XX IS THE NUMBER OF ELECTRONS IN C.I 
         X=0.D0 
         DO 40 J=1,NMOS 
   40    X=X+OCCA(J) 
         XX=X+X 
         NE=XX+0.5 
         NELEC=(NELECS-NE+1)/2 
         NLEFT=NORBS-NMOS-NELEC 
C        FILL TABLE OF FACTORIALS NUMBER. 
         NFA(1)=1 
         NFA(2)=1 
         DO 50 I=2,NMECI+1 
   50    NFA(I+1)=NFA(I)*I 
C        NUMBER OF ACTIVE M.O 
         NCI2=NMOS 
      ENDIF 
C 
C     PRINTOUT LEVEL 
      DEBUG=(DEBUG.AND.PRNT2) 
      PRNT=(PRNT1.AND.PRNT2) 
      LSPIN=(LSPIN1.AND. PRNT1) 
      KALPHA=(NE+1)/2 
      KBETA=NE-KALPHA 
C 
C     2-ELECTRONS INTEGRALS OVER C.I-ACTIVE M.O. 
C     ------------------------------------------ 
C     COMPUTE ALSO <IJ!KL> IN /SCRAH2/ FOR SUBSEQUENT GRADIENT, 
C     WITH I RUNNING OVER C.I-ACTIVE M.O IF LGRAD IS FALSE 
C                         OR   ALL   M.O IF LGRAD IS TRUE, 
C          J AND K>=L RUNNING OVER ALL C.I-ACTIVE M.O. 
      MDIJKL=N*NMOS*NMOS*(NMOS+1)/2 
      MPQKL =NRELAX*MORB2-MDIJKL 
      CALL IJKL (COEFF,N,NELEC+1,NMOS,W,DIJKL(MDIJKL+1),MPQKL 
     .          ,XY,NMECI,DIJKL,LGRAD) 
C 
C     READ OR GENERATE MICRO-STATES. 
C     ----------------------------- 
      NATOMS=NUMAT 
      IF(FIRST1) THEN 
         I=INDEX(KEYWRD,'MICROS') 
         IF(I.NE.0)THEN 
            K=READA(KEYWRD,I) 
            LAB=K 
            IF(DEBUG)WRITE(IPRT,'(''    MICROSTATES READ IN'')') 
            NTOT=XX+0.5 
            DO 110 I=1,LAB 
               READ(LEC,'(20I1)')(MICROA(J,I),J=1,NMOS),(MICROB(J,I) 
     .                           ,J=1,NMOS) 
               IF(DEBUG)WRITE(IPRT,'(20I6)')(MICROA(J,I),J=1,NMOS), 
     1    (MICROB(J,I),J=1,NMOS) 
               K=0 
               DO 100 J=1,NMOS 
  100          K=K+MICROA(J,I)+MICROB(J,I) 
               IF(K.NE.NTOT)THEN 
                  NTOT=K 
                  XX=K 
                  WRITE(IPRT,'(/,'' NUMBER OF ELECTRONS IN C.I. REDEFINE 
     .D TO :'',I4)')K 
               ENDIF 
  110       CONTINUE 
            FIRST1=.FALSE. 
         ENDIF 
      ENDIF 
C 
C     COMPUTE SPIN MULTIPLICITY AND CHECK. 
C 
      K=KDELTA 
      IF(PRNT)WRITE(IPRT,'(/,'' DELTA S = '',I4)')K 
      NUPP=KALPHA+K 
      NDOWN=KBETA-K 
      AMS=(NUPP-NDOWN)*0.5D0 
      IF(PRNT)WRITE(IPRT,'(/,'' MS = '',F4.1)') AMS 
      IF(NUPP*NDOWN.LT.0) THEN 
         WRITE(IPRT,'(/,'' IMPOSSIBLE VALUE OF DELTA S ... STOP.'')') 
         STOP 
      ENDIF 
      LIMA=NFA(NMOS+1)/(NFA(NUPP+1)*NFA(NMOS-NUPP+1)) 
      LIMB=NFA(NMOS+1)/(NFA(NDOWN+1)*NFA(NMOS-NDOWN+1)) 
      LAB=LIMA*LIMB 
      IF(PRNT)WRITE(IPRT,'(/'' NO OF CONFIGURATIONS CONSIDERED ='',I4)') 
     .                    LAB 
      IF(LAB.GT.2*NMECI**2) THEN 
         WRITE(IPRT,'('' TOO MANY CONFIGURATIONS IN C.I. STOP....'')') 
         STOP 
      ENDIF 
      CALL PERM(NPERMA, NUPP, NMOS, 10, LIMA) 
      CALL PERM(NPERMB, NDOWN, NMOS, 10, LIMB) 
      K=0 
      DO 120 I=1,LIMA 
      DO 120 J=1,LIMB 
      K=K+1 
      DO 120 L=1,NMOS 
      MICROA(L,K)=NPERMA(L,I) 
  120 MICROB(L,K)=NPERMB(L,J) 
C 
C     GROUND STATE (I.E VACUUM) ENERGY AND DIAGONAL ELEMENTS OF THE C.I 
C     ----------------------------------------------------------------- 
      CALL MECID (EIGS,GSE,EIGA,DIAG) 
C 
C     CHECK THE NUMBER OF CONFIGURATION (CUTOFF = NMECI**2). 
C     ------------------------------------------------------ 
      J=0 
  130 IF(LAB.LE.NMECI**2) GO TO 170 
      X=DIAG(1)-1.D0 
      DO 140 I=1,LAB 
         IF(DIAG(I).GT.X)THEN 
            X=DIAG(I) 
            J=I 
         ENDIF 
  140 CONTINUE 
      IF(J.NE.LAB) THEN 
         DO 160 I=J,LAB 
            I1=I+1 
            DO 150 K=1,NMOS 
               MICROA(K,I)=MICROA(K,I1) 
  150       MICROB(K,I)=MICROB(K,I1) 
  160    DIAG(I)=DIAG(I1) 
      ENDIF 
      LAB=LAB-1 
      GOTO 130 
C 
C     BUILD SPIN AND NUMBER OF ALPHA SPIN TABLES. 
C     ------------------------------------------- 
  170 DO 190 I=1,LAB 
      K=0 
      X=0.D0 
      DO 180 J=1,NMOS 
      X=X+MICROA(J,I)*MICROB(J,I) 
  180 K=K+MICROA(J,I) 
      NALPHA(I)=K 
  190 SPIN(I)=4.D0*X-(XX-2*NALPHA(I))**2 
C 
C     SOME PRINTOUT. 
C     -------------- 
      IF(PRNT) THEN 
         WRITE(IPRT,'(/,'' NUMBER OF ELECTRONS IN C.I. ='',F5.1)')XX 
         IF( DEBUG ) THEN 
            WRITE(IPRT,'(/,''  C.I-ACTIVE M.O COEFFICIENTS AND EIGENVALU 
     .ES BEFORE & AFTER 2-ELECT REMOVAL'')') 
            DO 200 J=NELEC+1,NELEC+NMOS 
            WRITE(IPRT,'('' M.O'',I4,'' EIGENVALUE'',2F12.6)') 
     .                   J,EIGS(J),EIGA(J-NELEC) 
  200       WRITE(IPRT,'(8F10.6)')(COEFF(I,J),I=1,NORBS) 
         ENDIF 
         WRITE(IPRT,'(/,'' TWO-ELECTRON J-INTEGRALS OVER ACTIVE M.O'')') 
         DO 210 I=1,NMOS 
  210    WRITE(IPRT,'(10F8.4)')(XY(I,I,J,J),J=1,NMOS) 
         WRITE(IPRT,'(/,'' TWO-ELECTRON K-INTEGRALS OVER ACTIVE M.O'')') 
         DO 220 I=1,NMOS 
  220    WRITE(IPRT,'(10F8.4)')(XY(I,J,I,J),J=1,NMOS) 
         WRITE(IPRT,'(/,'' GROUND STATE ENERGY:'',F13.6,'' E.V.'')')GSE 
         WRITE(IPRT,'(/,'' CONFIGURATIONS CONSIDERED IN C.I.''/ 
     1          '' M.O. NUMBER :      '',10I4)')(I,I=NELEC+1,NELEC+NMOS) 
         DO 230 I=1,LAB 
         WRITE(IPRT,'(/10X,I4,6X,10I4)') I,(MICROA(K,I),K=1,NMOS) 
  230    WRITE(IPRT,'(20X,10I4)')(MICROB(K,I),K=1,NMOS) 
      ENDIF 
C 
C  FILL SECULAR DETERMINANT 
C  ------------------------ 
C 
      CALL MECIH (DIAG,CIMAT) 
C 
C     PRINTOUT 
      IF(DEBUG)THEN 
         WRITE(IPRT,'(/,'' C.I. MATRIX'')') 
         CALL VECPRT(CIMAT,LAB) 
      ELSE 
         IF(PRNT) THEN 
            WRITE(IPRT,'(/,'' DIAGONAL OF C.I. MATRIX'')') 
            WRITE(6,'(5F13.6)')(CIMAT((I*(I+1))/2),I=1,LAB) 
         ENDIF 
      ENDIF 
C 
C     DIAGONALIZE THE C.I MATRIX 
C     -------------------------- 
      LABCUT=MIN(LAB,LROOT+10) 
      CALL HQRII(CIMAT,LAB,LABCUT,EIG,CONF) 
C 
C     DECIDE WHICH ROOT TO EXTRACT 
      KROOT=0 
      IF(SMULT.LT.0.1D0) KROOT=LROOT 
      IF(PRNT.AND.PRTVEC)  THEN 
         WRITE(IPRT,'(/,'' STATE EIGENVECTORS'')') 
         CALL MATOUT(CONF,EIG,LABCUT,LAB,LAB) 
      ENDIF 
      IF(PRNT)WRITE(IPRT,'(/,'' STATE ENERGIES '', 
     .           '' EXPECTATION VALUE OF S**2  S FROM S**2=S(S+1)'')') 
      IROOT=0 
      DO 270 I=1,LABCUT 
         X=0.5D0*XX 
         II=(I-1)*LAB 
         DO 260 J=1,LAB 
            JI=J+II 
            X=X-CONF(JI)*CONF(JI)*SPIN(J)*0.25D0 
            K=ISPQR(J,1) 
            IF(K.EQ.1)  GOTO  250 
            DO 240 K=2,K 
               LI=ISPQR(J,K)+II 
  240       X=X+CONF(JI)*CONF(LI)*2.D0 
  250       CONTINUE 
  260    CONTINUE 
         Y=(-1.D0+SQRT(1.D0+4.D0*X))*0.5D0 
         IF(ABS(SMULT-X).LT.0.01)THEN 
            IROOT=IROOT+1 
            IF(IROOT.EQ.LROOT) KROOT=I 
         ENDIF 
         J=Y*2.D0+1.5D0 
  270 IF(PRNT)WRITE(IPRT,'(F12.6,I5,3X,A8,2F8.2)') EIG(I),I,TSPIN(J),X,Y 
C 
C     SELECTED EIGENSTATE TOWARD OPTIMIZATION AND DERIVATIVES 
C     ------------------------------------------------------- 
      MECI=EIG(KROOT) 
      J=LAB*(KROOT-1) 
      DO 280 I=1,LAB 
  280 VECTCI(I)=CONF(I+J) 
      IF(PRNT) THEN 
         WRITE(IPRT,'(/'' EIGENVECTOR OF THE SELECTED STATE'', 
     1                 '' (NUMBER'',I3,'')'')')KROOT 
         WRITE(IPRT,'(10F8.4)')(VECTCI(I),I=1,LAB) 
      ENDIF 
C 
C     BUILD AND PRINT SPIN DENSITY MATRIX AFTER C.I. 
C     ---------------------------------------------- 
      IF (.NOT.LSPIN) RETURN 
      MAXVEC=MIN(4,LAB) 
      IF((NE/2)*2.EQ.NE) THEN 
        WRITE(IPRT,'(/,'' ESR SPECIFIED FOR AN EVEN-ELECTRON SYSTEM'')') 
      ENDIF 
      DO 300 I=1,NMOS 
         DO 300 J=1,NORBS 
  300 WORK(J,I)=COEFF(J,NELEC+I)**2 
      DO 370 IUJ=1,MAXVEC 
         IOFSET=(IUJ-1)*LAB 
         WRITE(IPRT,'(/,'' MICROSTATE CONTRIBUTIONS TO '', 
     .                  ''STATE EIGENFUNCTION'',I3)')IUJ 
         WRITE(IPRT,'(5F13.6)')(CONF(I+IOFSET),I=1,LAB) 
         DO 310 I=1,LAB 
  310    CONF(I)=CONF(I+IOFSET)**2 
C                                             SECOND VECTOR] 
         DO 330 I=1,NMOS 
            SUM=0.D0 
            DO 320 J=1,LAB 
  320       SUM=SUM+(MICROA(I,J)-MICROB(I,J))*CONF(J) 
  330    EIGA(I)=SUM 
         WRITE(IPRT,'(/,'' SPIN DENSITIES FROM EACH M.O., ENERGY:'' 
     .               ,F7.3)')EIG(IUJ) 
         WRITE(IPRT,'(5F12.6)') (EIGA(I),I=1,NMOS) 
         WRITE(IPRT,*)'     SPIN DENSITIES FROM EACH ATOMIC ORBITAL' 
         WRITE(IPRT,*)'    S        PX        PY        PZ        TOTAL' 
         DO 360 I=1,NATOMS 
            IL=NFIRST(I) 
            IU=NLAST(I) 
            L=0 
            SUMM=0.D0 
            DO 350 K=IL,IU 
               L=L+1 
               SUM=0.D0 
               DO 340 J=1,NMOS 
  340          SUM=SUM+WORK(K,J)*EIGA(J) 
            SUMM=SUMM+SUM 
  350       EIGS(L)=SUM 
      IF(L.EQ.4)THEN 
         WRITE(IPRT,'(''  ATOM'',I4,''    SPIN DENSITY  '',5F10.7)') 
     .               I,(EIGS(K),K=1,L),SUMM 
      ELSE 
         WRITE(IPRT,'(''  ATOM'',I4,''    SPIN DENSITY  '',F10.7 
     .               ,30X,F10.7)')I,EIGS(1),SUMM 
      ENDIF 
  360 CONTINUE 
  370 CONTINUE 
      RETURN 
      END 
      SUBROUTINE MECID ( EIGS,GSE,EIGA,DIAG) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION EIGS(*),EIGA(*),DIAG(*) 
      COMMON /BASEOC/ OCCA(NMECI),KDUM(NMECI+2) 
     1       /XYIJKL/ XY(NMECI,NMECI,NMECI,NMECI) 
     2       /CIDATA/ VECTCI(NMECI**2),XX,NELEC,NMOS,LAB 
     3               ,NALPHA(NMECI**2) 
     4               ,MICROA(NMECI,NMECI**2),MICROB(NMECI,NMECI**2) 
C 
C     EIGENVALUES AFTER REMOVAL OF 2-ELECT INTERACTION : EIGA 
C     GROUND STATE (VACUUM) ENERGY : GSE 
C     DIAGONAL ELEMENTS OF THE C.I.MATRIX : DIAG 
C 
       SAVE
      GSE=0.D0 
      DO 20 I=1,NMOS 
      X=0.0 
      DO 10 J=1,NMOS 
   10 X=X+(2.D0*XY(I,I,J,J)-XY(I,J,I,J))*OCCA(J) 
      EIGA(I)=EIGS(I+NELEC)-X 
      GSE=GSE+EIGA(I)*OCCA(I)*2.D0 
      GSE=GSE+XY(I,I,I,I)*OCCA(I)*OCCA(I) 
      DO 20 J=I+1,NMOS 
   20 GSE=GSE+2.D0*(2.D0*XY(I,I,J,J) - XY(I,J,I,J))*OCCA(I)*OCCA(J) 
C     DIAGONAL ELEMENTS OF C.I MATRIX 
      DO 30 I=1,LAB 
   30 DIAG(I)=DIAGI(MICROA(1,I),MICROB(1,I),EIGA,XY,NMOS)-GSE 
      RETURN 
      END 
      SUBROUTINE MECIH (DIAG,CIMAT) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION DIAG(*),CIMAT(*) 
C 
C     BUILD THE C.I. MATRIX 'CIMAT' IN PACKED CANONICAL FORM. 
C 
      COMMON /CIDATA/ VECTCI(NMECI**2),XX,NELEC,NMOS,LAB 
     1               ,NALPHA(NMECI**2) 
     2               ,MICROA(NMECI,NMECI**2),MICROB(NMECI,NMECI**2) 
     3       /SPQR  / ISPQR(NMECI**2,NMECI),IS,I,K 
       SAVE
C 
      IK=0 
C 
C     OUTER LOOP TO FILL C.I. MATRIX. 
      DO 30 I=1,LAB 
         IS=2 
C 
C     INNER LOOP. 
         DO 20 K=1,I 
            IK=IK+1 
            CIMAT(IK)=0.D0 
            IX=0 
            IY=0 
            DO 10 J=1,NMOS 
            IX=IX+ABS(MICROA(J,I)-MICROA(J,K)) 
   10       IY=IY+ABS(MICROB(J,I)-MICROB(J,K)) 
C 
C                              CHECK IF MATRIX ELEMENT HAS TO BE ZERO 
C 
            IF(IX+IY.GT.4 .OR. NALPHA(I).NE.NALPHA(K)) GO TO 20 
            IF(IX+IY.EQ.4) THEN 
               IF(IX.EQ.0)THEN 
                  CIMAT(IK)=BABBCD(MICROA(1,I),MICROB(1,I) 
     .                            ,MICROA(1,K),MICROB(1,K),NMOS) 
               ELSE IF(IX.EQ.2) THEN 
                  CIMAT(IK)=AABBCD(MICROA(1,I),MICROB(1,I) 
     .                            ,MICROA(1,K),MICROB(1,K),NMOS) 
               ELSE 
                  CIMAT(IK)=AABACD(MICROA(1,I),MICROB(1,I) 
     .                            ,MICROA(1,K),MICROB(1,K),NMOS) 
               ENDIF 
            ELSE IF(IX.EQ.2) THEN 
               CIMAT(IK)=AABABC(MICROA(1,I),MICROB(1,I) 
     .                         ,MICROA(1,K),MICROB(1,K),NMOS) 
            ELSE IF(IY.EQ.2) THEN 
               CIMAT(IK)=BABBBC(MICROA(1,I),MICROB(1,I) 
     .                         ,MICROA(1,K),MICROB(1,K),NMOS) 
            ELSE 
               CIMAT(IK)=DIAG(I) 
            ENDIF 
   20    CONTINUE 
   30 ISPQR(I,1)=IS-1 
      RETURN 
      END 
      SUBROUTINE MECIP (P,C,WORK,N,W2,NMOS) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /BASEOC/ OCCA(NMECI),NFA(NMECI+2) 
     1       /CIDATA/ VECTCI(NMECI**2),XX,NCI1,NCI2,NCI3 
     2               ,NALPHA(NMECI**2) 
     3               ,MICROA(NMECI,NMECI**2),MICROB(NMECI,NMECI**2) 
C 
C     UPDATE TOTAL DENSITY MATRIX DUE TO C.I. CORRECTION 
C 
C  INPUT 
C     P        : TOTAL DENSITY MATRIX ISSUING FROM SCF COMPUTATION 
C     C(N,N)   : M.O. COEFFICIENTS , IN COLUMN 
C     WORK(N,NMOS) : WORK ARRAY 
C     W2(NMOS,NMOS): WORK ARRAY. (NMOS MUST BE EQUAL TO NCI2) 
C  OUTPUT 
C     P        : TOTAL DENSITY MATRIX AFTER C.I. CORRECTION, 
C                RETURNED IN PACKED CANONICAL ORDER. 
C 
      DIMENSION P(*),C(N,N),WORK(N,NMOS),W2(NMOS,NMOS) 
      SAVE
C 
C     BUILD  DENSITY MATRIX IN C.I-ACTIVE M.O BASIS, STORED IN W2. 
C     ------------------------------------------------------------ 
C 
C     INITIALIZE WITH THE OPPOSITE OF THE 'SCF' DENSITY. 
      DO 10 I=1,NCI2 
      W2(I,I)=-OCCA(I)*2.D0 
      DO 10 J=1,I-1 
   10 W2(I,J)=0.D0 
C 
C     ADD THE C.I. CORRECTION 
      DO 120 ID=1,NCI3 
      DO 120 JD=1,ID 
C     CHECK SPIN AGREEMENT 
      IF(NALPHA(ID).NE.NALPHA(JD)) GO TO 120 
      IX=0 
      IY=0 
      DO 20 J=1,NCI2 
      IX=IX+ABS(MICROA(J,ID)-MICROA(J,JD)) 
   20 IY=IY+ABS(MICROB(J,ID)-MICROB(J,JD)) 
C     CHECK NUMBER OF DIFFERING M.O. 
      IF(IX+IY.GT.2) GO TO 120 
      IF(IX.EQ.2) THEN 
C        DETERMINANTS ID AND JD DIFFER BY M.O I IN ID AND M.O J IN JD: 
         DO 30 I=1,NCI2 
   30    IF(MICROA(I,ID).NE.MICROA(I,JD)) GO TO 40 
   40    IJ=MICROB(I,ID) 
         DO 50 J=I+1,NCI2 
         IF(MICROA(J,ID).NE.MICROA(J,JD)) GO TO 60 
   50    IJ=IJ+MICROA(J,ID)+MICROB(J,ID) 
C        IJ GIVES THE SIGN OF THE PERMUTATION 
   60    W2(J,I)=W2(J,I)+VECTCI(ID)*VECTCI(JD)*FLOAT(1-2*MOD(IJ,2)) 
      ELSE IF(IY.EQ.2) THEN 
C        DETERMINANTS ID AND JD DIFFER BY M.O J IN ID AND M.O I IN JD: 
         DO 70 I=1,NCI2 
   70    IF(MICROB(I,ID).NE.MICROB(I,JD)) GO TO 80 
   80    IJ=0 
         DO 90 J=I+1,NCI2 
         IF(MICROB(J,ID).NE.MICROB(J,JD)) GO TO 100 
   90    IJ=IJ+MICROA(J,ID)+MICROB(J,ID) 
  100    IJ=IJ+MICROA(J,ID) 
         W2(J,I)=W2(J,I)+VECTCI(ID)*VECTCI(JD)*FLOAT(1-2*MOD(IJ,2)) 
      ELSE 
C        DETERMINANTS ID AND JD ARE IDENTICAL: 
         DO 110 I=1,NCI2 
  110    W2(I,I)=W2(I,I)+(MICROA(I,ID)+MICROB(I,ID))*VECTCI(ID)**2 
      ENDIF 
  120 CONTINUE 
C 
C     BACK TRANSFORM INTO A.O. BASIS. 
C     ------------------------------- 
C     P(C.I.) = P(SCF) + C * W2 * C' 
      DO 130 I=1,NCI2 
CDIR$ IVDEP 
      DO 130 J=1,I-1 
  130 W2(J,I)=W2(I,J) 
C     STEP 1: WORK = C * W2 
      CALL MXM (C(1,NCI1+1),N,W2,NCI2,WORK,NCI2) 
C     STEP 2: P = P + WORK * C' 
      IJ=0 
      DO 150 I=1,N 
      DO 150 J=1,I 
      IJ=IJ+1 
      SUM=0.D0 
      DO 140 K=1,NCI2 
  140 SUM=SUM+WORK(I,K)*C(J,NCI1+K) 
  150 P(IJ)=P(IJ)+SUM 
C     NOTE FROM D.L.: AT THIS POINT THE 'NATURAL ORBITALS' OF THIS STATE 
C     CAN BE OBTAINED STRAIGHTWAY AS EIGENVECTORS OF THE DENSITY MATRIX. 
      RETURN 
      END 
      SUBROUTINE MOLDAT 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
     2       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     3                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     4                NCLOSE,NOPEN,NDUMY,FRACT 
     5       /KEYWRD/ KEYWRD 
     6       /NATORB/ NATORB(107) 
     7       /CORE  / CORE(107) 
     8       /BETAS / BETAS(107),BETAP(107),BETAD(107) 
     9       /MOLORB/ USPD(MAXORB),PSPD(MAXORB) 
      COMMON /WMATRX/ WDUMMY(N2ELEC*3),KDUMMY,NBAND(NUMATM) 
     1       /VSIPS / VS(107),VP(107),VD(107) 
     2       /ONELEC/ USS(107),UPP(107),UDD(107) 
     3       /ATHEAT/ ATHEAT 
     4       /POLVOL/ POLVOL(107) 
     5       /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107) 
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     7                ,GSD(107),GPD(107),GDD(107) 
     8       /ALPHA / ALP(107) 
      COMMON /GAUSS / FN1(107),FN2(107) 
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107), 
     1ZPM(107), ZDM(107), BETASM(107), BETAPM(107), BETADM(107), 
     2ALPM(107), EISOLM(107), DDM(107), QQM(107), AMM(107), 
     3ADM(107), AQM(107), GSSM(107), GSPM(107), GPPM(107), 
     4GP2M(107), HSPM(107), POLVOM(107) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      PARAMETER (MDUMY=MAXPAR**2-MPACK) 
      COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MDUMY) 
* 
*  COMMON BLOCKS FOR MINDO/3 
* 
      COMMON /ONELE3 /  USS3(18),UPP3(18) 
     1       /ATOMI3 /  EISOL3(18),EHEAT3(18) 
     2       /EXPON3 /  ZS3(18),ZP3(18) 
* 
*  END OF MINDO/3 COMMON BLOCKS 
* 
      COMMON /EXPONT/ ZS(107),ZP(107),ZD(107) 
      COMMON /ATOMIC/ EISOL(107),EHEAT(107) 
      DIMENSION COORD(3,NUMATM) 
      CHARACTER*80 KEYWRD 
      LOGICAL DEBUG, UHF,EXCI, TRIP, MINDO3, BIRAD,PARAM,AM1, OPEN 
      SAVE
      DEBUG = (INDEX(KEYWRD,'MOLDAT').NE.0) 
      MINDO3= (INDEX(KEYWRD,'MINDO').NE.0) 
      UHF=(INDEX(KEYWRD,'UHF') .NE. 0) 
      AM1= (INDEX(KEYWRD,'AM1')+INDEX(KEYWRD,'PARAM').NE.0) 
      KHARGE=0 
      I=INDEX(KEYWRD,'CHARGE') 
      IF(I.NE.0) KHARGE=READA(KEYWRD,I) 
      NELECS=-KHARGE 
      NDORBS=0 
      ATHEAT=0.D0 
      EAT=0.D0 
      NUMAT=0 
      IF (   .NOT.   AM1   ) THEN 
* 
*    SWITCH IN MNDO PARAMETERS 
* 
         DO 10 I=1,107 
            IF(.NOT.MINDO3) POLVOL(I)=POLVOM(I) 
            FN1(I)=0.D0 
            ZS(I)=ZSM(I) 
            ZP(I)=ZPM(I) 
            ZD(I)=ZDM(I) 
            USS(I)=USSM(I) 
            UPP(I)=UPPM(I) 
            UDD(I)=UDDM(I) 
            BETAS(I)=BETASM(I) 
            BETAP(I)=BETAPM(I) 
            BETAD(I)=BETADM(I) 
            ALP(I)=ALPM(I) 
            EISOL(I)=EISOLM(I) 
            DD(I)=DDM(I) 
            QQ(I)=QQM(I) 
            AM(I)=AMM(I) 
            AD(I)=ADM(I) 
            AQ(I)=AQM(I) 
            GSS(I)=GSSM(I) 
            GPP(I)=GPPM(I) 
            GSP(I)=GSPM(I) 
            GP2(I)=GP2M(I) 
            HSP(I)=HSPM(I) 
   10    CONTINUE 
      ENDIF 
      IF( MINDO3 ) THEN 
         DO 20 I=1,17 
            IF(I.EQ.2.OR.I.EQ.10)GOTO 20 
            USS(I)=USS3(I) 
            UPP(I)=UPP3(I) 
            EISOL(I)=EISOL3(I) 
            EHEAT(I)=EHEAT3(I) 
            ZS(I)=ZS3(I) 
            ZP(I)=ZP3(I) 
   20    CONTINUE 
      ENDIF 
      IF(USS(1) .GT. -1.D0) THEN 
         WRITE(6,'(''  THE HAMILTONIAN REQUESTED IS NOT AVAILABLE IN'' 
     1,'' THIS PROGRAM'')') 
         STOP 
      ENDIF 
      IA=1 
      IB=0 
      NHEAVY=0 
      DO 70 II=1,NATOMS 
         IF(LABELS(II).EQ.99.OR.LABELS(II).EQ.107) GOTO 70 
         NUMAT=NUMAT+1 
         NAT(NUMAT)=LABELS(II) 
         NFIRST(NUMAT)=IA 
         NI=NAT(NUMAT) 
         ATHEAT=ATHEAT+EHEAT(NI) 
         EAT   =EAT   +EISOL(NI) 
         NELECS=NELECS+NINT(CORE(NI)) 
         IB=IA+NATORB(NI)-1 
         NMIDLE(NUMAT)=IB 
         IF(NATORB(NI).EQ.9)NDORBS=NDORBS+5 
         IF(NATORB(NI).EQ.9)NMIDLE(NUMAT)=IA+3 
         NLAST(NUMAT)=IB 
         NBAND(NUMAT)=NATORB(NI)*(NATORB(NI)+1)/2 
         USPD(IA)=USS(NI) 
         IF(IA.EQ.IB) GOTO 60 
         K=IA+1 
         K1=IA+3 
         DO 30 J=K,K1 
            USPD(J)=UPP(NI) 
   30    CONTINUE 
         NHEAVY=NHEAVY+1 
   40    IF(K1.EQ.IB)GOTO 60 
         K=K1+1 
         DO 50 J=K,IB 
   50    USPD(J)=UDD(NI) 
   60    CONTINUE 
   70 IA=IB+1 
      ATHEAT=ATHEAT-EAT*23.061D0 
      NORBS=NLAST(NUMAT) 
      IF(NORBS.GT.MAXORB)THEN 
         WRITE(6,'(//10X,''**** MAX. NUMBER OF ORBITALS:'',I4,/ 
     1            10X,''NUMBER OF ORBITALS IN SYSTEM:'',I4)') 
     2MAXORB,NORBS 
         STOP 
      ENDIF 
      NLIGHT=NUMAT-NHEAVY 
      N2EL=50*NHEAVY*(NHEAVY-1)+10*NHEAVY*NLIGHT+(NLIGHT*(NLIGHT-1))/2 
      IF(LABELS(NATOMS).EQ.107) N2EL=N2EL*2 
      IF(N2EL.GT.N2ELEC)THEN 
         WRITE(6,'(//10X,''**** MAX. NUMBER OF TWO-ELECTRON INTEGRALS:'' 
     1,I8,/ 
     2            10X,''NUMBER OF TWO ELECTRON INTEGRALS IN SYSTEM:'', 
     3I8)') 
     4N2ELEC,N2EL 
         STOP 
      ENDIF 
C 
C   NOW TO CALCULATE THE NUMBER OF LEVELS OCCUPIED 
      TRIP=(INDEX(KEYWRD,'TRIPLET').NE.0) 
      EXCI=(INDEX(KEYWRD,'EXCITED').NE.0) 
      BIRAD=(EXCI.OR.INDEX(KEYWRD,'BIRAD').NE.0) 
      IF(INDEX(KEYWRD,'C.I.') .NE. 0 .AND. UHF ) THEN 
         WRITE(6,'(//10X,''C.I. NOT ALLOWED WITH UHF '')') 
         STOP 
      ENDIF 
C 
C NOW TO WORK OUT HOW MANY ELECTRONS ARE IN EACH TYPE OF SHELL 
C 
      NALPHA=0 
      NBETA=0 
      NCLOSE=0 
      NOPEN=0 
      IF( UHF ) THEN 
         FRACT=1.D0 
         NBETA=NELECS/2 
         IF( TRIP ) THEN 
            IF(NBETA*2 .NE. NELECS) THEN 
               WRITE(6,'(//10X,''TRIPLET SPECIFIED WITH ODD NUMBER'', 
     1            '' OF ELECTRONS, CORRECT FAULT '')') 
               STOP 
            ELSE 
               WRITE(6,'(//'' TRIPLET STATE CALCULATION'')') 
               NBETA=NBETA-1 
            ENDIF 
         ENDIF 
         NALPHA=NELECS-NBETA 
         WRITE(6,'(//10X,''UHF CALCULATION, NO. OF ALPHA ELECTRONS ='',I 
     13,/27X,''NO. OF BETA  ELECTRONS ='',I3)')NALPHA,NBETA 
      ELSE 
C 
C   NOW TO DETERMINE OPEN AND CLOSED SHELLS 
C 
         OPEN=.FALSE. 
         IELEC=0 
         ILEVEL=0 
         IF( TRIP .OR. EXCI .OR. BIRAD ) THEN 
            IF( (NELECS/2)*2 .NE. NELECS) THEN 
               WRITE(6,'(//10X,''SYSTEM SPECIFIED WITH ODD NUMBER'', 
     1            '' OF ELECTRONS, CORRECT FAULT '')') 
               STOP 
            ENDIF 
            IF(BIRAD)WRITE(6,'(//'' SYSTEM IS A BIRADICAL'')') 
            IF(TRIP )WRITE(6,'(//'' TRIPLET STATE CALCULATION'')') 
            IF(EXCI )WRITE(6,'(//'' EXCITED STATE CALCULATION'')') 
            IELEC=2 
            ILEVEL=2 
         ELSEIF((NELECS/2)*2.NE.NELECS) THEN 
            IELEC=1 
            ILEVEL=1 
         ENDIF 
         IF(INDEX(KEYWRD,'QUART').NE.0) THEN 
            WRITE(6,'(//'' QUARTET STATE CALCULATION'')') 
            IELEC=3 
            ILEVEL=3 
         ENDIF 
         IF(INDEX(KEYWRD,'QUINT').NE.0) THEN 
            WRITE(6,'(//'' QUINTET STATE CALCULATION'')') 
            IELEC=4 
            ILEVEL=4 
         ENDIF 
         IF(INDEX(KEYWRD,'SEXT').NE.0) THEN 
            WRITE(6,'(//'' SEXTET STATE CALCULATION'')') 
            IELEC=5 
            ILEVEL=5 
         ENDIF 
         I=INDEX(KEYWRD,'OPEN(') 
         IF(I.NE.0)THEN 
            IELEC=READA(KEYWRD,I) 
            ILEVEL=READA(KEYWRD,I+7) 
         ENDIF 
         NCLOSE=NELECS/2 
         NOPEN = NELECS-NCLOSE*2 
         IF( IELEC.NE.0 )THEN 
            IF((NELECS/2)*2.EQ.NELECS .NEQV. 
     1                  (IELEC/2)*2.EQ.IELEC) THEN 
               WRITE(6,'('' IMPOSSIBLE NUMBER OF OPEN SHELL ELECTR 
     1ONS'')') 
               STOP 
            ENDIF 
            NCLOSE=NCLOSE-IELEC/2 
            NOPEN=ILEVEL 
            FRACT=IELEC*1.D0/ILEVEL 
            WRITE(6,'('' THERE ARE'',I3,'' DOUBLY FILLED LEVELS'') 
     1')NCLOSE 
         ENDIF 
         IF( .NOT. PARAM)WRITE(6,'(//10X,''RHF CALCULATION, NO. OF '', 
     1''DOUBLY OCCUPIED LEVELS ='',I3)')NCLOSE 
         IF (NOPEN.NE.0.AND.ABS(FRACT-1.D0).LT.1.D-4) 
     1WRITE(6,'(/27X,''NO. OF SINGLY OCCUPIED LEVELS ='',I3)')NOPEN 
         IF (NOPEN.NE.0.AND.ABS(FRACT-1.D0).GT.1.D-4) 
     1WRITE(6,'(/27X,''NO. OF LEVELS WITH OCCUPANCY'',F6.3,''  ='',I3)' 
     2)FRACT,NOPEN 
         NOPEN=NOPEN+NCLOSE 
      ENDIF 
      YY=FLOAT(KHARGE)/(NORBS+1.D-10) 
      L=0 
      DO 100 I=1,NUMAT 
         NI=NAT(I) 
         XX=1.D0 
         IF(NI.GT.2) XX=0.25D0 
         W=CORE(NI)*XX-YY 
         IA=NFIRST(I) 
         IC=NMIDLE(I) 
         IB=NLAST(I) 
         DO 80 J=IA,IC 
            L=L+1 
   80    PSPD(L)=W 
         DO 90 J=IC+1,IB 
            L=L+1 
   90    PSPD(L)=0.D0 
  100 CONTINUE 
C 
C   WRITE OUT THE INTERATOMIC DISTANCES 
C 
      CALL GMETRY(GEO,COORD) 
      RMIN=100.D0 
      L=0 
      DO 110 I=1,NUMAT 
         DO 110 J=1,I 
            L=L+1 
            RXYZ(L)=SQRT((COORD(1,I)-COORD(1,J))**2+ 
     1                     (COORD(2,I)-COORD(2,J))**2+ 
     2                     (COORD(3,I)-COORD(3,J))**2) 
            IF(RMIN.GT.RXYZ(L) .AND. I .NE. J .AND. 
     1 (NAT(I).LT.103 .OR. NAT(J).LT.103)) THEN 
               IMINR=I 
               JMINR=J 
               RMIN=RXYZ(L) 
            ENDIF 
  110 CONTINUE 
      IF (INDEX(KEYWRD,'PARAM')+INDEX(KEYWRD,'NOINTER') .EQ. 0) THEN 
         WRITE(6,'(//10X,''  INTERATOMIC DISTANCES'')') 
         CALL VECPRT(RXYZ,NUMAT) 
      ENDIF 
      IF(RMIN.LT.0.8D0.AND.INDEX(KEYWRD,'GEO-OK') .EQ.0) THEN 
         WRITE(6,120)IMINR,JMINR,RMIN 
  120    FORMAT(//,'   ATOMS',I3,' AND',I3,' ARE SEPARATED BY',F8.4, 
     1' ANGSTROMS.',/'   TO CONTINUE CALCULATION SPECIFY "GEO-OK"') 
         STOP 
      ENDIF 
      IF(.NOT. DEBUG) RETURN 
      WRITE(6,130)NUMAT,NORBS,NDORBS,NATOMS 
  130 FORMAT('   NUMBER OF REAL ATOMS:',I4,/ 
     1      ,'   NUMBER OF ORBITALS:  ',I4,/ 
     2      ,'   NUMBER OF D ORBITALS:',I4,/ 
     3      ,'   TOTAL NO. OF ATOMS:  ',I4) 
      WRITE(6,140)(USPD(I),I=1,NORBS) 
  140 FORMAT('   ONE-ELECTRON DIAGONAL TERMS',/,10(/,10F8.3)) 
      WRITE(6,150)(PSPD(I),I=1,NORBS) 
  150 FORMAT('   INITIAL P FOR ALL ATOMIC ORBITALS',/,10(/,10F8.3)) 
      RETURN 
      END 
      SUBROUTINE MULLIK(C,UHF,H,NORBS) 
      IMPLICIT REAL (A-H,O-Z) 
      LOGICAL UHF 
       INCLUDE "SIZES"
********************************************************************** 
*      MULLIK DOES A MULLIKEN POPULATION ANALYSIS 
*    INPUT     C      =  SQUARE ARRAY OF EIGENVECTORS. 
*              H      =  PACKED ARRAY OF ONE-ELECTRON MATRIX 
*    OUTPUT    FILE 13   WRITTEN IF KEYWORD "GRAPH" ACTIVATED 
*              OTHERWISE PRINT MULLIKEN POPULATION ON UNIT 6 
********************************************************************** 
      COMMON 
     1       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     2               ,NLAST(NUMATM), NORBX, NELECS,NALPHA,NBETA 
     3               ,NCLOSE,NOPEN,NDUMY,FRACT 
     4       /KEYWRD/ KEYWRD 
     5       /BETAS / BETAS(107),BETAP(107),BETAD(107) 
     6       /GEOM  / GEO(3,NUMATM) 
     7       /EXPONT/ ZS(107),ZP(107),ZD(107) 
     8       /SCRACH/ WORK(MAXORB*MAXORB) 
     9       /SCRAH2/ STORE(MPACK),HS(MPACK),VECS(MAXORB*MAXORB) 
     .               ,EIGS(MAXORB),IFACT(MAXORB) 
      CHARACTER KEYWRD*80 
      DIMENSION C(*), H(*) 
      DIMENSION XYZ(3,NUMATM) 
      EQUIVALENCE (WORK(1),XYZ(1,1)) 
      SAVE
      DO 10 I=1,NORBS 
   10 IFACT(I)=(I*(I-1))/2 
      IFACT(NORBS+1)=(NORBS*(NORBS+1))/2 
C 
C     CALCULATE THE OVERLAP MATRIX FROM H, BETAS, BETAP, 
C     STORED IN WORK AND STORE. 
C 
      DO 50 I=1,NUMAT 
         IA=NFIRST(I) 
         IB=NLAST(I) 
         BI=BETAS(NAT(I)) 
         DO 50 K=IA,IB 
            II=IFACT(K) 
            DO 30 J=1,I-1 
               JA=NFIRST(J) 
               JB=NLAST(J) 
               BJ=BETAS(NAT(J)) 
               DO 20 JJ=JA,JB 
                  WORK(II+JJ)=2.D0*WORK(II+JJ)/(BI+BJ) 
   20          BJ=BETAP(NAT(J)) 
   30       CONTINUE 
            DO 40 JJ=IA,K 
   40       WORK(II+JJ)=0.D0 
   50 BI=BETAP(NAT(I)) 
      DO 60 I=1,NORBS 
   60 WORK(IFACT(I+1))=1.D0 
      CALL SCOPY (IFACT(NORBS+1),WORK,1,STORE,1) 
C 
C     WORK OUT SQRT(OVERLAP), STORED IN HS 
C 
      CALL HQRII (WORK,NORBS,NORBS,EIGS,VECS) 
      J2=0 
      DO 70 I=1,NORBS 
         EIGS(I)=1.D0/SQRT(EIGS(I)) 
         IJ=I 
         J1=J2+1 
         J2=J2+NORBS 
         DO 70 JI=J1,J2 
            WORK(IJ)=EIGS(I)*VECS(JI) 
   70 IJ=IJ+NORBS 
      CALL MXM (VECS,NORBS,WORK,NORBS,HS,NORBS) 
      IF (INDEX(KEYWRD,'GRAPH').NE.0) THEN 
*        WRITE ON UNIT 13 THE FOLLOWING DATA FOR GRAPHICS CALCULATION, 
*        IN ORDER: 
*           NUMBER OF ATOMS, ORBITAL, ELECTRONS 
*           ALL ATOMIC COORDINATES 
*           ORBITAL COUNTERS 
*           ORBITAL EXPONENTS, S, P, AND D, AND ATOMIC NUMBERS 
*           EIGENVECTORS (M.O.S NOT RE-NORMALISED) 
*           INVERSE-SQUARE ROOT OF THE OVERLAP MATRIX. 
         CALL GMETRY(GEO,XYZ) 
         WRITE(13)NUMAT,NORBS,NELECS,((XYZ(I,J),J=1,NUMAT),I=1,3) 
         WRITE(13)(NLAST(I),NFIRST(I),I=1,NUMAT) 
         WRITE(13)(ZS(NAT(I)),I=1,NUMAT),(ZP(NAT(I)),I=1,NUMAT), 
     1         (ZD(NAT(I)),I=1,NUMAT),(NAT(I),I=1,NUMAT) 
         LINEAR=NORBS*NORBS 
         WRITE(13)(C (I),I=1,LINEAR) 
         WRITE(13)(HS(I),I=1,LINEAR) 
         RETURN 
      ENDIF 
C 
C OTHERWISE PERFORM MULLIKEN ANALYSIS 
C 
      CALL MXM (HS,NORBS,C,NORBS,VECS,NORBS) 
      CALL DENSIT(VECS,NORBS,NORBS,NCLOSE,NOPEN,FRACT,WORK) 
      DO 80 I=1,IFACT(NORBS+1) 
   80 WORK(I)=WORK(I)*STORE(I) 
      DO 110 I=1,NORBS 
         SUM=0 
         DO 90 J=1,I 
   90    SUM=SUM+WORK(IFACT(I)+J) 
         DO 100 J=I+1,NORBS 
  100    SUM=SUM+WORK(IFACT(J)+I) 
  110 WORK(IFACT(I+1))=SUM 
      CALL VECPRT(WORK,NORBS) 
      RETURN 
      END 
      SUBROUTINE NLLSQ(X,N,ESCF,GRAD) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION X(*),GRAD(*) 
************************************************************************ 
* 
*  NLLSQ IS A NON-DERIVATIVE, NONLINEAR LEAST-SQUARES MINIMIZER. IT USES 
*        BARTEL'S PROCEDURE TO MINIMISE A FUNCTION WHICH IS A SUM OF 
*        SQUARES. 
* 
*    ON INPUT N    = NUMBER OF UNKNOWNS 
*             X    = PARAMETERS OF FUNCTION TO BE MINIMIZED. 
* 
*    ON EXIT  X    = OPTIMISED PARAMETERS. 
* 
*    THE FUNCTION TO BE MINIMIZED IS THE SUM OF SQUARE OF RESIDALS 
*    RETURNED BY 'COMPFG'. 
*==> FOR PRESENT PURPOSE THE RESIDUALS ARE THE FIRST DERIVATIVES OF 
*    THE ENERGY ESCF. 
*    THE CALLING SEQUENCE OF COMPFG MUST BE THE FOLLOWING : 
*                  CALL COMPFG(XPARAM,ESCF,FAIL,EFS,.TRUE.) 
*                  SSQ=DOT(EFS,EFS,N) 
*    WHERE   EFS  IS A VECTOR WHICH  COMPFG  FILLS WITH THE N INDIVIDUAL 
*                 COMPONENTS OF THE ERROR FUNCTION AT THE POINT X 
*            SSQ  IS THE VALUE OF THE SUM OF THE  EFS  SQUARED 
*            FAIL IS A FLAG TURNED TO .TRUE. IF EFS IS NOT RELIABLE. 
*    IN THIS FORMULATION OF NLLSQ M AND N ARE THE SAME. 
*    THE PRECISE DEFINITIONS OF THESE TWO QUANTITIES IS: 
* 
*     N = NUMBER OF PARAMETERS TO BE OPTIMIZED. 
*     M = NUMBER OF REFERENCE FUNCTIONS. M MUST BE GREATER THEN, OR 
*         EQUAL TO, N 
************************************************************************ 
C     Q = ORTHOGONAL MATRIX   (M BY M) 
C     R = RIGHT-TRIANGULAR MATRIX   (M BY N) 
C     MXCNT(1) = MAX ALLOW OVERALL FUN EVALS 
C     MXCNT(2) = MAX ALLOW NO OF FNC EVALS PER LIN SEARCH 
C     TOLS1 = RELATIVE TOLERANCE ON X OVERALL 
C     TOLS2 = ABSOLUTE TOLERANCE ON X OVERALL 
C     TOLS5 = RELATIVE TOLERANCE ON X FOR LINEAR SEARCHES 
C     TOLS6 = ABSOLUTE TOLERANCE ON X FOR LINEAR SEARCHES 
C     NRST = NUMBER OF CYCLES BETWEEN SIDESTEPS 
C     ********** 
      COMMON /TIME  / TIME0 
     1       /MESAGE/ IFLEPO,IITER 
     2       /KEYWRD/ KEYWRD 
     3       /LAST  / LAST 
     4       /PRECI / SCFCV,SCFTOL,EG(9),KDUM(MAXPAR) 
     4       /OPTIM / IMP,IMP0,LEC,IPRT,Q(MAXPAR,MAXPAR),EFSLST(MAXPAR) 
     5               ,R(MAXPAR,MAXPAR),XLAST(MAXPAR),ALF,SSQ,PN 
     6               ,ICYC,IRST,JRST,NDOUBL,M,NCOUNT 
     7               ,Y(MAXPAR),EFS(MAXPAR),P(MAXPAR) 
      LOGICAL RESTRT, FAIL 
      CHARACTER*80 KEYWRD 
      CHARACTER SPACE*1, CHDOT*1, ZERO*1, NINE*1, CH*1 
      DATA SPACE,CHDOT,ZERO,NINE /' ','.','0','9'/ 
      SAVE
C     ********** 
C     READ KEYWORDS AND OVERWRITE STANDARD OPTIONS 
C     ********** 
      RESTRT=(INDEX(KEYWRD,'REST') .NE. 0) 
C     LENGTH OF /OPTIM/ TO BE SAVED FOR RESTART ACCORDING TO 
C     /OPTIM/ I1(MAXPAR,LEN1),I2(LEN2). 
      LEN1=(2*MAXPAR+2)*2 
      LEN2=           3*2 + 8 
      MXCYCL=100 
      I=INDEX(KEYWRD,'CYCLES=') 
      IF (I.NE.0) MXCYCL=READA(KEYWRD,I) 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF (IMP.NE.0) IMP=READA(KEYWRD,IMP) 
      GNORM=1.D0 
      IF(INDEX(KEYWRD,'PREC').NE.0) GNORM=GNORM*0.1D0 
      I= INDEX(KEYWRD,'GNORM=') 
      IF (I.NE.0) GNORM=READA(KEYWRD,I) 
      TOLS1=1.D-12 
      TOLS2=1.D-10 
      TOLS5=1.D-6 
      TOLS6=1.D-3 
      NRST=4 
      YMAXST=1.D0 
      TLEFT=3600 
      I=INDEX(KEYWRD,' T=') 
      IF(I.NE.0) THEN 
         TIM=READA(KEYWRD,I) 
         DO 10 J=I+3,80 
            CH=KEYWRD(J:J) 
            IF( CH .NE. CHDOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) TH 
     1EN 
               IF( CH .EQ. 'M') TIM=TIM*60 
               GOTO 20 
            ENDIF 
   10    CONTINUE 
   20    TLEFT=TIM 
      ENDIF 
      SUM=TLEFT 
      CALL SECOND (TFLY) 
      TLEFT=TLEFT-TFLY+TIME0 
C     ********** 
C     SET UP COUNTERS AND SWITCHES 
C     ********** 
      IFLEPO=11 
      M=N 
      NDOUBL=N 
      LAST=0 
      NTO=N/6 
      IFRTL=0 
      NREM=N-(NTO*6) 
      IREPET=0 
      NSST=0 
      IF(IXSO.EQ.0) IXSO=N 
      NP1 = N+1 
      NP2 = N+2 
      ICYC = 0 
      IRST = 0 
      JRST = 1 
      EPS =TOLS5 
      T = TOLS6 
C     ********** 
C     GET STARTING-POINT FUNCTION VALUE 
C     SET UP ESTIMATE OF INITIAL LINE STEP 
C     ********** 
      IF(RESTRT) THEN 
         CALL SAVOPT(LEN1,LEN2,.TRUE.) 
         MXCYCL=MXCYCL+ICYC 
         CALL SCOPY (N,XLAST,1,X,1) 
         CALL SECOND (TIME1) 
         GOTO 80 
      ENDIF 
      CALL COMPFG(X,ESCF,FAIL,EFSLST,.TRUE.) 
      SSQ=DOT(EFSLST,EFSLST,N) 
      RMS=SQRT(SSQ/FLOAT(N)) 
      GNORM=MAX(GNORM,SQRT(FLOAT(N))*(EG(1)+EG(2)+EG(3))) 
      WRITE(IPRT,'('' MINIMIZATION OF THE GRADIENT NORM BY NLLSQ ...'' 
     ./''    MAXIMUM NUMBER OF CYCLES         ='',I5 
     ./''    ALLOWED TIME                     ='',F8.2,'' SECONDS'' 
     ./''    INITIAL RMS GRADIENT             ='',F8.2 
     ./''    CV THRESHOLD ON THE RMS GRADIENT ='',F8.2 
     ./''    NUMBER OF OPTIMIZED VARIABLES    ='',I5 
     .)') MXCYCL,SUM,RMS,GNORM,N 
      IF(FAIL) STOP 
      NCOUNT = 1 
      DO 50 I=1,M 
         DO 30 J=1,N 
   30    R(I,J) = 0.0D0 
         DO 40 J=1,M 
   40    Q(J,I) = 0.0D0 
      R(I,I)=1.D0 
   50 Q(I,I)=1.D0 
      TEMP = DOT(X,X,N) 
      ALF = 100.0D0*(EPS*SQRT(TEMP)+T) 
C     ********** 
C     MAIN LOOP 
C     ********** 
      CALL SECOND (TIME1) 
   80 CONTINUE 
C     ********** 
C     UPDATE COUNTERS AND TEST FOR PRINTING THIS CYCLE 
C     ********** 
      IFRTL=IFRTL+1 
      ICYC = ICYC+1 
      IRST = IRST+1 
C     ********** 
C     SET  PRT,  THE LEVENBERG-MARQUARDT PARAMETER. 
C     ********** 
      PRT = SQRT(SSQ) 
C     ********** 
C     IF A SIDESTEP IS TO BE TAKEN, GO TO 31 
C     ********** 
      IF (IRST .GE. NRST)  GO TO 230 
C     ********** 
C     SOLVE THE SYSTEM    Q*R*P = -EFSLST    IN THE LEAST-SQUARES SENSE 
C     ********** 
      NSST=0 
      DO 100 I=1,M 
  100 EFS(I) = -DOT(Q(1,I),EFSLST,M) 
      DO 110 J=1,N 
         JJ = NP1-J 
         DO 110 I=1,J 
            II = NP2-I 
  110 R(II,JJ) = R(I,J) 
      DO 180 I=1,N 
         I1 = I+1 
         Y(I) = PRT 
         EFSSS=0.0D0 
         IF (I.LT.N) THEN 
            DO 120 J=I1,N 
  120       Y(J) = 0.0D0 
         ENDIF 
         DO 170 J=I,N 
            II = NP2-J 
            JJ = NP1-J 
            IF (ABS(Y(J)) .GE. ABS(R(II,JJ))) THEN 
               TEMP = Y(J)*SQRT(1.0D0+(R(II,JJ)/Y(J))**2) 
            ELSE 
               TEMP = R(II,JJ)*SQRT(1.0D0+(Y(J)/R(II,JJ))**2) 
            ENDIF 
            SIN = R(II,JJ)/TEMP 
            COS = Y(J)/TEMP 
            R(II,JJ) = TEMP 
            TEMP = EFS(J) 
            EFS(J)=SIN*TEMP+COS*EFSSS 
            EFSSS=SIN*EFSSS-COS*TEMP 
            IF (J .GE. N)  GO TO 180 
            J1 = J+1 
            DO 160 K=J1,N 
               JJ = NP1-K 
               TEMP = R(II,JJ) 
               R(II,JJ) = SIN*TEMP+COS*Y(K) 
  160       Y(K) = SIN*Y(K)-COS*TEMP 
  170    CONTINUE 
  180 CONTINUE 
      P(N) = EFS(N)/R(2,1) 
      DO 210 I=N,1,-1 
         TEMP = EFS(I) 
         K = I+1 
         II = NP2-I 
         DO 200 J=K,N 
         JJ = NP1-J 
  200    TEMP = TEMP-R(II,JJ)*P(J) 
         JJ = NP1-I 
  210 P(I) = TEMP/R(II,JJ) 
      GO TO 250 
C     ********** 
C     SIDESTEP SECTION 
C     ********** 
  230 JRST = JRST+1 
      NSST=NSST+1 
      IF(NSST.GE.IXSO) GO TO 670 
      IF (JRST .GT. N)  JRST=2 
      IRST = 0 
C     ********** 
C     PRODUCTION OF A VECTOR ORTHOGONAL TO THE LAST P-VECTOR 
C     ********** 
      WORK = PN*(ABS(P(1))+PN) 
      TEMP = P(JRST) 
      P(1) = TEMP*(P(1)+SIGN(PN,P(1))) 
      DO 240 I=2,N 
  240 P(I) = TEMP*P(I) 
      P(JRST) = P(JRST)-WORK 
C     ********** 
C     COMPUTE NORM AND NORM-SQUARE OF THE P-VECTOR 
C     ********** 
  250 PNLAST = PN 
      PN=0.D0 
      PN2 = 0.0D0 
      DO 260 I=1,N 
         PN=PN+ABS(P(I)) 
  260 PN2 = PN2+P(I)**2 
      IF(PN.LT.1.D-20) THEN 
         WRITE(IPRT,'('' SYSTEM DOES NOT APPEAR TO BE OPTIMIZABLE.'',/ 
     1,'' THIS CAN HAPPEN IF (A) IT WAS OPTIMIZED TO BEGIN WITH'',/ 
     2,'' OR                 (B) IT IS NEITHER A GROUND NOR A'', 
     3'' TRANSITION STATE'')') 
         CALL GEOUT 
         STOP 
      ENDIF 
      IF(PN2.LT.1.D-20)PN2=1.D-20 
      PN = SQRT(PN2) 
      IF(ALF.GT.1.D20)ALF=1.D20 
      IF(ICYC .GT. 1) THEN 
         ALF=ALF*1.D-20*PNLAST/PN 
         IF(ALF.GT.1.D10)        ALF=1.D10 
         ALF=ALF*1.D20 
      ENDIF 
      TTMP=ALF*PN 
      IF(TTMP.LT.0.0001D0) ALF=0.001D0/PN 
      CALL SCOPY (N,X,1,EFS,1) 
C     ********** 
C     PERFORM LINE-MINIMIZATION FROM POINT X IN DIRECTION P OR -P 
C     ********** 
      SSQLST = SSQ 
      CALL SCOPY (N,X,1,XLAST,1) 
      CALL LOCMIN(M,X,N,P,EFS,IERR,ESCF) 
      IF(SSQLST .LT. SSQ ) THEN 
         IF(IERR .EQ. 0)      SSQ=SSQLST 
         CALL SCOPY (N,XLAST,1,X,1) 
         IRST=NRST 
         PN=PNLAST 
         TIME2=TIME1 
         CALL SECOND (TIME1) 
         TCYCLE=TIME1-TIME2 
         TLEFT=TLEFT-TCYCLE 
         IF(TLEFT .GT. TCYCLE*2) GO TO 80 
         GOTO 630 
      ENDIF 
      IREPET=0 
C     ********** 
C     PRODUCE THE VECTOR   R*P 
C     ********** 
      DO 300 I=1,N 
  300 Y(I) = SDOT(N-I+1,R(I,I),MAXPAR,P(I),1) 
C     ********** 
C     PRODUCE THE VECTOR ... 
C                  Y  =    (EFS-EFSLST-ALF*Q*R*P)/(ALF*(NORMSQUARE(P)) 
C     COMPUTE NORM OF THIS VECTOR AS WELL 
C     ********** 
      WORK = ALF*PN2 
      YN = 0.0D0 
      DO 310 I=1,M 
         TEMP = (EFS(I)-EFSLST(I)-ALF*SDOT(N,Q(I,1),MAXPAR,Y,1)) 
         EFSLST(I) = EFS(I) 
         YN = YN+TEMP**2 
  310 EFS(I) = TEMP/WORK 
      YN = SQRT(YN)/WORK 
C     ********** 
C     THE BROYDEN UPDATE   NEW MATRIX = OLD MATRIX + Y*(P-TRANS) 
C     HAS BEEN FORMED.  IT IS NOW NECESSARY TO UPDATE THE  QR DECOMP. 
C     FIRST LET    Y = (Q-TRANS)*Y. 
C     ********** 
      DO 320 I=1,M 
  320 Y(I) = DOT(Q(1,I),EFS,M) 
C     ********** 
C     REDUCE THE VECTOR Y TO A MULTIPLE OF THE FIRST UNIT VECTOR USING 
C     A HOUSEHOLDER TRANSFORMATION FOR COMPONENTS N+1 THROUGH M AND 
C     ELEMENTARY ROTATIONS FOR THE FIRST N+1 COMPONENTS.  APPLY ALL 
C     TRANSFORMATIONS TRANSPOSED ON THE RIGHT TO THE MATRIX Q, AND 
C     APPLY THE ROTATIONS ON THE LEFT TO THE MATRIX R. 
C     THIS GIVES    (Q*(V-TRANS))*((V*R) + (V*Y)*(P-TRANS)),    WHERE 
C     V IS THE COMPOSITE OF THE TRANSFORMATIONS.  THE MATRIX 
C     ((V*R) + (V*Y)*(P-TRANS))    IS UPPER HESSENBERG. 
C     ********** 
      IF (M .LE. NP1)  GO TO 410 
C 
C THE NEXT THREE LINES WERE INSERTED TO TRY TO GET ROUND OVERFLOW BUGS. 
C 
      CONST=1.D-12 
      DO 330 I=NP1,M 
  330 CONST=MAX(ABS(Y(NP1)),CONST) 
      YTAIL = 0.0D0 
      DO 340 I=NP1,M 
  340 YTAIL = YTAIL+(Y(I)/CONST)**2 
      YTAIL = SQRT(YTAIL)*CONST 
      BET = (1.0D25/YTAIL)/(YTAIL+ABS(Y(NP1))) 
      Y(NP1) = SIGN (YTAIL+ABS(Y(NP1)),Y(NP1)) 
      DO 400 I=1,M 
         TMP = 0.0D0 
         DO 380 J=NP1,M 
  380    TMP = TMP+Q(I,J)*Y(J)*1.D-25 
         TMP = BET*TMP 
         DO 390 J=NP1,M 
  390    Q(I,J) = Q(I,J)-TMP*Y(J) 
  400 CONTINUE 
      Y(NP1) = YTAIL 
      I = NP1 
      GO TO 420 
  410 CONTINUE 
      I = M 
  420 CONTINUE 
  430 J = I 
      I = I-1 
      IF (I.LE.0)  GO TO 500 
      IF (Y(J).EQ.0.D0)  GO TO 430 
      IF (ABS(Y(I)) .GE. ABS(Y(J))) THEN 
         TEMP = ABS(Y(I))*SQRT(1.0D0+(Y(J)/Y(I))**2) 
      ELSE 
         TEMP = ABS(Y(J))*SQRT(1.0D0+(Y(I)/Y(J))**2) 
      ENDIF 
      COS = Y(I)/TEMP 
      SIN = Y(J)/TEMP 
      Y(I) = TEMP 
      DO 480 K=1,M 
         TEMP = COS*Q(K,I)+SIN*Q(K,J) 
         WORK = -SIN*Q(K,I)+COS*Q(K,J) 
         Q(K,I) = TEMP 
  480 Q(K,J) = WORK 
      IF (I .GT. N)  GO TO 430 
      R(J,I) = -SIN*R(I,I) 
      R(I,I) = COS*R(I,I) 
      IF (J .GT. N)  GO TO 430 
      DO 490 K=J,N 
         TEMP = COS*R(I,K)+SIN*R(J,K) 
         WORK = -SIN*R(I,K)+COS*R(J,K) 
         R(I,K) = TEMP 
  490 R(J,K) = WORK 
      GO TO 430 
C     ********** 
C     REDUCE THE UPPER-HESSENBERG MATRIX TO UPPER-TRIANGULAR FORM 
C     USING ELEMENTARY ROTATIONS.  APPLY THE SAME ROTATIONS, TRANSPOSED, 
C     ON THE RIGHT TO THE MATRIX  Q. 
C     ********** 
  500 CALL SAXPY (N,YN,P,1,R,MAXPAR) 
      JEND = NP1 
      IF (M .EQ. N)  JEND=N 
      DO 530 J=2,JEND 
         I = J-1 
         IF (R(J,I).EQ.0.D0)  GO TO 530 
         IF (ABS(R(I,I)) .GE. ABS(R(J,I))) THEN 
            TEMP = ABS(R(I,I))*SQRT(1.0D0+(R(J,I)/R(I,I))**2) 
         ELSE 
            TEMP = ABS(R(J,I))*SQRT(1.0D0+(R(I,I)/R(J,I))**2) 
         ENDIF 
         COS = R(I,I)/TEMP 
         SIN = R(J,I)/TEMP 
         R(I,I) = TEMP 
         IF (J .LE. N) THEN 
            DO 510 K=J,N 
            TEMP = COS*R(I,K)+SIN*R(J,K) 
            WORK = -SIN*R(I,K)+COS*R(J,K) 
            R(I,K) = TEMP 
  510       R(J,K) = WORK 
         ENDIF 
         DO 520 K=1,M 
         TEMP = COS*Q(K,I)+SIN*Q(K,J) 
         WORK = -SIN*Q(K,I)+COS*Q(K,J) 
         Q(K,I) = TEMP 
  520    Q(K,J) = WORK 
  530 CONTINUE 
C     ********** 
C     CHECK THE STOPPING CRITERIA 
C     ********** 
      TEMP = DOT(X,X,N) 
      TOLX = TOLS1*SQRT(TEMP)+TOLS2 
      IF (SQRT(ALF*PN2) .LE. TOLX)  GO TO 650 
      IF(SSQ.GE.GNORM*SQRT(FLOAT(N))) GO TO 610 
C***** 
C     The stopping criterion is that no individual gradient be 
C     greater than 2.5*GNORM i.e 2.5 times the standard deviation 
C***** 
      DO 600 I=1,N 
         IF(ABS(EFSLST(I)).GE.2.5D0*GNORM) GO TO 610 
  600 CONTINUE 
      RMS=SSQ/SQRT(FLOAT(N)) 
      GO TO 660 
  610 CONTINUE 
      IF (ICYC .GE. MXCYCL)  THEN 
         IFLEPO=12 
         GOTO 880 
      ENDIF 
      TIME2=TIME1 
      CALL SECOND (TIME1) 
      TCYCLE=TIME1-TIME2 
      TLEFT=TLEFT-TCYCLE 
      IF (IMP.GT.0) WRITE(IPRT,1000)ICYC,TCYCLE,TLEFT,SQRT(SSQ),ESCF 
      IF(TLEFT .GT. TCYCLE*2) GO TO 80 
  630 CALL SCOPY (N,X,1,XLAST,1) 
      CALL SAVOPT(LEN1,LEN2,.FALSE.) 
      STOP 
  650 WRITE (IPRT,1020)  NCOUNT 
      GOTO 880 
  660 WRITE (IPRT,1030)  NCOUNT,SSQ,RMS 
      GOTO 880 
  670 CONTINUE 
      WRITE(IPRT,1010) IXSO 
      GOTO 880 
  880 LAST=1 
      CALL COMPFG(X,ESCF,FAIL,GRAD,.TRUE.) 
      RETURN 
 1000 FORMAT(' CYCLE:',I5,' TIME:',F7.2,' TIME LEFT:',F9.1, 
     1' GRAD.:',F10.3,' HEAT:',G14.7) 
 1010 FORMAT(1H ,5X,'ATTEMPT TO GO DOWNHILL IS UNSUCCESSFUL AFTER',I5,5X 
     1,'ORTHOGONAL SEARCHES') 
 1020 FORMAT('0TEST ON X SATISFIED, NUMBER OF FUNCTION CALLS = ',I5) 
 1030 FORMAT('0TEST ON SSQ SATISFIED, NUMBER OF FUNCTION CALLS = ',I5 
     ./' SSQ =',F8.3,5X,'RMS =',F8.3) 
      END 
      SUBROUTINE NUCHAR(LINE,VALUE,NVALUE) 
      IMPLICIT REAL (A-H,O-Z) 
************************************************************************ 
* 
*   NUCHAR  DETERMINS AND RETURNS THE REAL VALUES OF ALL NUMBERS 
*           FOUND IN 'LINE'. ALL CONNECTED SUBSTRINGS ARE ASSUMED 
*           TO CONTAIN NUMBERS 
*   ON ENTRY LINE    = CHARACTER STRING 
*   ON EXIT  VALUE   = ARRAY OF NVALUE REAL VALUES 
* 
************************************************************************ 
      DIMENSION VALUE(40),ISTART(40) 
      CHARACTER*80 LINE 
      CHARACTER*1 COMMA,SPACE 
      LOGICAL LEADSP 
      DATA COMMA,SPACE/',',' '/ 
      SAVE
* 
* CLEAN OUT COMMAS. (WARNING, TABS ARE NOT UNDERSTOOD IN EBCDIC) 
* 
      DO 10 I=1,80 
   10 IF(LINE(I:I).EQ.COMMA)LINE(I:I)=SPACE 
* 
* FIND INITIAL DIGIT OF ALL NUMBERS, CHECK FOR LEADING SPACES FOLLOWED 
*     BY A CHARACTER 
* 
      LEADSP=.TRUE. 
      NVALUE=0 
      DO 20 I=1,80 
         IF (LEADSP.AND.LINE(I:I).NE.SPACE) THEN 
            NVALUE=NVALUE+1 
            ISTART(NVALUE)=I 
         END IF 
         LEADSP=(LINE(I:I).EQ.SPACE) 
   20 CONTINUE 
* 
* FILL NUMBER ARRAY 
* 
      DO 30 I=1,NVALUE 
         VALUE(I)=READA(LINE,ISTART(I)) 
   30 CONTINUE 
      RETURN 
      END 
      SUBROUTINE PATH (IND,X,F,G,N) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C--------------- 
C     MAIN ROUTINE TO FOLLOW A REACTION PATH (EG A -GRADIENT TRAJECTORY) 
C     STARTING (OR NOT) FROM A SADDLE. 
C--------------- 
C     REQUIRED SUBROUTINES : 
C        PATH1 : SELF STARTING MIXED INTEGRATOR 
C        PATH2 : INTERPOLATION DEDICATED TO PATH1 
C        DOT,SUPDOT,SCOPY,MXM,DIAGIV : MATHEMATICAL PACKAGE 
C        READVT: READ A VECTOR OF DATA 
C        SAVOPT: SAVE/RESTART ROUTINE 
C--------------- 
C     THE COMMON/OPTIM/        INCLUDES THE WHOLE DATA REQUIRED... 
C     NOTE...THIS STRUCTURE ALLOWS TO OVERLAY THIS BRANCH (PATH1,PATH2, 
C     DOT,SUPDOT,DIAGIV) WITH THOSE OF THE ENERGY AND GRADIENT (COMPFG) 
C     MOREOVER,ONLY THIS SUBROUTINE MUST BE MODIFIED FOR IMPLEMENTATION 
C     OF THE ALGORITHM IN ANOTHER PACKAGE . 
C--------------- 
C 
      COMMON /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,HESSE(MAXHES),P(MAXPAR,MAXPAR) 
     .               ,DY2(MAXPAR),POND(MAXPAR),D(MAXPAR),XOLD(MAXPAR) 
     .               ,TVOLD(MAXPAR),Y1(MAXPAR,2),Y2(MAXPAR,2) 
     .               ,Y3(MAXPAR,2),C(MAXPAR,4),Y4(MAXPAR,2) 
     .               ,Y(MAXPAR,2),YE(MAXPAR),DX(MAXPAR) 
     .               ,HPREC,HMIN,H,HMAX,HTOT,DHTOT,RMS,EOLD,CRITE 
     .               ,Y1NORM,Y2NORM,Y3NORM,ETOL,TOLE 
     .               ,ICALL,ITERAT,IS,IPRINT,ITE,NBOUND,NBOULO 
     .               ,KONV,HUPDAT,RESET,INTERP 
     .               ,IMETH,SAVE(MAXPAR) 
      COMMON /TIME  / TIME0 
      COMMON /MESAGE/ IFLEPO 
      COMMON /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
      DIMENSION X(N),G(N) 
      LOGICAL KONV,HUPDAT,RESET,INTERP,FAIL,REST,SHOWT,RESTO 
      SAVE
C 
      TLEFT=3600. 
      I=INDEX(KEYWRD,' T=') 
      IF(I.NE.0) TLEFT=READA(KEYWRD,I) 
      SHOWT=INDEX(KEYWRD,'TIME').NE.0 
      REST= INDEX(KEYWRD,'REST').NE.0 
      RESTO=.FALSE. 
C     FOR SAVE/RESTART : EQUIVALENCED /OPTIM/ I1(MAXPAR,LEN1),I2(LEN2) 
      LEN1=2*(MAXPAR+22) 
      LEN2=2*(MAXHES+14) + 16 
      IF ( REST ) THEN 
         CALL SAVOPT(LEN1,LEN2,.TRUE.) 
         CALL SCOPY (N,SAVE,1,X,1) 
      ENDIF 
C    ... 
C     FIRST CALL TO GRADIENT, THUS DEFINING THE ACCURACY DATA IN /PRECI/ 
      CALL SECOND (TIME) 
      CALL COMPFG(X,F,FAIL,G,.TRUE.) 
C     ... 
C     READ OPTIONS AND TAKE DEFAULT VALUES 
C     ... 
      ITV  =INDEX(KEYWRD,' T.V') 
      IPOND=INDEX(KEYWRD,' WEIG') 
      LIMIT=100 
      EPS=5.D0/SQRT(FLOAT(N)) 
      HMIN=0.04D0 
      ETOL=SCFCV*1.D1 
      TOLE=F+10.D0 
      IF(INDEX(KEYWRD,'PRECI') .NE. 0) THEN 
         EPS=EPS*0.1D0 
         LIMIT=LIMIT*10 
         HMIN=HMIN*0.1D0 
      ENDIF 
      HPREC=HMIN*0.50D0 
      HMAX=HMIN*1.D1 
C     OVERWRITE DEFAULT VALUES IF PROVIDED 
      I=INDEX(KEYWRD,'CYCLES=') 
      IF(I.NE.0) LIMIT=READA(KEYWRD,I) 
      I=INDEX(KEYWRD,'GNORM=') 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF(IMP.NE.0) IMP=READA(KEYWRD,IMP) 
      IF(I.NE.0) EPS=ABS(READA(KEYWRD,I))/SQRT(FLOAT(N)) 
      IF ( REST ) GO TO 40 
      KONV=.TRUE. 
      IF(IPOND.EQ.0) THEN 
C     IF NO WEIGHT ARE PROVIDED,SET EACH WEIGHT=1. 
         DO 2 I=1,N 
    2    POND(I)=1.D0 
      ELSE 
         CALL READVT (LEC,IPRT,POND,N) 
      ENDIF 
      DO 3 I=1,N 
      J=KTYP(I) 
      KONV=POND(I).GT.0.D0.AND.KONV 
    3 C(I,1)=EG(J) 
      EPS=MAX(EPS,3.D0*SQRT(DOT(C,C,N)/FLOAT(N))) 
      IF(ITV.EQ.0) THEN 
C        IF NO TRANSITION VECTOR IS PROVIDED, 
C        SELECT THE WEIGTHED STEEPEST DESCENT. 
         DO 4 I=1,N 
    4    YE(I)=-G(I)/POND(I) 
      ELSE 
         CALL READVT (LEC,IPRT,YE,N) 
      ENDIF 
      DO 5 I=1,N 
    5 YE(I)=YE(I)/POND(I) 
      TVNORM=1.D0/SQRT(DOT(YE,YE,N)) 
      DO 6 I=1,N 
      DY2(I)=3.D0*C(I,1)/POND(I) 
    6 YE(I)=YE(I)*TVNORM 
      IMETH=8 
      GO TO 30 
C 
C     ITERATION WITH RESTORE OF DENSITY MATRICES IF SCF DIVERGENCE 
C 
   20 CALL SECOND (TIME) 
      CALL COMPFG(X,F,FAIL,G,.TRUE.) 
   30 IF(FAIL) GO TO 50 
      RESTO=.FALSE. 
      CALL SECOND (TFLY) 
      TIME=TFLY-TIME 
      IF(SHOWT) WRITE(IPRT,110) TIME,TFLY-TIME0 
      IF(TLEFT-2.D0*TIME.LT.TFLY-TIME0) THEN 
         WRITE(IPRT,120) TIME 
         CALL SCOPY (N,X,1,SAVE,1) 
         CALL SAVOPT(LEN1,LEN2,.FALSE.) 
         IMETH=21 
         GO TO 41 
      ENDIF 
   40 CALL PATH1   (X,F,G,N,EPS,LIMIT,IMETH,P) 
      IF(IMETH.LT.20) GO TO 20 
   41 IF(IMETH.EQ.20) THEN 
         IND=1 
         IFLEPO=11 
      ELSE 
         IND=0 
         IFLEPO=12 
      ENDIF 
      RETURN 
   50 WRITE(IPRT,100) 
      IF (RESTO) THEN 
         IMETH=21 
         GO TO 41 
      ELSE 
         RESTO=.TRUE. 
         GO TO 20 
      ENDIF 
  100 FORMAT(' *** WARNING FROM ''PATH'' *** SCF PROBLEMS...'/ 
     .       ' RESTORE DENSITY MATRICES AND TRY AGAIN') 
  110 FORMAT(' ELAPSED TIME IN ''PATH'' =',F9.3,'   INTEGRAL=',F10.3, 
     .       ' SECOND') 
  120 FORMAT(' TYPICAL TIME FOR ONE CYCLE OF ''PATH''=',F9.3) 
      END 
      SUBROUTINE READVT (LEC,IPRT,VECT,NDIM) 
      IMPLICIT REAL (A-H,O-Z) 
C     UNFORMATED READ OF THE VECTOR VECT OF LENGTH NDIM ON UNIT # LEC. 
C     ERROR MESSAGES PRINTED ON UNIT IPRT. 
C     THE DATA MUST BE SEPARATED BY AT LEAST ONE OF THESE CHARACTERS : 
C     BLANK   COMMA   SEMI-COLUMN   SLASH, 
C     AND A VALUE MUST NOT STAND ON MORE THAN ONE 'CARD'. 
C     NOTE ... A BLANK 'CARD' WILL NOT BE INTERPRETED AS ZERO, 
C                                  BUT 
C              'nn*vv' IS ALLOWED, FULFILLING THE VECTOR VECT WITH 
C              nn CONSECUTIVE VALUE vv. 
      DIMENSION VECT(*) 
      CHARACTER LINE*80,SPACE*1,COMMA*1,SCOLUM*1,SLASH*1,STAR*1 
      LOGICAL LEADSP,FLAG 
      DATA COMMA,SPACE,SCOLUM,SLASH,STAR 
     ./     ',' , ' ' , ';'  , '/' , '*'                       / 
      SAVE
C 
      IPOS=0 
   10 READ (LEC,'(A)',END=40,ERR=50) LINE 
C     CONVERT ALL ALLOWED SEPARATOR INTO SPACE 
      DO 20 I=1,80 
      IF(LINE(I:I).EQ.COMMA .OR. LINE(I:I).EQ.SCOLUM .OR. 
     .   LINE(I:I).EQ.SLASH                           ) LINE(I:I)=SPACE 
   20 CONTINUE 
C     FULFIL THE VECTOR VECT 
      LEADSP=.TRUE. 
      FLAG=.FALSE. 
      DO 30 I=1,80 
      LEADSP=LEADSP.AND.LINE(I:I).NE.SPACE.AND.LINE(I:I).NE.STAR 
      IF(LEADSP) THEN 
         IPOS=IPOS+1 
         VECT(IPOS)=READA(LINE,I) 
         IF(FLAG) THEN 
            FLAG=.FALSE. 
            VAL=VECT(IPOS) 
            MULT=VECT(IPOS-1) 
            IPOS=IPOS-2 
            DO 25 J=1,MULT 
            IPOS=IPOS+1 
   25       VECT(IPOS)=VAL 
         ENDIF 
      ENDIF 
      FLAG=  LINE(I:I).EQ.STAR  .OR. FLAG 
   30 LEADSP=LINE(I:I).EQ.SPACE .OR. FLAG 
      IF(IPOS.LT.NDIM) GO TO 10 
C     DEBUGG 
      IF(IPOS.EQ.NDIM) RETURN 
      WRITE(IPRT,'('' DATA VECTOR OF LENGTH'',I4,'' GREATER THAN'',I4)') 
     .           IPOS,NDIM 
      GO TO 50 
   40 WRITE(IPRT,'('' UNEXPECTED END OF DATA ...'')') 
   50 WRITE(IPRT,'('' READ ERROR ON UNIT'',I3,'' THE DATA ARE :'',A)') 
     .           LEC,LINE 
      WRITE(IPRT,'('' THUS THE RUN STOPPED AT THIS POINT IN ROUTINE'', 
     .             '' READVT'')') 
      STOP 
      END 
      SUBROUTINE PATH1(X,E,G,N,EPS,LIMIT,IMETH,P) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C----------------------------------------------------------------------- 
C     REACTION PATH DESCRIPTION BY NUMERICAL INTEGRATION 
C       EPS   : CONVERGENCE THRESHOLD ON RMS GRADIENT G AT POINT X 
C       LIMIT : MAXIMUM NUMBER OF ITERATION 
C       IMETH : 8,9 ... FOR CURRENT EVALUATION OF G AT X 
C               20      NORMAL RETURN 
C               21      DIVERGENCE (INCREASING ENERGY) 
C     DATA ... 
C       POND(I)  PONDERATION FACTOR (EG MASSES OF NUCLEI) 
C       YE(I)    TRANSITION VECTOR  (IF PROVIDED ) 
C       HMIN     MINIMUM ALLOWED STEP LENGTH 
C       HMAX     MAXIMUM ------------------- 
C       HPREC    CONVERGENCE THRESHOLD ON VARIABLES AT EACH ITERATION 
C     REFERENCE FOR REACTION PATH DEFINITION  : 
C       KATO,FUKUI JACS VOL 98  P 6395  (1976) 
C     REFERENCE FOR HESSIAN UPDATE : 
C       M.J.D. POWELL MATH. PROG. VOL 1 P 26 (1971) 
C     REFERENCE AS A STARTING POINT FOR THIS INTEGRATOR : 
C       A. RALSTON FOR PREDICTOR CORRECTOR 2/4 
C       J. CERTAINE FOR LARGE TIME CONSTANT TREATMENT 
C                  BOTH IN 
C       MATHEMATICAL METHODS FOR DIGITAL COMPUTER 
C       (A. RALSTON ED) J.WILEY & SONS,NEW-YORK (1960) 
C     ELABORATED BY D.LIOTARD 
C     LABORATOIRE DE CHIMIE STRUCTURALE -PAU, FRANCE- DECEMBER 1984 
C 
      COMMON /PRECI/ SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HESSE(MAXHES) 
     .              ,PDUMMY(MAXPAR,MAXPAR),DY2(MAXPAR),POND(MAXPAR) 
     .              ,D(MAXPAR),XOLD(MAXPAR),TVOLD(MAXPAR) 
     .              ,Y1(MAXPAR,2),Y2(MAXPAR,2),Y3(MAXPAR,2),C(MAXPAR,4) 
     .              ,Y4(MAXPAR,2),Y(MAXPAR,2),YE(MAXPAR),DX(MAXPAR), 
     .               HPREC,HMIN,H,HMAX,HTOT,DHTOT,RMS,EOLD,CRITE, 
     .               Y1NORM,Y2NORM,Y3NORM,ETOL,TOLE, 
     .               ICALL,ITERAT,IS,IPRINT,ITE,NBOUND,NBOULO, 
     .               KONV,HUPDAT,RESET,INTERP 
      DIMENSION X(N),G(N),P(N,N) 
      LOGICAL KONV,HUPDAT,RESET,INTERP 
      SAVE
C     ... 
C     DISPATCHING ACCORDING TO THE VALUE OF IMETH 
C       8   STARTING POINT 
C       9   GET AWAY FROM THE SADDLE 
C      10   ONE OF THE INTEGRATOR 
C    ... 
      IMETHO=IMETH-7 
      GO TO (9001,9002,9003),IMETHO 
      WRITE(IPRT,1220) IMETH 
      IMETH=21 
      RETURN 
 9001 CONTINUE 
C     ... 
C     OPTION CONTROL AND PRINTOUT 
C     ... 
      SS=DOT(YE,G,N) 
      WRITE(IPRT,1010) HMIN,HMAX,HPREC,LIMIT,IMP,EPS,(EG(I),I=1,3),E,SS 
      WRITE(IPRT,1040) (POND(I),I=1,N) 
      IF(KONV) GO TO 5 
      WRITE(IPRT,1060) 
      IMETH=21 
      RETURN 
    5 WRITE(IPRT,1050) (YE(I),I=1,N) 
C     INITIALIZE HESSIAN,COUNTERS AND PATH LENGTH HTOT. 
      NBOUND=N*(N+1)/2 
      DO 11 I=1,NBOUND 
   11 HESSE(I)=0.D0 
      NBOUND=N*N 
      DO 12 I=1,NBOUND 
   12 P(I,1)=0.D0 
      K=1 
      DO 13 I=1,N 
      D(I)=0.D0 
      P(K,1)=1.D0 
   13 K=K+N+1 
      IMETH=9 
      ICALL=1 
      ITERAT=0 
      NBOULO=N 
      NBOUND=N+1 
      HTOT=0.D0 
      DHTOT=HMIN*2.D0 
      IMP0=IMP 
      IMP=MIN0(IMP,3) 
      RMS=SQRT(DOT(G,G,N)/FLOAT(N)) 
C     ... 
C     AS LONG AS THE GRADIENT IS NOT YET PRECISE , 
C     GET AWAY FROM THE SADDLE IN TV DIRECTION,TOLERANCE ON ENERGY :TOLE 
C     ... 
   14 SS=DOT(G,YE,N) 
      DS=0.D0 
      DO 15 I=1,N 
   15 DS=DS+(YE(I)*C(I,1))**2 
      DS=SQRT(DS) 
      IF(SS.LT.-DS) GO TO 20 
      HTOT=HTOT+DHTOT 
      DO 16 I=1,N 
   16 X(I)=X(I)+DHTOT*YE(I) 
      RETURN 
 9002 CONTINUE 
      ICALL=ICALL+1 
      ITERAT=ITERAT+1 
      IF(IMP.LE.0) GO TO 2101 
      RMS=SQRT(DOT(G,G,N)/FLOAT(N)) 
      IPRINT=1 
      GO TO 900 
 2101 IF(ITERAT.LT.MIN0(LIMIT,20).AND.E.LT.TOLE) GO TO 14 
      WRITE(IPRT,1120) ITERAT,SS,DS 
      IF(IMP.GE.2) GO TO 2102 
      IMP=2 
      IPRINT=2 
      GO TO 900 
 2102 IMP=IMP0 
      IMETH=21 
      RETURN 
C     ... 
C     INITIALIZATION BY EULER-CAUCHY METHOD WITH STEP HPREC<H<DHTOT 
C     ... 
   20 WRITE(IPRT,1030) ITERAT,E,HTOT 
      EOLD=E 
      HUPDAT=.FALSE. 
      IMETH=10 
      DO 21 I=1,N 
      Y1(I,1)=X(I) 
      Y1(I,2)=-G(I)/POND(I) 
      XOLD(I)=X(I) 
   21 TVOLD(I)=Y1(I,2) 
      Y1NORM=SQRT(DOT(Y1(1,2),Y1(1,2),N)) 
C     FIRST ORDER PREDICTOR 
      H=MAX(DHTOT,2.D0*HMIN)/Y1NORM 
   22 DO 23 I=1,N 
   23 Y3(I,1)=Y1(I,1)+H*Y1(I,2) 
      ITE=1 
   24 IS=1 
      GO TO 800 
C     SECOND ORDER CORRECTOR 
 3001 CRITE=0.D0 
      DO 25 I=1,N 
      Y(I,2)=Y1(I,1)+H*(Y1(I,2)+Y3(I,2))*0.5D0 
   25 CRITE=MAX(CRITE,DABS(Y(I,2)-Y3(I,1))) 
      IF(CRITE.LE.HPREC.AND.E.LE.EOLD+ETOL) GO TO 28 
      IF(CRITE.GT.HMAX) GO TO 27 
      DO 26 I=1,N 
   26 Y3(I,1)=Y(I,2) 
      ITE=ITE+1 
      IF(ITE.LE.3) GO TO 24 
C     REDUCED STEP SIZE 
   27 IF(H*Y1NORM.LT.HPREC) GO TO 100 
      H=MIN(2.1D0*HMIN/Y1NORM,H*0.5D0) 
      ITERAT=ITERAT+1 
      GO TO 22 
C     CONVERGENCE 
   28 EOLD=E 
      Y3NORM=SQRT(DOT(Y3(1,2),Y3(1,2),N)) 
      KONV=.TRUE. 
      RESET=.FALSE. 
      INTERP=.TRUE. 
      CALL PATH2 (Y1,Y3,N) 
      Y2NORM=SQRT(DOT(Y(1,2),Y(1,2),N)) 
      DHTOT=H*(Y1NORM+Y3NORM+4.D0*Y2NORM)/6.D0 
      HTOT=HTOT+DHTOT 
      ITERAT=ITERAT+1 
      WRITE(IPRT,1130) ITERAT,E,HTOT 
      IMP=IMP0 
C     ... 
C     START A STEP H OF P.C. IN EIGENVECTORS BASIS 
C     ... 
C     BACK ROTATE Y1 AND Y2 (IN Y3) ONTO C 
   30 Y2NORM=Y3NORM 
      IF(.NOT.HUPDAT) GO TO 36 
      DO 31 J=1,2 
      CALL MXM (P,N,Y1(1,J),N,C(1,J),1) 
      CALL MXM (P,N,Y3(1,J),N,C(1,J+2),1) 
   31 CALL MXM (P,N,Y4(1,J),N,Y2(1,J),1) 
C     ESTABLISH NEW ROTATION AND NBOUND 
      K=0 
      DO 32 I=1,N 
      DO 32 J=1,I 
      K=K+1 
   32 P(I,J)=HESSE(K) 
      CALL DIAGIV(P,N,N,D,EPS2) 
      EPS1=MAX(EPS2*FLOAT(N),2.D0*HPREC/(H*DHTOT)) 
      IF(RESET) EPS1=EPS2*FLOAT(N) 
      NBOUND=1 
   33 IF (D(NBOUND).GT.EPS1) GO TO 34 
      NBOUND=NBOUND+1 
      IF(NBOUND.LE.N) GO TO 33 
   34 NBOULO=NBOUND-1 
C     ROTATE Y1 AND Y2 FROM C TO THE NEW EIGENVECTORS BASIS 
      DO 35 J=1,2 
      IF (.NOT.INTERP) CALL MXM (Y2(1,J),1,P,N,Y4(1,J),N) 
      CALL MXM (C(1,J),1,P,N,Y1(1,J),N) 
   35 CALL MXM (C(1,J+2),1,P,N,Y2(1,J),N) 
      GO TO 40 
C     NO UPDATE OF THE HESSIAN 
   36 DO 37 I=1,N 
      Y2(I,1)=Y3(I,1) 
   37 Y2(I,2)=Y3(I,2) 
C     CONVERGENCE CRITERIA AND STANDARD EDITION 
   40 RMS=SQRT(DOT(G,G,N)/FLOAT(N)) 
      IF(RMS.GT.EPS.OR.ITERAT.LT.10) GO TO 42 
      WRITE(IPRT,1140) 
      IMETH=20 
   41 IMP=MAX0(IMP,3) 
      IPRINT=3 
      GO TO 900 
 2103 IMP=IMP0 
      RETURN 
   42 IF(ITERAT.LT.LIMIT) GO TO 44 
   43 WRITE(IPRT,1150) 
      IMETH=21 
      GO TO 41 
   44 ITERAT=ITERAT+1 
      IPRINT=4 
      IF (.NOT.RESET) GO TO 900 
C     ... 
C     START AN ITERATION OF CORRECTOR FORMULA WITH STEP H. 
C     ... 
 2104 CONTINUE 
      HUPDAT=.FALSE. 
C     PREDICTOR Y3 
   45 ITE=0 
      IF(NBOULO.EQ.0) GO TO 47 
      DO 46 I=1,NBOULO 
      Y3(I,1)=Y1(I,1)+2.D0*H*Y2(I,2) 
   46 Y(I,1)=DABS(Y3(I,1)-Y2(I,1)) 
      IF(NBOUND.GT.N) GO TO 49 
   47 DO 48 I=NBOUND,N 
      Y13=Y1(I,2)+D(I)*Y1(I,1) 
      Y23=Y2(I,2)+D(I)*Y2(I,1) 
      EXPD=DEXP(-D(I)*H) 
      YE(I)=Y2(I,1)*EXPD 
      C(I,1)=(1.D0-EXPD)/D(I) 
      C(I,2)=(1.D0-C(I,1)/H)/D(I) 
      C(I,3)=(0.5D0-C(I,2)/H)/D(I) 
      Y3(I,1)=YE(I)+(C(I,1)+C(I,2))*Y23-C(I,2)*Y13 
      Y(I,1)=DABS(Y3(I,1)-Y2(I,1)) 
   48 YE(I)=YE(I)+(C(I,3)-0.5D0*C(I,2))*Y13+(C(I,1)-2.D0*C(I,3))*Y23 
   49 CRITE=0.D0 
      DO 50 I=1,N 
   50 CRITE=MAX(CRITE,Y(I,1)) 
      IF(CRITE.GT.HMAX) GO TO 90 
      ITE=1 
      IS=2 
      GO TO 800 
C     CORRECTOR Y3 AND CONVERGENCE CRITERIUM CRITE 
 3002 IF(NBOULO.EQ.0) GO TO 53 
      DO 52 I=1,NBOULO 
      Y(I,2)=Y3(I,1) 
      Y3(I,1)=Y1(I,1)+H*(Y3(I,2)+4.D0*Y2(I,2)+Y1(I,2))/3.D0 
   52 Y(I,1)=DABS(Y3(I,1)-Y(I,2)) 
      IF(NBOUND.GT.N) GO TO 55 
   53 DO 54 I=NBOUND,N 
      Y(I,2)=Y3(I,1) 
      Y3(I,1)=YE(I)+(C(I,3)+0.5D0*C(I,2))*(Y3(I,2)+D(I)*Y3(I,1)) 
   54 Y(I,1)=DABS(Y3(I,1)-Y(I,2)) 
   55 CRITE=0.D0 
      DO 56 I=1,N 
   56 CRITE=MAX(CRITE,Y(I,1)) 
      IF(CRITE.GT.HMAX) GO TO 90 
      CRITE=CRITE/HPREC 
      IS=3 
      GO TO 800 
 3003 IF(CRITE.GT.1.D0.AND.ITE.GT.6) GO TO 90 
      IF(CRITE.LE.1.D0) GO TO 62 
C     NEXT ITERATION OF THE IMPLICIT CORRECTOR FORMULA 
      ITE=ITE+1 
      GO TO 3002 
   62 IF(E.GT.EOLD+ETOL) GOTO 90 
C     CONVERGENCE ACHIEVED 
      RESET=.FALSE. 
      EOLD=E 
      Y3NORM=SQRT(DOT(Y3(1,2),Y3(1,2),N)) 
      CALL PATH2(Y2,Y3,N) 
      Y25NOR=SQRT(DOT(Y(1,2),Y(1,2),N)) 
      DHTOT=H*(Y2NORM+Y3NORM+4.D0*Y25NOR)/6.D0 
      HTOT=HTOT+DHTOT 
      IF(ITE.LE.2.AND.DHTOT.LE.0.5D0*HMAX.AND.KONV) GO TO 70 
      KONV=ITE.LE.2 
      IF((ITE.LE.4.OR.DHTOT.LT.HMIN*2.D0).AND.DHTOT.LT.HMAX) GO TO 64 
C     THE NEXT STEP WILL BE HALVED 
      H=H*0.5D0 
      DHTOT=DHTOT*0.5D0 
      DO 63 I=1,N 
      Y1(I,1)=Y(I,1) 
   63 Y1(I,2)=Y(I,2) 
      INTERP=.TRUE. 
      GO TO 30 
C     THE NEXT STEP WILL BE UNCHANGED 
   64 DO 65 I=1,N 
      Y1(I,1)=Y2(I,1) 
   65 Y1(I,2)=Y2(I,2) 
      INTERP=.TRUE. 
      GO TO 30 
C     THE NEXT STEP WILL BE DOUBLED WITH SAVING OF INTERMEDIATE IN Y4 
   70 H=H*2.D0 
      DHTOT=DHTOT*2.D0 
      DO 71 I=1,N 
      Y4(I,1)=Y2(I,1) 
   71 Y4(I,2)=Y2(I,2) 
      INTERP=.FALSE. 
      GO TO 30 
C     NOT YET CONVERGED : THE STEP MUST BE HALVED. 
   90 KONV=.FALSE. 
      IF (DHTOT.LT.HMIN) GO TO 96 
      IF (IMP.GE.4) WRITE(6,1160) DHTOT,ITE 
      IF (.NOT.INTERP) GO TO 92 
      CALL PATH2 (Y1,Y2,N) 
      DO 91 I=1,N 
      Y1(I,1)=Y(I,1) 
   91 Y1(I,2)=Y(I,2) 
      GO TO 95 
   92 DO 93 I=1,N 
      Y1(I,1)=Y4(I,1) 
   93 Y1(I,2)=Y4(I,2) 
      INTERP=.TRUE. 
   95 H=H*0.5D0 
      DHTOT=DHTOT*0.5D0 
      GO TO 45 
C     LAST ATEMPT TO PURSUE ... 
   96 IF(.NOT.HUPDAT.OR.RESET) GO TO 98 
      WRITE(IPRT,1210) ITERAT 
      RESET=.TRUE. 
      DO 97 I=1,N 
      Y3(I,1)=Y2(I,1) 
   97 Y3(I,2)=Y2(I,2) 
      Y3NORM=Y2NORM 
      GO TO 30 
C     RESTART WITH EULER-CAUCHY IN EIGENVECTORS BASIS 
   98 WRITE(IPRT,1230) ITERAT 
      DO 99 I=1,N 
      Y1(I,1)=Y2(I,1) 
   99 Y1(I,2)=Y2(I,2) 
      Y1NORM=Y2NORM 
      NBOULO=N 
      NBOUND=N+1 
      H=2.D0*HMIN/Y1NORM 
      GO TO 22 
C     UNABLE TO CONVERGE WITH DHTOT<HMIN 
  100 WRITE(IPRT,1170) CRITE,DHTOT,HMIN,ITE 
      GO TO 43 
C     ... 
C     USUAL ENTRY POINT WITH BACK ROTATION AND HESSIAN'UPDATE 
C     ... 
C     BACK ROTATION OF Y3 ONTO X 
  800 CALL MXM (P,N,Y3,N,X,1) 
C     CALL ENERGY E AND GRADIENT G AT POINT X 
  810 RETURN 
 9003 CONTINUE 
      ICALL=ICALL+1 
C     UPDATE THE HESSIAN MATRIX 
      DO 820 I=1,N 
      Y(I,2)=-G(I)/POND(I) 
  820 DX(I)=X(I)-XOLD(I) 
      XNORM2=DOT(DX,DX,N) 
      IF(XNORM2.LE.HPREC**2) GO TO 860 
      XNORM2=1.0D0/XNORM2 
      CALL SUPDOT(Y,HESSE,DX,N,1) 
      DO 830 I=1,N 
      Y(I,1)=TVOLD(I)-Y(I,2)-Y(I,1) 
  830 Y(I,1)=CVMGT(0.D0,Y(I,1),ABS(Y(I,1)).LT.DY2(I)) 
      HUPDAT=.TRUE. 
      SCAL=DOT(Y,DX,N)*XNORM2 
      K=0 
      DO 840 I=1,N 
      DO 840 J=1,I 
      K=K+1 
  840 HESSE(K)=HESSE(K)+(Y(I,1)*DX(J)+Y(J,1)*DX(I)-DX(I)*DX(J)*SCAL) 
     . *XNORM2 
      DO 850 I=1,N 
      XOLD(I)=X(I) 
  850 TVOLD(I)=Y(I,2) 
C     ROTATE ONTO EIGENVECTORS BASIS THE WEIGHTED NEGATIVE GRADIENT Y3 
  860 CALL MXM (Y(1,2),1,P,N,Y3(1,2),N) 
      GO TO (3001,3002,3003),IS 
      WRITE(IPRT,1070) IS 
      IMETH=21 
      RETURN 
C     ... 
C     PRINTING SECTION.DISPATCH ACCORDING TO IPRINT 
C     ... 
  900 IF(IMP.LE.0) GO TO 920 
      WRITE(IPRT,1080) ITERAT,E,RMS,HTOT,ICALL 
      IF(IMP.GT.1) WRITE(IPRT,1090) (X(I),I=1,N) 
      IF(IMP.GT.2) WRITE(IPRT,1100) (G(I),I=1,N) 
      IF(.NOT.HUPDAT) GO TO 920 
      IF(IMP.GT.3) WRITE(IPRT,1180) NBOULO,(D(I),I=1,N) 
      IF(IMP.LT.5) GO TO 920 
      WRITE(IPRT,1190) 
      DO 910 I=1,N 
  910 WRITE(IPRT,1200)I,(P(J,I),J=1,N) 
  920 GO TO (2101,2102,2103,2104),IPRINT 
      WRITE(IPRT,1110) IPRINT 
      IMETH=21 
      RETURN 
C     ... 
 1000 FORMAT(2I5,3F10.0) 
 1010 FORMAT('1REACTION PATH...MIN/MAX STEPS :',2F8.5, 
     .' WITH REQUIRED ACCURACY :',F8.6/ 
     .17X,'MAX ITERATIONS=',I5,12X,'PRINTOUT LEVEL =',I3/ 
     .17X,'RMS GRADIENT CV THRESHOLD =   ',1PD9.1/ 
     .17X,'STANDARD DEVIATION ON GRADIENT',3D9.1/ 
     .17X,'STARTING POINT ENERGY=',D10.3,' <T.VCTOR!GRADIENT>=',D9.1) 
 1020 FORMAT(8F10.0) 
 1030 FORMAT(' START EULER-CAUCHY  PREDICTOR-CORRECTOR AT ITERATION',I3, 
     ./' WITH ENERGY=',1PD12.4,5X,'AND LENGTH=',0PF12.6) 
 1040 FORMAT(' WEIGHTS',9F8.4/(8X,9F8.4)) 
 1050 FORMAT(' T VCTOR',9F8.4/(8X,9F8.4)) 
 1060 FORMAT(' NO WEIGHT CAN BE NEGATIVE OR NUL ...BYE') 
 1070 FORMAT(I5,' :ILLEGAL VALUE OF''IS'' IN PATH1 ROUTINE...BYE') 
 1080 FORMAT(' ITE',I5,2X,'ENERGY=',1PD12.4,4X,'RMS GRADIENT=',D10.2/ 
     .11X,'INTEGRATED PATH LENGTH=',D12.4,4X,'NUMBER OF GRADIENT CALL' 
     .,I5) 
 1090 FORMAT(' COORD=',7F10.5/(7X,7F10.5)) 
 1100 FORMAT(' GRAD.=',7F10.2/(7X,7F10.2)) 
 1110 FORMAT(' ILLEGAL VALUE OF''IPRINT''=',I5,' IN PATH1 ROUTINE..BYE') 
 1120 FORMAT(' UNABLE TO GET AWAY FROM THE SADDLE AFTER',I4, 
     . 'ITERATIONS'/' SLOPE=',1PD10.2,' +-',D10.2) 
 1130 FORMAT(' START TIME CONSTANT PREDICTOR-CORRECTOR AT ITERATION',I3/ 
     .' WITH ENERGY=',1PD12.4,5X,'AND LENGTH=',0PF12.6) 
 1140 FORMAT(' WHAO ... CONVERGENCE ACHIEVED') 
 1150 FORMAT(' UNABLE TO CONVERGE ...BYE') 
 1160 FORMAT(' STEP (',F11.6,' ) HALVED AT ITERATION',I4, 
     . ' OF THE CORRECTOR FORMULA') 
 1170 FORMAT(' CRITERION=',F10.1,' > 1.0 OR STEP=',F11.6,' <',F11.6/ 
     .' OR ITER=',I2,'> 6 OR INCREASING ENERGY : DIVERGENCE'/ 
     .' TRY AGAIN FROM THIS POINT WITH A SMALLER VALUE OF HMIN ...') 
 1180 FORMAT(' EIGENVALUES OF HESSIAN  (WITH CUTOFF =',I3,')'/ 
     . (4X,1P,7D10.2)) 
 1190 FORMAT(' WITH EIGENVECTORS (ROWWISE)') 
 1200 FORMAT(1X,I3,1P,7D10.2/(4X,7D10.2)) 
 1210 FORMAT(' RESET H MATRIX AND TRY AGAIN AT ITERATION',I3) 
 1220 FORMAT(' ABNORMAL VALUE OF''IMETH''=',I5,' IN PATH1 ROUTINE..BYE') 
 1230 FORMAT(' RESTART EULER-CAUCHY WITH EIGENVECTORS AT ITERATION',I3) 
      END 
      SUBROUTINE PATH2 (Y1,Y2,N) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
C     THIRD ORDER INTERPOLATION BETWEEN Y1 AND Y2 (HALF STEP SIZE) 
C     H =STEP SIZE BETWEEN Y1 AND Y2 , Y2 POSTERIOR AT Y1. 
C     RESULTS IN Y VECTORS (Y AND DY/DH ). 
      COMMON /OPTIM/ IMP,IMP0,LEC,IPRT,HESSE(MAXHES),P(MAXPAR,MAXPAR) 
     .              ,DY2(MAXPAR),POND(MAXPAR),D(MAXPAR),XOLD(MAXPAR) 
     .              ,TVOLD(MAXPAR),Y1Y2Y3(MAXPAR,6),C(MAXPAR,4) 
     .              ,Y4(MAXPAR,2),Y(MAXPAR,2),YE(MAXPAR),DX(MAXPAR) 
     .              ,HPREC,HMIN,H,HMAX,HTOT,DHTOT,RMS,EOLD,CRITE 
     .              ,Y1NORM,Y2NORM,Y3NORM,ETOL,TOLE 
     .              ,ICALL,ITERAT,IS,IPRINT,ITE,NBOUND,NBOULO 
     .              ,KONV,HUPDAT,RESET,INTERP 
      DIMENSION Y1(MAXPAR,2),Y2(MAXPAR,2) 
      LOGICAL KONV,HUPDAT,RESET,INTERP 
      SAVE
      IF(NBOULO.EQ.0) GO TO 20 
      DO 10 I=1,NBOULO 
      Y(I,1)=0.5D0*(Y1(I,1)+Y2(I,1))+H*(Y1(I,2)-Y2(I,2))*0.125D0 
   10 Y(I,2)=1.5D0*(Y2(I,1)-Y1(I,1))/H-(Y1(I,2)+Y2(I,2))*0.250D0 
      IF(NBOUND.GT.N) RETURN 
   20 HH=H*0.5D0 
      DO 30 I=NBOUND,N 
      EXPD=DEXP(-D(I)*HH) 
      AO=Y1(I,2)+D(I)*Y1(I,1) 
      C1=Y2(I,1)-Y1(I,1)-Y1(I,2)*C(I,1) 
      C2=Y2(I,2)+D(I)*Y2(I,1)-AO 
      DELTA=1.D0/(0.5D0*C(I,2)-C(I,3)) 
      A1=(0.5D0*C1-C(I,3)*C2)*DELTA 
      A2=(C(I,2)*C2-C1)*DELTA 
      CO=(1.D0-EXPD)/D(I) 
      C1=(0.5D0-CO/H)/D(I) 
      C2=(0.125D0-C1/H)/D(I) 
      Y(I,1)=Y1(I,1)*EXPD+AO*CO+A1*C1+A2*C2 
   30 Y(I,2)=-D(I)*Y(I,1)+AO+0.5D0*A1+0.125D0*A2 
      RETURN 
      END 
      SUBROUTINE PATHS 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /ALPARM/ ALPARM(3,MAXPAR),X0, X1, X2, ILOOP 
************************************************************************ 
* 
*   PATH FOLLOWS A REACTION COORDINATE.   THE REACTION COORDINATE IS ON 
*        ATOM LATOM, AND IS A DISTANCE IF LPARAM=1, 
*                           AN ANGLE   IF LPARAM=2, 
*                           AN DIHEDRALIF LPARAM=3. 
* 
************************************************************************ 
      DIMENSION GD(MAXPAR),XLAST(MAXPAR),MDFP(20),XDFP(20) 
      CHARACTER*80 KEYWRD 
      CHARACTER*10 TYPE(3) 
      DATA TYPE / 'ANGSTROMS ','DEGREES   ','DEGREES   '/ 
      SAVE
      ILOOP=1 
      IF(INDEX(KEYWRD,'RESTAR') .NE. 0) THEN 
         MDFP(9)=0 
         CALL DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP) 
         WRITE(6,'(//10X,'' RESTARTING AT POINT'',I3)')ILOOP 
      ENDIF 
      IF(ILOOP.GT.1) GOTO 10 
      WRITE(6,'(''  ABOUT TO ENTER FLEPO FROM PATH'')') 
      CALL SECOND (TIME1) 
      CALL FLEPO(XPARAM,NVAR,FUNCT) 
      WRITE(6,'(''  OPTIMISED VALUES OF PARAMETERS, INITIAL POINT'')') 
      CALL WRITE(TIME1,FUNCT) 
      CALL SECOND (TIME1) 
   10 CONTINUE 
      IF(ILOOP.GT.2) GOTO 40 
      GEO(LPARAM,LATOM)=REACT(2) 
      IF(ILOOP.EQ.1) THEN 
         X0=REACT(1) 
         X1=X0 
         X2=REACT(2) 
         IF(X2.LT. -100.D0) STOP 
         DO 20 I=1,NVAR 
            ALPARM(2,I)=XPARAM(I) 
   20    ALPARM(1,I)=XPARAM(I) 
         ILOOP=2 
      ENDIF 
      CALL FLEPO(XPARAM,NVAR,FUNCT) 
      RNORD=REACT(2) 
      IF(LPARAM.GT.1) RNORD=RNORD*57.29577951D0 
      WRITE(6,'(1X,16(''*****'')//17X,''REACTION COORDINATE = '' 
     1,F12.4,2X,A10,19X//1X,16(''*****''))')RNORD,TYPE(LPARAM) 
      CALL WRITE(TIME1,FUNCT) 
      CALL SECOND (TIME1) 
      DO 30 I=1,NVAR 
   30 ALPARM(3,I)=XPARAM(I) 
C 
C   NOW FOR THE MAIN INTERPOLATION ROUTE 
C 
      IF(ILOOP.EQ.2)ILOOP=3 
   40 CONTINUE 
      DO 110 ILOOP = ILOOP,100 
C 
         IF(REACT(ILOOP).LT. -100.D0) STOP 
C 
         RNORD=REACT(ILOOP) 
         IF(LPARAM.GT.1) RNORD=RNORD*57.29577951D0 
         WRITE(6,'(1X,16(''*****'')//19X,''REACTION COORDINATE = '' 
     1,F12.4,2X,A10,19X//1X,16(''*****''))')RNORD,TYPE(LPARAM) 
C 
         X3=REACT(ILOOP) 
         C3=(X0**2-X1**2)*(X1-X2)-(X1**2-X2**2)*(X0-X1) 
C      WRITE(6,'(''   C3:'',F13.7)')C3 
         IF (ABS(C3) .LT. 1.D-8) THEN 
C 
C    WE USE A LINEAR INTERPOLATION 
C 
            CC1=0.D0 
            CC2=0.D0 
         ELSE 
C    WE DO A QUADRATIC INTERPOLATION 
C 
            CC1=(X1-X2)/C3 
            CC2=(X0-X1)/C3 
         END IF 
         CB1=1.D0/(X1-X2) 
         CB2=(X1**2-X2**2)*CB1 
C 
C    NOW TO CALCULATE THE INTERPOLATED COORDINATES 
C 
         DO 50 I=1,NVAR 
            DELF0=ALPARM(1,I)-ALPARM(2,I) 
            DELF1=ALPARM(2,I)-ALPARM(3,I) 
            ACONST = CC1*DELF0-CC2*DELF1 
            BCONST = CB1*DELF1-ACONST*CB2 
            CCONST = ALPARM(3,I) - BCONST*X2 - ACONST*X2**2 
            XPARAM(I)=CCONST+BCONST*X3+ACONST*X3**2 
            ALPARM(1,I)=ALPARM(2,I) 
   50    ALPARM(2,I)=ALPARM(3,I) 
C 
C   NOW TO CHECK THAT THE GUESSED GEOMETRY IS NOT TOO ABSURD 
C 
         DO 60 I=1,NVAR 
   60    IF(ABS(XPARAM(I)-ALPARM(3,I)) .GT. 0.2) GOTO 70 
         GOTO 90 
   70    WRITE(6,'('' GEOMETRY TOO UNSTABLE FOR EXTRAPOLATION TO BE USED 
     1''/ ,'' - THE LAST GEOMETRY IS BEING USED TO START THE NEXT'' 
     2,'' CALCULATION'')') 
         DO 80 I=1,NVAR 
   80    XPARAM(I)=ALPARM(3,I) 
   90    CONTINUE 
         X0=X1 
         X1=X2 
         X2=X3 
         GEO(LPARAM,LATOM)=REACT(ILOOP) 
         CALL FLEPO(XPARAM,NVAR,FUNCT) 
         CALL WRITE(TIME1,FUNCT) 
         CALL SECOND (TIME1) 
         DO 100 I=1,NVAR 
  100    ALPARM(3,I)=XPARAM(I) 
  110 CONTINUE 
      END 
      SUBROUTINE PERM(IPERM,NELS,NMOS,MAXMOS,NPERMS) 
      DIMENSION IPERM(MAXMOS,60), IADD(20), NEL(20) 
      SAVE
************************************************************************ 
* 
*  PERM PERMUTES NELS ENTITIES AMONG NMOS LOCATIONS. THE ENTITIES AND 
*       LOCATIONS ARE EACH INDISTINGUISHABLE. THE PAULI EXCLUSION 
*       PRINCIPLE IS FOLLOWED. THE NUMBER OF STATES PRODUCED IS GIVEN 
*       BY NMOS]/(NELS]*(NMOS-NELS)]). 
* ON INPUT: NELS  = NUMBER OF INDISTINGUISHABLE ENTITIES 
*           NMOS  = NUMBER OF INDISTINGUISHABLE LOCATIONS 
* 
* ON OUTPUT IPERM = ARRAY OF PERMUTATIONS, A 0 INDICATES NO ENTITY, 
*                   A 1 INDICATES AN ENTITY. 
*           NPERM = NUMBER OF PERMUTATIONS. 
* 
************************************************************************ 
      IF(NELS.GT.NMOS)THEN 
         WRITE(6,'('' NUMBER OF PARTICLES,'',I3,'' GREATER THAN NO. '', 
     1''OF STATES,'',I3)')NELS,NMOS 
         NPERMS=0 
         RETURN 
      ENDIF 
      NPERMS=1 
      DO 10 I=1,20 
   10 NEL(I)=1000 
      DO 20 I=1,NELS 
   20 NEL(I)=1 
      DO 50 I12=1-12+NELS,NMOS,NEL(12) 
         IADD(12)=I12 
         DO 50 I11=I12+1,NMOS,NEL(11) 
            IADD(11)=I11 
            DO 50 I10=I11+1,NMOS,NEL(10) 
               IADD(10)=I10 
               DO 50 I9=I10+1,NMOS,NEL(9) 
                  IADD(9)=I9 
                  DO 50 I8=I9+1,NMOS,NEL(8) 
                     IADD(8)=I8 
                     DO 50 I7=I8+1,NMOS,NEL(7) 
                        IADD(7)=I7 
                        DO 50 I6=I7+1,NMOS,NEL(6) 
                           IADD(6)=I6 
                           DO 50 I5=I6+1,NMOS,NEL(5) 
                              IADD(5)=I5 
                              DO 50 I4=I5+1,NMOS,NEL(4) 
                                 IADD(4)=I4 
                                 DO 50 I3=I4+1,NMOS,NEL(3) 
                                    IADD(3)=I3 
                                    DO 50 I2=I3+1,NMOS,NEL(2) 
                                       IADD(2)=I2 
                                       DO 50 I1=I2+1,NMOS,NEL(1) 
                                          IADD(1)=I1 
                                          DO 30 J=1,NMOS 
   30                                     IPERM(J,NPERMS)=0 
                                          DO 40 J=1,NELS 
   40                                     IPERM(IADD(J),NPERMS)=1 
                                          NPERMS=NPERMS+1 
                                          IF(NPERMS.GT.61)THEN 
                                             WRITE(6,'('' NUMBER OF PERM 
     1UTATIONS TOO GREAT, LIMIT 60'')') 
                                             GOTO 60 
                                          ENDIF 
   50 CONTINUE 
   60 NPERMS=NPERMS-1 
      RETURN 
      END 
      SUBROUTINE POLAR 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
*********************************************************************** 
* 
*   POLAR CALCULATES THE POLARIZATION VOLUME IN CUBIC ANGSTROMS 
*         OF A MOLECULE. 
*         A SHAPED ELECTRIC FIELD IS CONSTRUCTED, THE FIELD IS PRODUCED 
*         BY POINT CHARGES IN THE LAYOUT 
* 
*    CHARGE   LOCATION 
* 
*     +Q       A  Z          THIS IS THE LAYOUT FOR THE DIAGONAL TERMS, 
*     +Q/2     AB Z          THE OFF-DIAGONALS, OF COURSE, CONTAIN 
*     -Q/2    -AB Z          TWICE AS MANY TERMS. THE RESULTING FIELD 
*     -Q      -A  Z          IS RECTILINEAR TO A GOOD APPROXIMATION 
*                            IN THE VOLUME OF ALL "NORMAL" MOLECULES 
*  "A" IS PROGRAM-DEFINED AND IS HERE SET TO 160 ANGSTROMS 
*  "B" IS THE INVERSE CUBE ROOT OF TWO. 
*********************************************************************** 
      COMMON /TITLES/ KOMENT,TITLE 
     1       /POLVOL/ POLVOL(107) 
     2       /KEYWRD/ KEYWRD 
     3       /GEOKST/ NATOMS,LABELS(NUMATM) 
     4               ,NA(NUMATM),NB(NUMATM),NC(NUMATM) 
     5       /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,XPARAM(MAXPAR) 
     6       /TIME  / TIME0 
     7       /CORE  / CORE(107) 
     8       /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR) 
     9       /WMATRX/ WDUMMY(N2ELEC*3),KDUMMY,NBAND(NUMATM) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM) 
     1               ,NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA 
     2               ,NCLOSE,NOPEN,NDUMY,FRACT 
     3       /GEOM  / GEO(3,NUMATM) 
     4       /LAST  / LAST 
     5       /COORD / COORD(3,NUMATM) 
      DIMENSION GRAD(MAXPAR), HEATS(5), PHASE(2,4), 
     1          POLMAT(6), VECTRS(9), EIGS(3) 
      CHARACTER  KEYWRD*80, TYPE*7, KOMENT*80, TITLE*80 
      LOGICAL HYPER,FAIL 
      DATA PHASE/3*1.D0,4*-1.D0,1.D0/ 
      SAVE
      TYPE=' MNDO  ' 
      HYPER=(INDEX(KEYWRD,'HYPER').NE.0) 
      FACTA=300 
C#      READ(7,*)FACTA 
      IF(INDEX(KEYWRD,'MINDO') .NE. 0) TYPE='MINDO/3' 
      IF(INDEX(KEYWRD,'AM1') .NE. 0)    TYPE='  AM1  ' 
      CALL GMETRY(GEO,COORD) 
      LAST=1 
      NA(1)=99 
C 
C  SET UP THE VARIABLES IN XPARAM AND LOC, THESE ARE IN CARTESIAN 
C  COORDINATES. 
C 
      NDEP=0 
C 
C   XX ANGSTROMS WAS FOUND TO BE THE BEST DISTANCE. 
C 
      FACT1=0.5D0**(1.D0/3.D0) 
      FACT3=1.D0-FACT1 
      FACT2=1.D0/FACT3**2 
C 
C   2 * PI * E(0) / (23.061 * (Q=CHARGE ON THE ELECTRON)) =0.0015056931 
C   IN CUBIC ANGSTROMS, Q   = 1.60219D-19 COULOMBS 
C                       E(0)=8.854188D-12(JOULES**(-2).C**(-2).M**(-1)) 
C                       E(0)=8.854188D-22 (CONVERTED TO ANGSTROMS) 
      NUMAT=0 
      SUMX=0.D0 
      SUMY=0.D0 
      SUMZ=0.D0 
      DO 20 I=1,NATOMS 
         IF(LABELS(I).NE.99) THEN 
            NUMAT=NUMAT+1 
            LABELS(NUMAT)=LABELS(I) 
            SUMX=SUMX+COORD(1,NUMAT) 
            SUMY=SUMY+COORD(2,NUMAT) 
            SUMZ=SUMZ+COORD(3,NUMAT) 
            DO 10 J=1,3 
   10       GEO(J,NUMAT)=COORD(J,NUMAT) 
         ENDIF 
   20 CONTINUE 
      SUMX=SUMX/NUMAT 
      SUMY=SUMY/NUMAT 
      SUMZ=SUMZ/NUMAT 
      SUMMAX=0.D0 
      ATPOL=0.D0 
      DO 30 I=1,NUMAT 
         ATPOL=ATPOL+POLVOL(NAT(I)) 
         GEO(1,I)=GEO(1,I)-SUMX 
         IF(SUMMAX.LT.ABS(GEO(1,I))) SUMMAX=ABS(GEO(1,I)) 
         GEO(2,I)=GEO(2,I)-SUMY 
         IF(SUMMAX.LT.ABS(GEO(2,I))) SUMMAX=ABS(GEO(2,I)) 
         GEO(3,I)=GEO(3,I)-SUMZ 
         IF(SUMMAX.LT.ABS(GEO(3,I))) SUMMAX=ABS(GEO(3,I)) 
   30 CONTINUE 
C 
C   THE ELECTRIC FIELD ACROSS ANY MOLECULE SHOULD BE ROUGHLY THE SAME, 
C   THEREFORE: 
      DELTA=25*SUMMAX 
      IF(DELTA.LT.160)DELTA=160 
      CONST=DELTA**4*0.0015056931D0 
      CONST=CONST*FACT2 
C 
C  INCREASE THE CHARGE ON THE SPARKLES 
C 
      CORE(105)= FACTA 
      CORE(106)=-CORE(105) 
      CORE(103)= CORE(105)*0.5D0 
      CORE(104)=-CORE(103) 
      CONST=CONST/CORE(105)**2 
      LABELS(NUMAT+1)=105 
      LABELS(NUMAT+2)=104 
      LABELS(NUMAT+3)=103 
      LABELS(NUMAT+4)=106 
      NAT(NUMAT+1)=105 
      NAT(NUMAT+2)=104 
      NAT(NUMAT+3)=103 
      NAT(NUMAT+4)=106 
      NFIRST(NUMAT+1)=NORBS+4 
      NFIRST(NUMAT+2)=NORBS+4 
      NFIRST(NUMAT+3)=NORBS+4 
      NFIRST(NUMAT+4)=NORBS+4 
      NMIDLE(NUMAT+1)=NORBS+3 
      NMIDLE(NUMAT+2)=NORBS+3 
      NMIDLE(NUMAT+3)=NORBS+3 
      NMIDLE(NUMAT+4)=NORBS+3 
      NLAST(NUMAT+1)=NORBS 
      NLAST(NUMAT+2)=NORBS 
      NLAST(NUMAT+3)=NORBS 
      NLAST(NUMAT+4)=NORBS 
      NBAND(NUMAT+1)=0 
      NBAND(NUMAT+2)=0 
      NBAND(NUMAT+3)=0 
      NBAND(NUMAT+4)=0 
      NVAR=0 
      NUMAT=NUMAT+4 
      NATOMS=NUMAT 
      NUMA1=NUMAT-3 
      NUMA2=NUMAT-2 
      NUMA3=NUMAT-1 
      GEO(1,NUMA1)=DELTA 
      GEO(2,NUMA1)=0.D0 
      GEO(3,NUMA1)=1.D8 
      GEO(1,NUMA2)=DELTA*FACT1 
      GEO(2,NUMA2)=0.D0 
      GEO(3,NUMA2)=1.D8 
      GEO(1,NUMA3)=-DELTA*FACT1 
      GEO(2,NUMA3)=0.D0 
      GEO(3,NUMA3)=1.D8 
      GEO(1,NUMAT)=-DELTA 
      GEO(2,NUMAT)=0.D0 
      GEO(3,NUMAT)=1.D8 
C#      I=NVAR 
C#      NVAR=0 
      CALL COMPFG(GEO,HEATS(5),FAIL, GRAD, .FALSE.) 
      IF(FAIL) STOP 
C#      NVAR=I 
      IJ=0 
      DO 70 I=1,3 
         IM1=I-1 
         DO 50 J=1,IM1 
            IJ=IJ+1 
            K=6-I-J 
            L=0 
            DO 40 LL=1,4 
               L=L+1 
               GEO(I,NUMA1)= DELTA*PHASE(1,LL) 
               GEO(I,NUMA2)= DELTA*PHASE(1,LL)*FACT1 
               GEO(I,NUMA3)=-DELTA*PHASE(1,LL)*FACT1 
               GEO(I,NUMAT)=-DELTA*PHASE(1,LL) 
               GEO(J,NUMA1)= DELTA*PHASE(2,LL) 
               GEO(J,NUMA2)= DELTA*PHASE(2,LL)*FACT1 
               GEO(J,NUMA3)=-DELTA*PHASE(2,LL)*FACT1 
               GEO(J,NUMAT)=-DELTA*PHASE(2,LL) 
               GEO(K,NUMA1)= 0.D0 
               GEO(K,NUMA2)= 0.D0 
               GEO(K,NUMA3)= 0.D0 
               GEO(K,NUMAT)= 0.D0 
               CALL COMPFG(GEO,HEATS(L),FAIL, GRAD, .FALSE.) 
               IF(FAIL) STOP 
   40       CONTINUE 
            POLMAT(IJ)=(HEATS(2)+HEATS(4)-HEATS(1)-HEATS(3))*CONST 
   50    CONTINUE 
         IJ=(I*(I+1))/2 
         DO 60 K=NUMA1,NUMAT 
            DO 60 J=1,3 
   60    GEO(J,K)= 0.D0 
         GEO(I,NUMA1)= DELTA 
         GEO(I,NUMA2)= DELTA*FACT1 
         GEO(I,NUMA3)=-DELTA*FACT1 
         GEO(I,NUMAT)=-DELTA 
         CALL COMPFG(GEO,HEATS(2),FAIL, GRAD, .FALSE.) 
         IF(FAIL) STOP 
         GEO(I,NUMA1)=-DELTA 
         GEO(I,NUMA2)=-DELTA*FACT1 
         GEO(I,NUMA3)= DELTA*FACT1 
         GEO(I,NUMAT)= DELTA 
         CALL COMPFG(GEO,HEATS(3),FAIL, GRAD, .FALSE.) 
         IF(FAIL) STOP 
         POLMAT(IJ)=0.5D0*(HEATS(5)+HEATS(5)-HEATS(2)-HEATS(3))*CONST+AT 
     1POL 
   70 CONTINUE 
      WRITE(6,'(A)')KOMENT, TITLE 
      WRITE(6,'(//10X,A,'' POLARIZATION MATRIX, FIELD='',F10.4, 
     1'' VOLTS PER ANGSTROM'')') 
     2TYPE,CORE(105)*2.D0*FACT3*14.399/DELTA**2 
      CALL VECPRT(POLMAT,3,3) 
      CALL HQRII(POLMAT,3,3,EIGS,VECTRS) 
      WRITE(6,'(//4X,''  POLARIZATION VOLUMES (IN CUBIC ANGSTROMS)'', 
     1'' AND VECTORS, AVERAGE='',F10.3)')(EIGS(1)+EIGS(2)+EIGS(3))/3.D0 
      CALL MATOUT(VECTRS,EIGS,3,3,3) 
      RETURN 
      END 
      SUBROUTINE POWELL (METHOD,XVAR,EOPT,GVAR,NVAR) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C-------------------- 
C     MAIN ROUTINE FOR GRADIENT NORM MINIMIZATION BY THE POWELL METHOD 
C-------------------- 
C     REQUIRED SUBROUTINE : 
C        POWEL1 :THE ORIGINAL POWELL ALGORITHM 
C        DOT,SUPDOT,DIAGIV : MATHEMATICAL PACKAGE 
C        SAVOPT :SAVE/RESTART ROUTINE 
C-------------------- 
C     THE COMMON/OPTIM/        INCLUDES THE WHOLE DATA REQUIRED. 
C     NOTE...THIS STRUCTURE ALLOWS TO OVERLAY THIS BRANCH (POWEL1,DOT, 
C     SUPDOT,DIAGIV) WITH THOSE OF THE ENERGY AND GRADIENT (COMPFG). 
C     MOREOVER,ONLY THIS SUBROUTINE MUST BE MODIFIED FOR IMPLEMENTATION 
C     IN ANOTHER PACKAGE. 
C-------------------- 
C 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,AJINV(MAXPAR,MAXPAR) 
     .               ,A(MAXPAR,MAXPAR),W(MAXPAR*5),B(MAXPAR,MAXPAR) 
     .               ,VALU(MAXPAR),RWORK(18),IWORK(14),SAVE(MAXPAR) 
     .               ,ISAVE(1) 
      COMMON /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),DUM(3),KDUM(MAXPAR) 
      COMMON /MESAGE/ IFLEPO 
      COMMON /SCFOK / FAIL 
      COMMON /TIME  / TIME0 
      COMMON /KEYWRD/ KEYWRD 
      CHARACTER*80 KEYWRD 
      DIMENSION XVAR(1),GVAR(1) 
      LOGICAL FAIL,REST,SHOWT,RESTO 
      SAVE
C 
      TLEFT=3600. 
      I=INDEX(KEYWRD,' T=') 
      IF (I.NE.0) TLEFT=READA(KEYWRD,I) 
      SHOWT=INDEX(KEYWRD,'TIME').NE.0 
      REST =INDEX(KEYWRD,'REST').NE.0 
      RESTO=.FALSE. 
C     FOR SAVE/RESTART : EQUIVALENCED /OPTIM/ I1(MAXPAR,LEN1),I2(LEN2) 
      LEN1=2*(3*MAXPAR+7) 
      LEN2=19 + 2*(18) 
      IF ( REST ) THEN 
         CALL SAVOPT(LEN1,LEN2,.TRUE.) 
         CALL SCOPY (NVAR,SAVE,1,XVAR,1) 
         IS=ISAVE(1) 
      ENDIF 
C     FIRST CALL TO COMPFG THUS DEFINING ACCURACY EG(3) ON GRADIENT 
      CALL SECOND (TIME) 
      CALL COMPFG(XVAR,EOPT,FAIL,GVAR,.TRUE.) 
      CALL SECOND (TFLY) 
      TIME=TFLY-TIME 
      IFLEPO=13 
C     TAKE STANDARD OPTION    DSTEP  : STEP FOR HESSIAN 
C                             DMAX   : GREATEST STEP LENGTH IN SEARCHES 
C                             MAXFUN : MAXIMUM NUMBER OF GRADIENT CALLS 
C     DSTEP AND DMAX ARE ALSO INFLUENCING THE BEHAVIOR OF THE METHOD... 
C     PLEASE READ THE POWELL PAPER BEFORE HAZARDOUS MODIFICATIONS. 
C                     (REFERENCE IN 'POWEL1') 
      DSTEP=0.03D0 
      DMAX=0.3D0 
      MAXFUN=5*NVAR 
      EPS=1.D0 
      IF(INDEX(KEYWRD,'PRECI') .NE. 0) THEN 
         EPS=EPS*0.1D0 
         DSTEP=DSTEP*0.5D0 
         MAXFUN=MAXFUN*2 
      ENDIF 
C     OR OVERREAD WITH SPECIFIED CRITERIA 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF(IMP.NE.0) IMP=READA(KEYWRD,IMP) 
      I=INDEX(KEYWRD,'CYCLES=') 
      IF(I.NE.0) MAXFUN=READA(KEYWRD,I) 
      I=INDEX(KEYWRD,'GNORM=') 
      IF(I.NE.0) EPS=ABS(READA(KEYWRD,I))/SQRT(FLOAT(NVAR)) 
      EPS=DMAX1(EPS,EG(1)*DSQRT(DFLOAT(NVAR))) 
      ACC=NVAR*EPS**2 
      WRITE(IPRT,110) NVAR,MAXFUN,EPS 
      WRITE (IPRT,120) EG(1),DSTEP,DMAX 
C     CHECK DATA AND TIMING 
      WRITE(IPRT,170) TIME 
      CALL SECOND (TFLY) 
      IF(TLEFT-2.D0*TIME.LT.TFLY-TIME0) THEN 
         RMS=SQRT(DOT(GVAR,GVAR,NVAR)/FLOAT(NVAR)) 
         IF(RMS.GE.EPS) THEN 
            TIMIN=TIME*3.D0 
            TIME=(NVAR+2)*TIME 
            WRITE(IPRT,180) TLEFT,TIME,TIMIN 
            FAIL=.TRUE. 
         ENDIF 
      ENDIF 
      IF (NVAR.LE.1) THEN 
         WRITE (IPRT,130) 
         FAIL=.TRUE. 
      ELSE IF (MAXFUN.LT.NVAR+2 .AND..NOT.REST) THEN 
         WRITE (IPRT,150) NVAR+2 
         FAIL=.TRUE. 
      ENDIF 
      IF (FAIL) THEN 
         WRITE(IPRT,190) 
         STOP 
      ENDIF 
C     START OR RESTART THE RUN 
      IF ( REST ) THEN 
         GO TO 4 
      ELSE 
         CALL POWEL1 (A,B,AJINV,XVAR,GVAR,NVAR,EOPT,DSTEP,DMAX,ACC 
     .               ,MAXFUN,IS) 
      ENDIF 
C 
C     ITERATION WITH RESTORE OF DENSITY MATRICES IF SCF DIVERGENCE 
C 
    2 CALL SECOND (TIME) 
      CALL COMPFG (XVAR,EOPT,FAIL,GVAR,.TRUE.) 
      IF (FAIL) GO TO 11 
      RESTO=.FALSE. 
      CALL SECOND (TFLY) 
      TIME=TFLY-TIME 
      IF(SHOWT) WRITE(IPRT,100) TIME,TFLY-TIME0 
      IF(TLEFT-2.D0*TIME.LT.TFLY-TIME0) THEN 
         CALL SCOPY (NVAR,XVAR,1,SAVE,1) 
         ISAVE(1)=IS 
         CALL SAVOPT(LEN1,LEN2,.FALSE.) 
         METHOD=1 
         IFLEPO=12 
         RETURN 
      ENDIF 
    4 CALL POWEL2 (A,B,AJINV,XVAR,GVAR,NVAR,EOPT,DSTEP,DMAX,ACC,MAXFUN 
     .            ,IS) 
      IF (FAIL)    GO TO 10 
      IF (IS.NE.6) GO TO 2 
C 
C     TERMINATION OR ERROR 
C 
    5 CALL COMPFG (XVAR,EOPT,FAIL,GVAR,.FALSE.) 
      METHOD=0 
      IFLEPO=11 
      IF (.NOT.FAIL) RETURN 
C     2-TIME SCF DIVERGENCE OR POWELL COMPLETION 
   10 WRITE(IPRT,140) IS 
      METHOD=1 
      IFLEPO=12 
      IF (IS.EQ.6) RETURN 
      CALL POWEL3 (A,B,AJINV,XVAR,GVAR,NVAR,EOPT) 
      GO TO 5 
   11 WRITE(IPRT,160) 
      IF ( RESTO ) THEN 
         IS=6 
         GO TO 10 
      ELSE 
         RESTO=.TRUE. 
         GO TO 2 
      ENDIF 
  100 FORMAT(' ELAPSED TIME IN''POWELL''=',F9.3,'   INTEGRAL=',F10.3, 
     .       ' SECOND') 
  110 FORMAT(//' STATIONARY POINT RESEARCH ... NUMBER OF VARIABLES',I3/ 
     * 6X,'MAXIMUM NUMBER OF GRADIENT CALLS',I6/ 
     *' REQUIRED CONVERGENCE ON RMS GRADIENT',1PD9.1) 
  120 FORMAT(' ERROR ON DERIVATIVES:',1PD10.2,6X,'STEP FOR HESSIAN:', 
     * D10.2,'< ',D10.2) 
  130 FORMAT(' POWELL METHOD REQUIRE AT LEAST TWO VARIABLES ... STOP') 
  140 FORMAT(' S.C.F.OR POWELL DIVERGENCE IN A BRANCH IS=',I2,'  STOP') 
  150 FORMAT(' THE MAXIMUM NUMBER OF CYCLES MUST BE GREATER THAN',I4) 
  160 FORMAT(' *** WARNING FROM ''POWELL'' ***  SCF PROBLEMS...'/ 
     .       ' RESTORE DENSITY MATRICES AND TRY AGAIN') 
  170 FORMAT(' TYPICAL TIME FOR ONE CYCLE OF ''POWELL''=',F9.3) 
  180 FORMAT(' WARNING ... THE ALLOWED TIME (',F10.3,') IS TOO SMALL' 
     ./' FOR A SIGNIFICANT IMPROVEMENT TO BE OBTAINED BY ''POWELL'' .' 
     ./' A MINIMUM VALUE FOR THE ALLOWED TIME SHOULD BE :',F11.3, 
     ./' START AGAIN WITH AT LEAST T=',F10.3) 
  190 FORMAT(/' *****   RUN STOPPED AT THIS POINT.   *****'/) 
      END 
      SUBROUTINE POWEL1 (A,B,AJINV,X,F,N,E,DSTEP,DMAX,ACC,MAXFUN,IS) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C 
C     GRADIENT NORM MINIMIZATION BY VARIABLE METRIC METHOD 
C     REFERENCE : 
C     M.J.D POWELL IN NUMERICAL METHODS FOR NONLINEAR ALGEBRAIC 
C                     EQUATIONS (P.RABINOWITZ ED.) GORDON.BREACH (1970) 
C 
C---------------------- 
C     SIZE   /OPTIM/ ...AJINV(N,N)...A(N,N)...W(5*N)...B(N,N)...VALU(N) 
      COMMON /OPTIM/ IPRINT,IMP0,LEC,IPRT,AJINVM(MAXPAR,MAXPAR) 
     .              ,AM(MAXPAR,MAXPAR),W(MAXPAR*5),BM(MAXPAR,MAXPAR) 
     .              ,VALU(MAXPAR) 
     .              ,DD,DM,DN,DS,DW,PA,PJ,SP,DSS,DMM,FNP,FSQ,FMIN,TINC 
     .              ,DTEST,DMULT,ANMULT,EMIN 
     .              ,I,J,K,IC,MW,NDC,ND,NF,NX,NT,NW,MAXC,NTEST 
     .              ,JACOB 
      COMMON /SCFOK/ FAIL 
      DIMENSION X(N),F(N) 
      DIMENSION A(N,N),B(N,N),AJINV(N,N) 
      LOGICAL FAIL,JACOB 
      CHARACTER*8 NEWTON,GRADIE,HYBRID,EXTRA,BLANK,CHEMIN 
      DATA NEWTON,   GRADIE,     HYBRID,    EXTRA,     BLANK 
     ./  ' NEWTON ','GRADIENT',' HYBRID ',' EXTRA  ','        '/ 
      SAVE
C     SET VARIOUS PARAMETERS 
      CHEMIN=BLANK 
      JACOB=.FALSE. 
      MAXC=0 
C     MAXC IS THE NUMBER OF GRADIENT CALLS 
      NT=N+4 
      NTEST=NT 
C     NT AND NTEST CAUSE AN ERROR RETURN IF F(X) DOES NOT INCREASE 
      DTEST=FLOAT(N+N)-0.5D0 
C     DTEST IS USED TO MAINTAIN LINEAR INDEPENDENCE 
      NX=N*N 
      NF=N 
      NW=NF+N 
      MW=NW+N 
      NDC=MW+N 
      ND=NDC+N 
C     THESE PARAMETERS SEPARATE THE WORKING SPACE ARRAY W 
      FMIN=0.D0 
C     USUALLY FMIN IS THE LEAST CALCULATED VALUE OF F(X), 
C     AND THE BEST X IS IN W(1) TO W(N) 
      DD=0.D0 
C     USUALLY DD IS THE SQUARE OF THE CURRENT STEP LENGTH 
      DSS=DSTEP*DSTEP 
      DM=DMAX*DMAX 
      DMM=4.D0*DM 
      IS=5 
C     IS CONTROLS A GO TO STATEMENT FOLLOWING A GRADIENT CALL 
      TINC=1.D0 
C     TINC IS USED IN THE CRITERION TO INCREASE THE STEP LENGTH 
C     CALL THE SUBROUTINE "COMPFG" 
    1 MAXC=MAXC+1 
      RETURN 
C 
      ENTRY POWEL2 (A,B,AJINV,X,F,N,E,DSTEP,DMAX,ACC,MAXFUN,IS) 
C     TEST FOR CONVERGENCE 
      FSQ=DOT(F,F,N) 
      IF (FSQ.GT.ACC) GO TO 4 
C     PROVIDE OF FINAL SOLUTION IF REQUESTED 
    3 WRITE (IPRT,7) 
    7 FORMAT(//',FINAL SOLUTION CALCULATED BY POWELL:') 
      IPRINT=MAX0(IPRINT,3) 
      IS=6 
      GO TO 100 
C     TEST FOR ERROR RETURN BECAUSE F(X) DOES NOT DECREASE 
    4 GO TO (10,11,11,10,11),IS 
   10 IF (FSQ.LT.FMIN) GO TO 15 
   20 IF (DD.GT.DSS) GO TO 11 
   12 NTEST=NTEST-1 
      IF (NTEST)13,14,11 
   14 WRITE (IPRT,16) NT 
      FAIL=.TRUE. 
   16 FORMAT(///5X,'ERROR RETURN FROM POWELL BECAUSE ',I5, 
     1' CALLS OF COMPFG FAILED TO IMPROVE THE RESIDUALS') 
      ENTRY POWEL3 (A,B,AJINV,X,F,N,E) 
   17 CALL SCOPY (N,W,1,X,1) 
      CALL SCOPY (N,W(NF+1),1,F,1) 
      FSQ=FMIN 
      E=EMIN 
      GO TO 3 
C     ERROR RETURN BECAUSE A NEW JACOBIAN IS UNSUCCESSFUL 
   13 WRITE (IPRT,19) 
      FAIL=.TRUE. 
   19 FORMAT(///5X,'ERROR RETURN FROM POWELL BECAUSE F(X)', 
     1'FAILED TO DECREASE USING A NEW JACOBIAN') 
      GO TO 17 
   15 NTEST=NT 
C     TEST WHETHER THERE HAVE BEEN MAXFUN CALLS OF COMPFG 
   11 IF (MAXFUN.GT.MAXC) GO TO 22 
   21 WRITE (IPRT,23) MAXC 
      FAIL=.TRUE. 
   23 FORMAT(///5X,'ERROR RETURN FROM POWELL BECAUSE', 
     1'THERE HAVE BEEN ',I5,' CALLS OF COMPFG') 
      IF (FSQ-FMIN)3,17,17 
C     PROVIDE PRINTING IF REQUESTED 
   22 GO TO 100 
C     STORE THE RESULT OF THE INITIAL CALL OF COMPFG 
   30 FMIN=FSQ 
      EMIN=E 
      CALL SCOPY (N,X,1,W,1) 
      CALL SCOPY (N,F,1,W(NF+1),1) 
C     CALCULATE A NEW JACOBIAN APPROXIMATION 
   32 IC=0 
      IS=3 
   33 IC=IC+1 
      X(IC)=X(IC)+DSTEP 
      GO TO 1 
   29 DO 8 I=1,N 
    8 AJINV(I,IC)=(F(I)-W(NF+I))/DSTEP 
      X(IC)=W(IC) 
      IF (IC.LT.N) GO TO 33 
C SYMETRISE THE NEW JACOBIAN (WHICH IS AN HESSIAN) 
      L=N-1 
      DO 34 I=1,L 
      K=I+1 
CDIR$ IVDEP 
      DO 34 J=K,N 
      AJINV(I,J)=(AJINV(I,J)+AJINV(J,I))/2.D0 
   34 AJINV(J,I)=AJINV(I,J) 
      DO 35 I=1,NX 
      B(I,1)=0.D0 
   35 A(I,1)=AJINV(I,1) 
C     CALCULATE THE INVERSE OF THE JACOBIAN AND SET THE DIRECTION MATRIX 
      CALL INVERT(AJINV,N,K,VALU,EPS1) 
      WRITE(IPRT,260) MAXC,K 
      JACOB=.TRUE. 
      K=N+1 
      DO 36 I=1,NX,K 
   36 B(I,1)=1.D0 
      DO 37 I=1,N 
   37 W(NDC+I)=1.D0+FLOAT(N-I) 
  260 FORMAT (' THE HESSIAN AT THE ITERATION',I5,' IS OF INDEX',I4) 
C     START ITERATION BY PREDICTING THE DESCENT AND NEWTON MINIMA 
   38 DO 96 I=1,N 
      X(I)=0.D0 
   96 F(I)=0.D0 
      DO 39 J=1,N 
      WJ=W(NF+J) 
      DO 39 I=1,N 
      X(I)=X(I)-A(J,I)*WJ 
   39 F(I)=F(I)-AJINV(I,J)*WJ 
      DS=DOT(X,X,N) 
      DN=DOT(F,F,N) 
      SP=DOT(X,F,N) 
C     TEST WHETHER A NEARBY STATIONARY POINT IS PREDICTED 
      IF (FMIN*FMIN-DMM*DS)41,41,42 
C     IF SO THEN RETURN OR REVISE JACOBIAN 
   42 GO TO(43,43,44),IS 
   44 WRITE(IPRT,45) 
   45 FORMAT(///5X,'ERROR RETURN FROM POWELL BECAUSE A', 
     1'NEARBY STATIONARY POINT OF F(X) IS PREDICTED') 
      GO TO 17 
   43 NTEST=0 
      CALL SCOPY (N,W,1,X,1) 
      GO TO 32 
C     TEST WHETHER TO APPLY THE FULL NEWTON CORRECTION 
   41 IS=2 
      IF (DN.GT.DD) GO TO 48 
   47 DD=DMAX1(DN,DSS) 
      DS=0.25D0*DN 
      CHEMIN=NEWTON 
      TINC=1.D0 
      IF (DN.GE.DSS) GO TO 58 
   49 IS=4 
      GO TO 80 
C     CALCULATE THE LENGTH OF THE STEEPEST DESCENT STEP 
   48 DO 40 I=1,N 
   40 VALU(I)=0.D0 
      DO 52 J=1,N 
      DO 52 I=1,N 
   52 VALU(I)=VALU(I)+A(I,J)*X(J) 
      DMULT=DOT(VALU,VALU,N) 
      DMULT=DS/DMULT 
      DS=DS*DMULT*DMULT 
C     TEST WHETHER TO USE THE STEEPEST DESCENT DIRECTION 
      IF (DS.LT.DD) GO TO 53 
C     TEST WHETHER THE INITIAL VALUE OF DD HAS BEEN SET 
   54 IF(DD.GT.0.D0) GO TO 56 
   55 DD=DMAX1(DSS,DMIN1(DM,DS)) 
      DS=DS/(DMULT*DMULT) 
      GO TO 41 
C     SET THE MULTIPLIER OF THE STEEPEST DESCENT DIRECTION 
   56 ANMULT=0.D0 
      DMULT=DMULT*DSQRT(DD/DS) 
      CHEMIN=GRADIE 
      GO TO 98 
C     INTERPOLATE THE STEEPEST DESCENT AND THE NEWTON DIRECTIONS 
   53 SP=SP*DMULT 
      ANMULT=(DD-DS)/((SP-DS)+DSQRT((SP-DD)**2+(DN-DD)*(DD-DS))) 
      DMULT=DMULT*(1.D0-ANMULT) 
      CHEMIN=HYBRID 
C     CALCULATE THE CHANGE IN X AND ITS ANGLE WITH THE FIRST DIRECTION 
   98 DO 57 I=1,N 
   57 F(I)=DMULT*X(I)+ANMULT*F(I) 
      DN=DOT(F,F,N) 
      SP=DOT(F,B(1,1),N) 
      DS=0.25D0*DN 
C     TEST WHETHER AN EXTRA STEP IS NEEDED FOR INDEPENDENCE 
      IF (W(NDC+1).LE.DTEST) GO TO 58 
   59 IF(SP*SP-DS)60,58,58 
C     TAKE THE EXTRA STEP AND UPDATE THE DIRECTION MATRIX 
   50 IS=2 
      CHEMIN=EXTRA 
CDIR$ IVDEP 
   60 DO 61 I=1,N 
      VALU(I)=B(I,1) 
      X(I)=W(I)+DSTEP*B(I,1) 
   61 W(NDC+I)=W(NDC+I+1)+1.D0 
      W(ND)=1.D0 
      K=NX-N 
      CALL SCOPY (K,B(N+1,1),1,B,1) 
      CALL SCOPY (N,VALU,1,B(1,N),1) 
      GO TO 1 
C     EXPRESS THE DIRECTION IN TERMS OF THOSE OF THE DIRECTION MATRIX, 
C     AND UPDATE THE COUNTS IN W(NDC+1) ETC. 
   58 SP=0.D0 
      DO 64 I=1,N 
      X(I)=DW 
      DW=DOT(F,B(1,I),N) 
      GO TO (68,66),IS 
   66 W(NDC+I)=W(NDC+I)+1.D0 
      SP=SP+DW*DW 
      IF (SP.LE.DS) GO TO 64 
      IS=1 
      KK=I 
      X(1)=DW 
      GO TO 69 
   68 X(I)=DW 
   69 W(NDC+I)=W(NDC+I+1)+1.D0 
   64 CONTINUE 
      W(ND)=1.D0 
C     REORDER THE DIRECTIONS SO THAT KK IS FIRST 
      IF (KK.LE.1)GO TO 70 
      CALL SCOPY (N,B(1,KK),1,VALU,1) 
      K=N*KK 
      L=N+1 
CDIR$ IVDEP 
      DO 72 I=K,L,-1 
   72 B(I,1)=B(I-N,1) 
      CALL SCOPY (N,VALU,1,B,1) 
C     GENERATE THE NEW ORTHOGONAL DIRECTION MATRIX 
   70 DO 74 I=1,N 
   74 W(NW+I)=0.D0 
      SP=X(1)*X(1) 
      DO 75 I=2,N 
      DS=DSQRT(SP*(SP+X(I)*X(I))) 
      DW=SP/DS 
      DS=X(I)/DS 
      SP=SP+X(I)*X(I) 
      I1=I-1 
      DO 76 J=1,N 
   76 W(NW+J)=W(NW+J)+X(I1)*B(J,I1) 
      DO 75 J=1,N 
   75 B(J,I1)=DW*B(J,I)-DS*W(NW+J) 
      SP=1.D0/DSQRT(DN) 
      DO 77 I=1,N 
   77 B(I,N)=SP*F(I) 
C     CALCULATE THE NEXT VECTOR X, AND PREDICT THE RIGHT HAND SIDES 
CDIR$ IVDEP 
   80 DO 78 I=1,N 
      X(I)=W(I)+F(I) 
   78 W(NW+I)=W(NF+I) 
      DO 79 J=1,N 
      DO 79 I=1,N 
   79 W(NW+I)=W(NW+I)+A(I,J)*F(J) 
      FNP=DOT(W(NW+1),W(NW+1),N) 
C     CALL COMPFG USING THE NEW VECTOR OF VARIABLES 
      GO TO 1 
C     UPDATE THE STEP SIZE 
   27 DMULT=0.9D0*FMIN+0.1D0*FNP-FSQ 
      IF (DMULT.GE.0.D0) GO TO 81 
   82 DD=DMAX1(DSS,0.25D0*DD) 
      TINC=1.D0 
      IF (FSQ-FMIN)83,28,28 
C     TRY THE TEST TO DECIDE WHETHER TO INCREASE THE STEP LENGTH 
   81 SP=0.D0 
      DO 84 I=1,N 
      SP=SP+DABS(F(I)*(F(I)-W(NW+I))) 
   84 VALU(I)=F(I)-W(NW+I) 
      SS=DOT(VALU,VALU,N) 
      PJ=1.D0+DMULT/(SP+DSQRT(SP*SP+DMULT*SS)) 
      SP=DMIN1(4.D0,TINC,PJ) 
      TINC=PJ/SP 
      DD=DMIN1(DM,SP*DD) 
      GO TO 83 
C     IF F(X) IMPROVES STORE THE NEW VALUE OF X 
   87 IF (FSQ.GE.FMIN) GO TO 50 
   83 FMIN=FSQ 
      EMIN=E 
CDIR$ IVDEP 
      DO 88 I=1,N 
      SP=X(I) 
      X(I)=W(I) 
      W(I)=SP 
      SP=F(I) 
      F(I)=W(NF+I) 
      W(NF+I)=SP 
   88 W(NW+I)=-W(NW+I) 
      IF (IS.GT.1) GO TO 50 
C     CALCULATE THE CHANGES IN F AND IN X 
C     AND UPDATE THE APPROXIMATIONS TO J AND TO AJINV 
CDIR$ IVDEP 
   28 DO 90 I=1,N 
      X(I)=X(I)-W(I) 
      F(I)=F(I)-W(NF+I) 
      VALU(I)=0.D0 
      W(MW+I)=X(I) 
   90 W(NW+I)=F(I) 
      DO 91 J=1,N 
CDIR$ IVDEP 
      DO 91 I=1,N 
      VALU(I)=VALU(I)+AJINV(J,I)*X(J) 
      W(NW+I)=W(NW+I)-A(I,J)*X(J) 
   91 W(MW+I)=W(MW+I)-AJINV(I,J)*F(J) 
      SP=DOT(VALU,F,N) 
      SS=DOT(X,X,N) 
      CALL SCOPY (N,VALU,1,F,1) 
      DMULT=1.D0 
      IF (DABS(SP).GE.0.1D0*SS) GO TO 95 
   94 DMULT=0.8D0 
   95 PJ=DMULT/SS 
      PA=DMULT/(DMULT*SP+(1.D0-DMULT)*SS) 
      DO 97 I=1,N 
      SP=PJ*W(NW+I) 
      SS=PA*W(MW+I) 
      DO 97 J=1,N 
      A(I,J)=A(I,J)+SP*X(J) 
   97 AJINV(I,J)=AJINV(I,J)+SS*F(J) 
      GO TO 38 
C     EDITING ON UNIT 6 AND DISPATCHING ACCORDING TO IS 
  100 IF (IPRINT.LE.0.OR.IS.EQ.3) GO TO 120 
      RMS=DSQRT(FSQ/FLOAT(N)) 
      SQRDD=DSQRT(DD) 
      WRITE (IPRT,200) MAXC,E,FSQ,RMS,CHEMIN,SQRDD 
      IF (IPRINT.LT.2) GO TO 120 
      WRITE (IPRT,210) X 
      IF (IS.NE.6) GO TO 115 
      IF (JACOB) THEN 
         DO 105 I=1,N 
  105    W(I)=0.D0 
         DO 110 J=1,N 
         DO 110 I=1,N 
  110    W(I)=W(I)-AJINV(I,J)*F(J) 
         WRITE (IPRT,230)(W(I),I=1,N) 
         L=N-1 
         DO 112 I=1,L 
         K=I+1 
CDIR$ IVDEP 
         DO 112 J=K,N 
         AJINV(I,J)=(AJINV(I,J)+AJINV(J,I))/2.D0 
  112    AJINV(J,I)=AJINV(I,J) 
         CALL INVERT (AJINV,N,I,VALU,EPS1) 
         WRITE (IPRT,250) I 
      ENDIF 
      WRITE (IPRT,220) F 
      RETURN 
  115 IF(IPRINT.GE.3) WRITE (IPRT,220) F 
  120 GO TO (27,28,29,87,30),IS 
      WRITE (IPRT,240) IS 
      IS=6 
      GO TO 100 
C 
  200 FORMAT(//' ITE',I4,3X,'ENERGY=',1PD13.5,2X,'<G!G>=',D15.8, 
     1 2X,'RMS GRAD=',D15.8/11X,'CORRECTION OF ',A8,' TYPE', 
     2 5X,'PREDICTED STEP LENGTH:',1PD11.3) 
  210 FORMAT(' COORD  ',1P,6D12.4/(8X,6D12.4)) 
  220 FORMAT(' GRAD.  ',1P,6D12.4/(8X,6D12.4)) 
  230 FORMAT(' SQ.DEV.',1P,6D12.4/(8X,6D12.4)) 
  240 FORMAT(' ERROR ON ''IS'' VALUE IN POWELL...STOP.IS=',I5) 
  250 FORMAT(' NUMBER OF NEGATIVE EIGENVALUE:',I3,' (ESTIMATE)') 
      END 
      SUBROUTINE POWSQ(XPARAM, NVAR, FUNCT) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XPARAM(*) 
********************************************************************** 
* 
*   POWSQ OPTIMISES THE GEOMETRY BY MINIMISING THE GRADIENT NORM. 
*         THUS BOTH GROUND AND TRANSITION STATE GEOMETRIES CAN BE 
*         CALCULATED. IT IS ROUGHLY EQUIVALENT TO FLEPO, FLEPO MINIMISES 
*         THE ENERGY, POWSQ MINIMISES THE GRADIENT NORM. 
* 
*  ON ENTRY XPARAM = VALUES OF PARAMETERS TO BE OPTIMISED. 
*           NVAR   = NUMBER OF PARAMETERS TO BE OPTIMISED. 
* 
*  ON EXIT  XPARAM = OPTIMISED PARAMETERS. 
*           FUNCT  = HEAT OF FORMATION IN KCALS. 
* 
********************************************************************** 
C        *****  ROUTINE PERFORMS  A LEAST SQUARES MINIMIZATION  ***** 
C        *****  OF A FUNCTION WHICH IS A SUM OF SQUARES.        ***** 
C        *****  INITIALLY WRITTEN BY J.W. MCIVER JR. AT SUNY/   ***** 
C        *****  BUFFALO, SUMMER 1971.  REWRITTEN AND MODIFIED   ***** 
C        *****  BY A.K. AT SUNY BUFFALO AND THE UNIVERSITY OF   ***** 
C        *****  TEXAS.  DECEMBER 1973                           ***** 
C        HOUSE-KEEPING BY D.L. (DEWAR GROUP, JULY 1985) 
C 
      COMMON /LAST  / LAST 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TIME  / TIME0 
      COMMON /GRADNT/ GRAD(MAXPAR),GNFIN 
      COMMON /NUMCAL/ NUMCAL 
      COMMON /MESAGE/ IFLEPO,ISCF 
      COMMON /PRECI / SCFCV,SCFTOL,EG(3),DUM(6),KDUM(MAXPAR) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,HESS(MAXPAR,MAXPAR),PMAT(MAXHES) 
     1               ,BMAT(MAXPAR,MAXPAR),GMIN1(MAXPAR),GMIN 
     2               ,IDUM,LOOP,SIG(MAXPAR),XBEST(MAXPAR),GNEXT,AMIN 
     3               ,ANEXT,PVEC(MAXPAR*MAXPAR),EIG(MAXPAR),P(MAXPAR) 
     4               ,Q(MAXPAR), WORK(MAXPAR),GNEXT1(MAXPAR) 
      LOGICAL DEBUG, RESTRT, TIMES, FAIL, OK 
      CHARACTER*80 KEYWRD 
      CHARACTER SPACE*1, CHDOT*1, ZERO*1, NINE*1, CH*1 
      DATA SPACE,CHDOT,ZERO,NINE /' ','.','0','9'/ 
      DATA  ICALCN /0/ 
      SAVE
C 
C     LENGTH OF DATA TO BE SAVED OR RESTORED IN THE BEGINNING OF THE 
C     COMMON /OPTIM/ I1(MAXPAR,LEN1),I2(LEN2) ... SEE 'SAVOPT'. 
      LEN1=4*MAXPAR+6 
      LEN2=2*MAXHES+8 
      IF(ICALCN.NE.NUMCAL) THEN 
         ICALCN=NUMCAL 
         RESTRT=(INDEX(KEYWRD,'REST') .NE. 0) 
         CALL SECOND (TIME1) 
         TIME2=TIME1 
         TIMES=(INDEX(KEYWRD,'TIME') .NE. 0) 
         TOTIME=3600 
         I=INDEX(KEYWRD,' T=') 
         IF(I.NE.0) THEN 
            TIM=READA(KEYWRD,I) 
            DO 10 J=I+3,80 
               CH=KEYWRD(J:J) 
               IF( CH .NE. CHDOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) 
     1 THEN 
                  IF( CH .EQ. 'M') TIM=TIM*60 
                  GOTO 20 
               ENDIF 
   10       CONTINUE 
   20       TOTIME=TIM 
            WRITE(IPRT,'(//10X,'' TIME FOR THIS STEP ='',F8.2)')TOTIME 
         ENDIF 
         STEP=0.02D0 
         LAST=0 
         LOOP=1 
         XINC=0.00529167D0 
         RHO2=1.D-8 
         NCYCLE=9999 
         I=INDEX(KEYWRD,'CYCLES=') 
         IF(I.NE.0) NCYCLE=READA(KEYWRD,I) 
         GNORM=1.D0 
         IF(INDEX(KEYWRD,'PREC') .NE. 0) GNORM=GNORM*0.1D0 
         I=INDEX(KEYWRD,'GNORM=') 
         IF(I.NE.0) GNORM=READA(KEYWRD,I) 
         DEBUG = (INDEX(KEYWRD,'POWSQ') .NE. 0) 
         IMP=INDEX(KEYWRD,'PRINT=') 
         IF(IMP.NE.0)IMP=READA(KEYWRD,IMP) 
         IF(RESTRT) THEN 
C           RESTORE STORED DATA 
            CALL SAVOPT(LEN1,LEN2,.TRUE.) 
            CALL SCOPY (NVAR,SIG,1,XPARAM,1) 
            IF(LOOP .GT. 0) THEN 
               WRITE(IPRT,'(//10X,'' RESTARTING AT POINT'',I3)')LOOP 
            ELSE 
               WRITE(IPRT,'(//10X,'' RESTARTING IN OPTIMISATION'', 
     1         '' ROUTINES'')') 
            ENDIF 
         ENDIF 
      ENDIF 
C*********************************************************************** 
C     INITIALIZE : FIRST CALL TO COMPFG                                * 
C*********************************************************************** 
      NVAR=ABS(NVAR) 
      IF(DEBUG) THEN 
         WRITE(IPRT,'('' ENTERING POWSQ. XPARAM :'')') 
         WRITE(IPRT,'(8(F10.4))')(XPARAM(I),I=1,NVAR) 
      ENDIF 
      IF( .NOT. RESTRT) THEN 
         CALL COMPFG(XPARAM,FUNCT,FAIL, GRAD, .TRUE.) 
         IF(FAIL) STOP 
         CALL SCOPY (NVAR,XPARAM,1,XBEST,1) 
         IF(DEBUG) THEN 
            WRITE(IPRT,'('' STARTING GRADIENTS'')') 
            WRITE(IPRT,'(3X,8F9.4)')(GRAD(I),I=1,NVAR) 
         ENDIF 
         GMIN=SQRT(DOT(GRAD,GRAD,NVAR)) 
         CALL SCOPY (NVAR,GRAD,1,GMIN1,1) 
      ENDIF 
C*********************************************************************** 
C    NOW TO CALCULATE THE INITIAL HESSIAN MATRIX.                      * 
C*********************************************************************** 
      IF(LOOP.LT.0) GOTO 110 
      DO 40 ILOOP=LOOP,NVAR 
         CALL SECOND (TIME1) 
         XPARAM(ILOOP)=XPARAM(ILOOP) + XINC 
         CALL COMPFG(XPARAM,FUNCT,FAIL, GRAD, .TRUE.) 
         IF(FAIL) STOP 
         IF(DEBUG.OR.IMP.GT.3)WRITE(IPRT,'(I3,12(8F9.4,/3X))') 
     1    ILOOP,(GRAD(J),J=1,NVAR) 
         XPARAM(ILOOP)=XPARAM(ILOOP) - XINC 
         DO 30 J=1,NVAR 
   30    HESS(ILOOP,J)=(GMIN1(J)-GRAD(J))/XINC 
         CALL SECOND (TIME2) 
         TSTEP=TIME2-TIME1 
         IF(TIMES)WRITE(IPRT,'('' TIME FOR STEP:'',F8.2,'' LEFT'',F8.2)' 
     1                 )TSTEP, TOTIME-TIME2+TIME0 
         IF( TOTIME-TIME2+TIME0 .LT. TSTEP*2.D0) THEN 
C           STORE RESULTS TO DATE. 
            LOOP=ILOOP+1 
            CALL SCOPY (NVAR,XPARAM,1,SIG,1) 
            CALL SAVOPT(LEN1,LEN2,.FALSE.) 
            STOP 
         ENDIF 
   40 CONTINUE 
C     CHECK THE INDEX (NUMBER OF NEGATIVE EIGENVALUES) OF THE HESSIAN. 
      K=0 
      DO 50 J=1,NVAR 
      DO 50 I=1,NVAR 
      K=K+1 
   50 PVEC(K)=-0.5D0*(HESS(I,J)+HESS(J,I)) 
      CALL INVERT(PVEC,NVAR,JNDEX,WORK,SUM) 
C     SCALE -HESSIAN MATRIX AND INITIALIZE B MATRIX 
      IF( DEBUG.OR.IMP.GT.3) THEN 
         WRITE(IPRT,'(//10X,''UN-NORMALISED HESSIAN MATRIX'')') 
         DO 60 I=1,NVAR 
   60    WRITE(IPRT,'(8F10.4)')(HESS(J,I),J=1,NVAR) 
      ENDIF 
      DO 80 I=1,NVAR 
         SUM=1.D0/SQRT(SDOT(NVAR,HESS(I,1),MAXPAR,HESS(I,1),MAXPAR)) 
         DO 70 J=1,NVAR 
            BMAT(I,J)=0.D0 
   70    HESS(I,J) = HESS(I,J)*SUM 
   80    BMAT(I,I)=SUM*2.D0 
      IF( DEBUG.OR.IMP.GT.3) THEN 
         WRITE(IPRT,'(//10X,''HESSIAN MATRIX'')') 
         DO 90 I=1,NVAR 
   90    WRITE(IPRT,'(8F10.4)')(HESS(J,I),J=1,NVAR) 
      ENDIF 
************************************************************************ 
*  THIS IS THE START OF THE BIG LOOP TO OPTIMISE THE GEOMETRY.         * 
************************************************************************ 
      LOOP=-99 
      TSTEP=TSTEP*4 
C     DEFINE TOL2, THE CONVERGENCE THRESHOLD ON THE GRADIENT NORM. 
      TOL2=GNORM*SQRT(FLOAT(NVAR)) 
      SUM=(EG(1)+EG(2)+EG(3))*0.866D0 
      TOL2=MAX(SUM,TOL2) 
      WRITE(IPRT,100)TOL2,NCYCLE,GMIN,JNDEX 
  100 FORMAT('0MINIMIZATION OF THE GRADIENT NORM BY ''SIGMA''...' 
     ./' CONVERGENCE THRESHOLD ON THE GRADIENT NORM :',1P,D10.2 
     ./' MAXIMUM NUMBER OF CYCLE :',0P,I4 
     ./'     AT THE STARTING POINT THE GRADIENT NORM IS :',1P,D10.2 
     ./'                           THE INDEX OF THE HESSIAN IS :',0P,I3) 
  110 IFAIL=0 
      DO 500 LLOOP = 1,NCYCLE 
      IF( TOTIME-TIME2+TIME0 .LT. TSTEP*2.D0) THEN 
C        STORE RESULTS TO DATE. 
         CALL SCOPY (NVAR,XPARAM,1,SIG,1) 
         CALL SAVOPT(LEN1,LEN2,.FALSE.) 
         STOP 
      ENDIF 
C     FORM-A- DAGGER-A- IN PA SLONG WITH -P- 
      IJ=0 
      DO 120 J=1,NVAR 
      P(J)=SDOT(NVAR,HESS(J,1),MAXPAR,GMIN1,1) 
      DO 120 I=1,J 
      IJ=IJ+1 
  120 PMAT(IJ) = SDOT(NVAR,HESS(I,1),MAXPAR,HESS(J,1),MAXPAR) 
      IF(DEBUG.OR.IMP.GT.3) THEN 
         WRITE(IPRT,'(/10X,''P MATRIX IN POWSQ'')') 
         CALL VECPRT(PMAT,NVAR) 
      ENDIF 
      CALL HQRII(PMAT,NVAR,NVAR,EIG,PVEC) 
C     FIND -Q- VECTOR AS FOLLOWS : 
C     CHECK FOR ZERO EIGENVALUE, 
      IF(EIG(1).LT.RHO2) THEN 
C        TAKE -Q- VECTOR AS EIGENVECTOR OF ZERO EIGENVALUE. 
         CALL SCOPY (NVAR,PVEC,1,Q,1) 
      ELSE 
C        FORM INVERSE BY BACK TRANSFORMING THE EIGENVECTORS, 
         IJ=0 
         DO 140 I=1,NVAR 
         IK=I 
         DO 130 K=1,NVAR 
         WORK(K)=PVEC(IK)/EIG(K) 
  130    IK=IK+NVAR 
         DO 140 J=1,I 
         IJ=IJ+1 
  140    PMAT(IJ) = SDOT(NVAR,PVEC(J),NVAR,WORK,1) 
C        FIND -Q- VECTOR. 
         CALL SUPDOT (Q,PMAT,P,NVAR,1) 
      ENDIF 
C     FIND SEARCH DIRECTION 
      DO 150 I=1,NVAR 
  150 SIG(I) = SDOT(NVAR,Q,1,BMAT(I,1),MAXPAR) 
C     DO A ONE DIMENSIONAL SEARCH 
      IF (DEBUG.OR.IMP.GT.2) THEN 
         WRITE(IPRT,'('' SEARCH VECTOR'')') 
         WRITE(IPRT,'(8F10.5)')(SIG(I),I=1,NVAR) 
      ENDIF 
      CALL SEARCH(XPARAM, ALPHA, NVAR, GMIN, OK) 
C     SAVE THE BEST TRIAL POINT IN XBEST. 
      IF (.NOT.OK) THEN 
         IFAIL=IFAIL+1 
         IF(IFAIL.GE.NVAR/2) THEN 
           WRITE(IPRT,'('' NO IMPROVEMENT OF THE GRADIENT NORM AFTER'' 
     .                 ,I3,'' CYCLES ... STOP'')')IFAIL 
           IFLEPO=12 
           GO TO 610 
         ENDIF 
      ELSE 
         IFAIL=0 
         CALL SCOPY (NVAR,XPARAM,1,XBEST,1) 
      ENDIF 
C     CONVERGENCE CRITERIA ON GRADIENT NORM AND COMPONENTS. 
      IF( NVAR .EQ. 1) GOTO 600 
      IF(GMIN.LE.TOL2) THEN 
         RMX = 0.0D0 
         DO 160 K=1,NVAR 
  160    RMX=MAX(ABS(GMIN1(K)),RMX) 
         IF(RMX.LT.2.5D0*GNORM) GO TO 600 
      ENDIF 
C     TWO STEP ESTIMATION OF DERIVATIVES,USING GNEXT1 & GMIN1 
      DO 170 K=1,NVAR 
  170 WORK(K) = (GMIN1(K)-GNEXT1(K))/(AMIN-ANEXT) 
      RMU =-DOT(WORK,GMIN1,NVAR)/(GMIN**2) 
      CALL SAXPY (NVAR,RMU,GMIN1,1,WORK,1) 
C     SCALE -WORK- AND -SIG- 
      SK = 1.0D0/SQRT(DOT(WORK,WORK,NVAR)) 
      DO 180 K=1,NVAR 
      SIG(K)  = SK*SIG(K) 
  180 WORK(K) = SK*WORK(K) 
C     FIND INDEX OF REPLACEMENT DIRECTION 
      PMAX = ABS(P(1)*Q(1)) 
      ID=1 
      DO 190 I=2,NVAR 
         IF(ABS(P(I)*Q(I)).GT.PMAX) THEN 
            PMAX = ABS(P(I)*Q(I)) 
            ID = I 
         ENDIF 
  190 CONTINUE 
C     REPLACE APPROPRIATE DIRECTION, DERIVATIVE & STARTING POINT 
      DO 200 K=1,NVAR 
      HESS(ID,K) = -WORK(K) 
  200 BMAT(K,ID) = SIG(K)/0.529167D0 
      IF(DEBUG.OR.IMP.GT.0)WRITE(IPRT,'('' CYCLE'',I4,''   GRADIENT ='' 
     .,F8.2)')LLOOP,GMIN 
      IF(DEBUG.OR.IMP.GT.1)WRITE(IPRT,'('' REPLACING DIRECTION'',I4)')ID 
      TIME1=TIME2 
      CALL SECOND (TIME2) 
      TSTEP=TIME2-TIME1 
      IF(TIMES)WRITE(IPRT,'('' TIME FOR STEP:'',F8.2,'' LEFT'',F8.2)') 
     1TSTEP, TOTIME-TIME2+TIME0 
  500 CONTINUE 
C     MAXIMUM NUMBER OF CYCLES EXCEEDED. 
C 
      WRITE(IPRT,'('' MAXIMUM NUMBER OF CYCLES REACHED IN POWSQ ...'' 
     .,/'' START AGAIN FROM THE LAST POINT IF NECESSARY.'')') 
      IFLEPO=12 
      GO TO 610 
C 
C     CONVERGENCE ACHIEVED 
C 
  600 IFLEPO=11 
  610 LAST=1 
      IJ=0 
      DO 620 I=1,NVAR 
      DO 620 J=1,I 
      IJ=IJ+1 
  620 PMAT(IJ)=-0.5D0*(HESS(I,J)+HESS(J,I)) 
      NMAX=MIN(8,NVAR) 
      CALL HQRII (PMAT,NVAR,NVAR,EIG,PVEC) 
  630 FORMAT(' FIRST EIGENVALUES OF THE FINAL HESSIAN (ESTIMATE) :' 
     .         /1P,8D10.2) 
      WRITE(IPRT,630) (EIG(I),I=1,NMAX) 
      IJ=0 
      K=0 
      DO 650 I=1,NVAR 
      DO 640 J=1,NVAR 
      K=K+1 
  640 BMAT(J,I)=PVEC(K)**2 
      DO 650 J=1,I 
      IJ=IJ+1 
  650 PMAT(IJ)=(HESS(I,J)-HESS(J,I))**2 
      DO 660 I=1,NMAX 
      CALL SUPDOT (WORK,PMAT,BMAT(1,I),NVAR,1) 
  660 EIG(I)=SQRT(DOT(WORK,BMAT(1,I),NVAR))*0.5D0 
      WRITE(IPRT,670) (EIG(I),I=1,NMAX) 
  670 FORMAT(' WITH ERRORS DUE TO THE LACK OF SYMMETRY IN THE HESSIAN:' 
     .         /1P,8D10.2) 
      CALL SCOPY (NVAR,XBEST,1,XPARAM,1) 
      CALL COMPFG(XPARAM,FUNCT,FAIL, GRAD, .TRUE.) 
      GNFIN=SQRT(DOT(GRAD,GRAD,NVAR)) 
      WRITE(IPRT,'('' GRADIENT NORM AT THE FINAL POINT ='',F9.3)')GNFIN 
      RETURN 
      END 
      SUBROUTINE PULAY(F,P,N,FPPF,FOCK,EMAT,LFOCK,NFOCK,MSIZE,START,PL) 
      IMPLICIT REAL (A-H,O-Z) 
************************************************************************ 
* 
*   PULAY USES DR. PETER PULAY'S METHOD FOR CONVERGENCE. 
*         A MATHEMATICAL DESCRIPTION CAN BE FOUND IN 
*         "P. PULAY, J. COMP. CHEM. 3, 556 (1982). 
* 
* ARGUMENTS:- 
*         ON INPUT F      = FOCK MATRIX, PACKED, LOWER HALF TRIANGLE. 
*                  P      = DENSITY MATRIX, PACKED, LOWER HALF TRIANGLE. 
*                  N      = NUMBER OF ORBITALS. 
*                  FPPF   = WORKSTORE OF SIZE MSIZE, CONTENTS WILL BE 
*                           OVERWRITTEN. 
*                  FOCK   =      "       "              "         " 
*                  EMAT   = WORKSTORE OF AT LEAST 15**2 ELEMENTS. 
*                  START  = LOGICAL, = TRUE TO START PULAY. 
*                  PL     = UNDEFINED ELEMENT. 
*      ON OUTPUT   F      = "BEST" FOCK MATRIX, = LINEAR COMBINATION 
*                           OF KNOWN FOCK MATRICES. 
*                  START  = FALSE 
*                  PL     = MEASURE OF NON-SELF-CONSISTENCY 
*                         = \[325]F,P\[345] = F*P - P*F. 
* 
************************************************************************ 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /SCRACH/ WORK(1) 
      DIMENSION EMAT(7,7), EVEC(49), COEFFS(7) 
      DIMENSION F(*), P(*), FPPF(*), FOCK(*) 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST, DEBUG, START 
      DATA FIRST/.TRUE./ 
      SAVE
      IF(FIRST) THEN 
         FIRST=.FALSE. 
         MAXLIM=6 
         DEBUG=(INDEX(KEYWRD,'DEBUGPULAY') .NE.0) 
         START=.TRUE. 
      ENDIF 
      IF(START) THEN 
         LINEAR=(N*(N+1))/2 
         MFOCK=MIN(MSIZE/LINEAR,MAXLIM) 
         IF(DEBUG) WRITE(6,'('' MAXIMUM SIZE IN PULAY:'',I5)')MFOCK 
         NFOCK=1 
         LFOCK=1 
         START=.FALSE. 
      ELSE 
         IF(NFOCK.LT.MFOCK)      NFOCK=NFOCK+1 
         IF(LFOCK.NE.MFOCK)THEN 
            LFOCK=LFOCK+1 
         ELSE 
            LFOCK=1 
         ENDIF 
      ENDIF 
      LBASE=(LFOCK-1)*LINEAR 
* 
*   FIRST, STORE FOCK MATRIX FOR FUTURE REFERENCE. 
* 
      CALL SCOPY (LINEAR,F,1,FOCK(LBASE+1),1) 
* 
*   NOW FORM /FOCK*DENSITY-DENSITY*FOCK/, AND STORE THIS IN FPPF 
* 
C     SCALAR VERSION 
C     CALL MAMULT(P,F,FPPF(LBASE+1),N,0.D0) 
C     CALL MAMULT(F,P,FPPF(LBASE+1),N,-1.D0) 
C     CRAY VERSION 
      CALL MAMULT(F,P,N,WORK,WORK(N*N+1),WORK(2*N*N+1),FPPF(LBASE+1)) 
* 
*   FPPF NOW CONTAINS THE RESULT OF FP - PF. 
*   UPDATE SYMMETRIC MATRIX EMAT. 
* 
      NFOCK1=NFOCK+1 
      CALL MXM (FPPF(LBASE+1),1,FPPF,LINEAR,EVEC,NFOCK) 
      DO 10 I=1,NFOCK 
      EMAT(LFOCK,I)=EVEC(I) 
   10 EMAT(I,LFOCK)=EMAT(LFOCK,I) 
      PL=EMAT(LFOCK,LFOCK)/LINEAR 
      CONST=1.D0/EMAT(LFOCK,LFOCK) 
      L=0 
      DO 30 I=1,NFOCK 
         DO 20 J=1,NFOCK 
            L=L+1 
   20    EVEC(L)=EMAT(I,J)*CONST 
         L=L+1 
   30    EVEC(L)=-1.D0 
      DO 40 I=1,NFOCK 
         L=L+1 
   40    EVEC(L)=-1.D0 
      L=L+1 
      EVEC(L)=0.D0 
      IF (DEBUG) THEN 
         WRITE(6,'('' EMAT IN PULAY'')') 
         DO 50 I=1,NFOCK1 
         K=I+NFOCK1*(I-1) 
   50    WRITE(6,'(1P,7E11.4)')(EVEC(J),J=I,K,NFOCK1) 
      ENDIF 
********************************************************************* 
*   THE MATRIX EMAT SHOULD HAVE THE SYMMETRIC FORM 
* 
*      !<E(1)*E(1)>  <E(1)*E(2)> ...   -1.0! 
*      !<E(2)*E(1)>  <E(2)*E(2)> ...   -1.0! 
*      !<E(3)*E(1)>  <E(3)*E(2)> ...   -1.0! 
*      !<E(4)*E(1)>  <E(4)*E(2)> ...   -1.0! 
*      !     .            .      ...     . ! 
*      !   -1.0         -1.0     ...    0. ! 
* 
*   WHERE <E(I)*E(J)> IS THE SCALAR PRODUCT OF \[325]F,P\[345] FOR ITERATION I 
*   TIMES \[325]F,P\[345] FOR ITERATION J. 
* 
********************************************************************* 
      CALL OSINV(EVEC,NFOCK1,D) 
      IF(ABS(D).LT.1.D-10)THEN 
         START=.TRUE. 
         RETURN 
      ENDIF 
      IF(NFOCK.LT.2) RETURN 
      IL=NFOCK*NFOCK1 
      DO 60 I=1,NFOCK 
   60 COEFFS(I)=-EVEC(I+IL) 
      IF(DEBUG) THEN 
         WRITE(6,'('' EVEC'')') 
         WRITE(6,'(7F11.6)')(COEFFS(I),I=1,NFOCK) 
         WRITE(6,'(''    LAGRANGIAN MULTIPLIER (ERROR) ='' 
     1             ,F13.6)')EVEC(NFOCK1*NFOCK1) 
      ENDIF 
* 
*   EXTRAPOLATED FOCK MATRIX 
* 
      CALL MXM (FOCK,LINEAR,COEFFS,NFOCK,F,1) 
      RETURN 
      END 
C     SUBROUTINE MAMULT(A,B,C,N,ONE) 
C     IMPLICIT REAL (A-H,O-Z) 
C     DIMENSION A(*),B(*),C(*) 
************************************************************************ 
* 
*   MAMULT MULTIPLIES MATRIX A BY MATRIX B AND GIVES C=A*B +ONE*C 
*          (DEDICATED TO 'PULAY' ) 
************************************************************************ 
C     L=0 
C     II=0 
C     DO 50 I=1,N 
C        JJ=0 
C        DO 40 J=1,I 
C           SUM=DOT(A(II+1),B(JJ+1),J) 
C           JJ=JJ+J 
C           KK=JJ 
C           DO 20 K=J+1,I 
C           SUM=SUM+A(II+K)*B(J+KK) 
C  20       KK=KK+K 
C           DO 30 K=I+1,N 
C           SUM=SUM+A(I+KK)*B(J+KK) 
C  30       KK=KK+K 
C        L=L+1 
C  40    C(L)=SUM+ONE*C(L) 
C  50 II=II+I 
C     RETURN 
C     END 
      SUBROUTINE MAMULT (F,P,N,FS,PS,FP,FPPF) 
      IMPLICIT REAL (A-H,O-Z) 
C     MAMULT (CRAY VERSION) IS DEDICATED TO ROUTINE 'PULAY' 
C  INPUT 
C     F        : FOCK MATRIX, PACKED CANONICAL 
C     P        : DENSITY MATRIX, PACKED CANONICAL 
C     N        : NUMBER OF ORBITALS 
C     FS,PS,FP : WORK ARRAYS OF SIZE N*N 
C  OUTPUT 
C     FPPF     : COMMUTATOR FP-PF, LOWER TRIANGLE, PACKED CANONICAL 
C 
      DIMENSION F(*),P(*),FS(N,N),PS(N,N),FP(N,N),FPPF(*) 
      SAVE
      L=0 
      DO 10 I=1,N 
CDIR$ IVDEP 
      DO 10 J=1,I 
      L=L+1 
      FS(I,J)=F(L) 
      FS(J,I)=F(L) 
      PS(I,J)=P(L) 
   10 PS(J,I)=P(L) 
      CALL MXM (FS,N,PS,N,FP,N) 
      L=0 
      DO 20 I=1,N 
      DO 20 J=1,I 
      L=L+1 
   20 FPPF(L)=FP(I,J)-FP(J,I) 
      RETURN 
      END 
      SUBROUTINE REACT1(ESCF) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM), NB(NUMATM), NC(NUMATM) 
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR) 
     1       /MOLORB/ USPD(MAXORB),PSPD(MAXORB) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /REACTN/ STEP, GEOA, GEOVEC, CALCST 
      DIMENSION GEOA(3,NUMATM), GEOVEC(3,NUMATM), 
     1          P1STOR(MPACK), P2STOR(MPACK), 
     2          P3STOR(MPACK), XOLD(MAXPAR), GROLD(MAXPAR) 
      LOGICAL GRADNT, FINISH, XYZ, INT, END, FAIL 
************************************************************************ 
* 
*  REACT1 DETERMINES THE TRANSITION STATE OF A CHEMICAL REACTION. 
* 
*   REACT WORKS BY USING TWO SYSTEMS SIMULTANEOUSLY, THE HEATS OF 
*   FORMATION OF BOTH ARE CALCULATED, THEN THE MORE STABLE ONE 
*   IS MOVED IN THE DIRECTION OF THE OTHER. AFTER A STEP THE 
*   ENERGIES ARE COMPARED, AND THE NOW LOWER-ENERGY FORM IS MOVED 
*   IN THE DIRECTION OF THE HIGHER-ENERGY FORM. THIS IS REPEATED 
*   UNTIL THE SADDLE POINT IS REACHED. 
* 
*   IF ONE FORM IS MOVED 3 TIMES IN SUCCESSION, THEN THE HIGHER ENERGY 
*   FORM IS RE-OPTIMIZED WITHOUT SHORTENING THE DISTANCE BETWEEN THE TWO 
*   FORMS. THIS REDUCES THE CHANCE OF BEING CAUGHT ON THE SIDE OF A 
*   TRANSITION STATE. 
* 
************************************************************************ 
      DIMENSION IDUM1(NUMATM), IDUM2(3,NUMATM), XSTORE(MAXPAR), 
     1DUMY(NUMATM), COORD(3,NUMATM), IROT(2,3) 
      CHARACTER*80 KEYWRD 
      DATA IROT/1,2,1,3,2,3/ 
      SAVE
      XYZ=(INDEX(KEYWRD,' XYZ') .NE. 0) 
      GRADNT=(INDEX(KEYWRD,'GRAD') .NE. 0) 
      I=(INDEX(KEYWRD,' BAR=')) 
      STEPMX=0.15D0 
      IF(I.NE.0) STEPMX=READA(KEYWRD,I) 
      MAXSTP=30 
C 
C    READ IN THE SECOND GEOMETRY. 
C 
      IF(XYZ) THEN 
         CALL GETGEO(5,LABELS,GEOA,LOC,NA,NB,NC,DUMY,NATOMS,INT) 
      ELSE 
         CALL GETGEO(5,IDUM1,GEOA,IDUM2, 
     1         IDUM1,IDUM1,IDUM1,DUMY,NATOMS,INT) 
      ENDIF 
      CLOSE (5) 
      CALL SECOND (TIME0) 
C 
C  SWAP FIRST AND SECOND GEOMETRIES AROUND 
C  SO THAT GEOUT CAN OUTPUT DATA ON SECOND GEOMETRY. 
C 
      NUMAT=0 
      DO 10 I=1,NATOMS 
         IF(LABELS(I).NE.99) NUMAT=NUMAT+1 
         CONST=1.D0 
         DO 10 J=1,3 
            X=GEOA(J,I)*CONST 
            CONST=0.0174532925D0 
            GEOA(J,I)=GEO(J,I) 
            GEO(J,I)=X 
   10 CONTINUE 
      WRITE(6,'(//10X,'' GEOMETRY OF SECOND SYSTEM'',/)') 
      CALL GEOUT 
C 
C     CONVERT TO CARTESIAN, IF NECESSARY 
C 
      IF(   XYZ   )THEN 
         CALL GMETRY(GEO,COORD) 
         SUMX=0.D0 
         SUMY=0.D0 
         SUMZ=0.D0 
         DO 20 J=1,NUMAT 
            SUMX=SUMX+COORD(1,J) 
            SUMY=SUMY+COORD(2,J) 
   20    SUMZ=SUMZ+COORD(3,J) 
         SUMX=SUMX/NUMAT 
         SUMY=SUMY/NUMAT 
         SUMZ=SUMZ/NUMAT 
         DO 30 J=1,NUMAT 
            GEO(1,J)=COORD(1,J)-SUMX 
            GEO(2,J)=COORD(2,J)-SUMY 
   30    GEO(3,J)=COORD(3,J)-SUMZ 
         WRITE(6,'(//,''  CARTESIAN GEOMETRY OF FIRST SYSTEM'',//)') 
         WRITE(6,'(3F14.5)')((GEO(J,I),J=1,3),I=1,NUMAT) 
         SUM=0.D0 
         SUMX=0.D0 
         SUMY=0.D0 
         SUMZ=0.D0 
         DO 40 J=1,NUMAT 
            SUM=SUM+(GEO(1,J)-GEOA(1,J))**2 
     1           +(GEO(2,J)-GEOA(2,J))**2 
     2           +(GEO(3,J)-GEOA(3,J))**2 
            SUMX=SUMX+GEOA(1,J) 
            SUMY=SUMY+GEOA(2,J) 
   40    SUMZ=SUMZ+GEOA(3,J) 
         SUM=0.D0 
         SUMX=SUMX/NUMAT 
         SUMY=SUMY/NUMAT 
         SUMZ=SUMZ/NUMAT 
         DO 50 J=1,NUMAT 
            GEOA(1,J)=GEOA(1,J)-SUMX 
            GEOA(2,J)=GEOA(2,J)-SUMY 
            GEOA(3,J)=GEOA(3,J)-SUMZ 
            SUM=SUM+(GEO(1,J)-GEOA(1,J))**2 
     1           +(GEO(2,J)-GEOA(2,J))**2 
     2           +(GEO(3,J)-GEOA(3,J))**2 
   50    CONTINUE 
         DO 100 L=3,1,-1 
C 
C     DOCKING IS DONE IN STEPS OF 16, 4, AND 1 DEGREES AT A TIME. 
C 
            CA=COS(4.D0**(L-1)*0.01745329D0) 
            SA=SQRT(ABS(1.D0-CA**2)) 
            DO 90 J=1,3 
               IR=IROT(1,J) 
               JR=IROT(2,J) 
               DO 80 I=1,10 
                  SUMM=0.D0 
                  DO 60 K=1,NUMAT 
                     X         = CA*GEOA(IR,K)+SA*GEOA(JR,K) 
                     GEOA(JR,K)=-SA*GEOA(IR,K)+CA*GEOA(JR,K) 
                     GEOA(IR,K)=X 
                     SUMM=SUMM+(GEO(1,K)-GEOA(1,K))**2 
     1                         +(GEO(2,K)-GEOA(2,K))**2 
     2                         +(GEO(3,K)-GEOA(3,K))**2 
   60             CONTINUE 
                  IF(SUMM.GT.SUM) THEN 
                     IF(I.GT.1)THEN 
                        SA=-SA 
                        DO 70 K=1,NUMAT 
                           X         = CA*GEOA(IR,K)+SA*GEOA(JR,K) 
                           GEOA(JR,K)=-SA*GEOA(IR,K)+CA*GEOA(JR,K) 
                           GEOA(IR,K)=X 
   70                   CONTINUE 
                        GOTO 90 
                     ENDIF 
                     SA=-SA 
                  ENDIF 
   80          SUM=SUMM 
   90       CONTINUE 
  100    CONTINUE 
         WRITE(6,'(//,''  CARTESIAN GEOMETRY OF SECOND SYSTEM'',//)') 
         WRITE(6,'(3F14.5)')((GEOA(J,I),J=1,3),I=1,NUMAT) 
         WRITE(6,'(//,''   "DISTANCE":'',F13.6)')SUM 
         WRITE(6,'(//,''  REACTION COORDINATE VECTOR'',//)') 
         WRITE(6,'(3F14.5)')((GEOA(J,I)-GEO(J,I),J=1,3),I=1,NUMAT) 
         NA(1)=99 
         J=0 
         NVAR=0 
         DO 120 I=1,NATOMS 
            IF(LABELS(I).NE.99)THEN 
               J=J+1 
               DO 110 K=1,3 
                  NVAR=NVAR+1 
                  LOC(2,NVAR)=K 
  110          LOC(1,NVAR)=J 
               LABELS(J)=LABELS(I) 
            ENDIF 
            NATOMS=NUMAT 
  120    CONTINUE 
      ENDIF 
C 
C   XPARAM HOLDS THE VARIABLE PARAMETERS FOR GEOMETRY IN GEO 
C   XOLD   HOLDS THE VARIABLE PARAMETERS FOR GEOMETRY IN GEOA 
C 
      SUM=0.D0 
      DO 130 I=1,NVAR 
         GROLD(I)=1.D0 
         XPARAM(I)=GEO(LOC(2,I),LOC(1,I)) 
         XOLD(I)=GEOA(LOC(2,I),LOC(1,I)) 
  130 SUM=SUM+(XPARAM(I)-XOLD(I))**2 
      STEP0=SQRT(SUM) 
      GRNOLD=SQRT(FLOAT(NVAR)) 
      ONE=1.D0 
      DELL=0.1D0 
      EOLD=-2000.D0 
      CALL SECOND (TIME1) 
      SWAP=0 
      DO 140 I=1,NORBS 
         J=(I*(I+1))/2 
         P1STOR(J)=PSPD(I) 
         P2STOR(J)=PSPD(I)*0.5D0 
  140 P3STOR(J)=PSPD(I)*0.5D0 
      DO 230 ILOOP=1,MAXSTP 
         CALL SECOND (TIME2) 
         WRITE(6,'('' TIME='',F9.2)')TIME2-TIME1 
         TIME1=TIME2 
C 
C   THIS METHOD OF CALCULATING 'STEP' IS QUITE ARBITARY, AND NEEDS 
C   TO BE IMPROVED BY INTELLIGENT GUESSWORK] 
C 
         IF (GNORM.LT.1.D-3)GNORM=1.D-3 
         WRITE(6,'('' CURRENT BAR, STEPMX, GNORM'',3F12.7)') 
     1STEP0,STEPMX,GNORM 
         STEP=MIN(SWAP,0.5D0, 6.D0/GNORM, DELL,STEPMX*STEP0+0.005D0) 
         SWAP=SWAP+1.D0 
         DELL=DELL+0.1 
         STEP0=STEP0-STEP 
         IF(STEP0.LT.0.01D0) GOTO 240 
         STEP=STEP0 
         DO 150 I=1,NVAR 
  150    XSTORE(I)=XPARAM(I) 
         CALL FLEPO(XPARAM, NVAR, ESCF) 
         DO 160 I=1,NVAR 
  160    XPARAM(I)=GEO(LOC(2,I),LOC(1,I)) 
         WRITE(6,'(//10X,''FOR POINT'',I3)')ILOOP 
         WRITE(6,'('' DISTANCE A - B  '',F12.6)')STEP 
C 
C   NOW TO CALCULATE THE "CORRECT" GRADIENTS, SWITCH OFF 'STEP'. 
C 
         STEP=0.D0 
         CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
         IF(FAIL) STOP 
         GNORM=0.D0 
         COSINE=0.D0 
         DO 180 I=1,NVAR 
         GNORM=GNORM+GRAD(I)*GRAD(I) 
         COSINE=COSINE+GRAD(I)*GROLD(I) 
  180    GROLD(I)=GRAD(I) 
         GNORM=SQRT(GNORM) 
         COSINE=COSINE/(GNORM*GRNOLD) 
         GRNOLD=GNORM 
         IF (GRADNT) THEN 
            WRITE(6,'(''  ACTUAL GRADIENTS OF THIS POINT'')') 
            WRITE(6,'(8F10.4)')(GRAD(I),I=1,NVAR) 
         ENDIF 
         WRITE(6,'('' HEAT            '',F12.6)')FUNCT1 
         GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
         WRITE(6,'('' GRADIENT NORM   '',F12.6)')GNORM 
         COSINE=COSINE*ONE 
         WRITE(6,'('' DIRECTION COSINE'',F12.6)')COSINE 
         CALL GEOUT 
         IF(SWAP.GT.2.9D0 .OR. ILOOP .GT. 3 .AND. COSINE .LT. 0.D0 
     1  .OR. ESCF .GT. EOLD) 
     2  THEN 
            IF(SWAP.GT.2.9D0)THEN 
               SWAP=0.D0 
            ELSE 
               SWAP=0.5D0 
            ENDIF 
C 
C   SWAP REACTANT AND PRODUCT AROUND 
C 
            FINISH=(ILOOP .GT. 3 .AND. COSINE .LT. 0.D0) 
            IF(FINISH) THEN 
               WRITE(6,'(//10X,'' BOTH SYSTEMS ARE ON THE SAME SIDE OF T 
     1HE '',''TRANSITION STATE -'',/10X,'' GEOMETRIES OF THE SYSTEMS'', 
     2'' ON EACH SIDE OF THE T.S. ARE AS FOLLOWS'')') 
               DO 190 I=1,NVAR 
  190          XPARAM(I)=XSTORE(I) 
               CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
               WRITE(6,'(//10X,'' GEOMETRY ON ONE SIDE OF THE TRANSITION 
     1'','' STATE'')') 
               CALL WRITE(TIME0,FUNCT1) 
               IF(FAIL) STOP 
            ENDIF 
            WRITE(6,'(''  REACTANTS AND PRODUCTS SWAPPED AROUND'')') 
            ONE=-1.D0 
            EOLD=ESCF 
            SUM=GOLD 
            GOLD=GNORM 
            GNORM=SUM 
            DO 200 I=1,NATOMS 
               DO 200 J=1,3 
                  X=GEO(J,I) 
                  GEO(J,I)=GEOA(J,I) 
  200       GEOA(J,I)=X 
            DO 210 I=1,NVAR 
               X=XOLD(I) 
               XOLD(I)=XPARAM(I) 
  210       XPARAM(I)=X 
C 
C    I'VE NOT HAD TIME TO WORK OUT THE CORRECT SIZE OFTHEDENSITYMATRICES 
C    SO 6000 IS AN ARBITARY LARGE NUMBER.  THIS SHOULD BE FIXED. 
C 
C    SWAP AROUND THE DENSITY MATRICES. 
C 
            DO 220 I=1,MPACK 
               X=P1STOR(I) 
               P1STOR(I)=P(I) 
               P(I)=X 
               X=P2STOR(I) 
               P2STOR(I)=PA(I) 
               PA(I)=X 
               X=P3STOR(I) 
               P3STOR(I)=PB(I) 
               PB(I)=X 
  220       CONTINUE 
            IF(FINISH) GOTO 240 
         ELSE 
            ONE=1.D0 
         ENDIF 
  230 CONTINUE 
  240 CONTINUE 
      WRITE(6,'('' AT END OF REACTION'')') 
      GOLD=SQRT(DOT(GRAD,GRAD,NVAR)) 
      CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
      GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
      CALL WRITE(TIME0,FUNCT1) 
      IF(FAIL) STOP 
* 
* THE GEOMETRIES HAVE (A) BEEN OPTIMISED CORRECTLY, OR 
*                     (B) BOTH ENDED UP ON THE SAME SIDE OF THE T.S. 
* 
*  TRANSITION STATE LIES BETWEEN THE TWO GEOMETRIES 
* 
      C1=GOLD/(GOLD+GNORM) 
      C2=1.D0-C1 
      WRITE(6,'('' BEST ESTIMATE GEOMETRY OF THE TRANSITION STATE'')') 
      WRITE(6,'(//10X,'' C1='',F8.3,''C2='',F8.3)')C1,C2 
      DO 250 I=1,NVAR 
  250 XPARAM(I)=C1*XPARAM(I)+C2*XOLD(I) 
      CALL COMPFG (XPARAM,FUNCT1,FAIL,GRAD,.TRUE.) 
      CALL WRITE(TIME0,FUNCT1) 
      STOP 
      END 
      SUBROUTINE READ 
      IMPLICIT REAL (A-H, O-Z) 
       INCLUDE "SIZES"
C 
C MODULE TO READ IN GEOMETRY FILE, OUTPUT IT TO THE USER, 
C AND CHECK THE DATA TO SEE IF IT IS REASONABLE. 
C EXIT IF NECESSARY. 
C 
C  ON EXIT NATOMS    = NUMBER OF ATOMS PLUS DUMMY ATOMS (IF ANY). 
C          KEYWRD    = KEYWORDS TO CONTROL CALCULATION 
C          KOMENT    = COMMENT CARD 
C          TITLE     = TITLE CARD 
C          LABELS    = ARRAY OF ATOMIC LABELS INCLUDING DUMMY ATOMS. 
C          GEO       = ARRAY OF INTERNAL COORDINATES. 
C          LOPT      = FLAGS FOR OPTIMIZATION OF MOLECULE 
C          NA        = ARRAY OF LABELS OF ATOMS, BOND LENGTHS. 
C          NB        = ARRAY OF LABELS OF ATOMS, BOND ANGLES. 
C          NC        = ARRAY OF LABELS OF ATOMS, DIHEDRAL ANGLES. 
C          LATOM     = LABEL OF ATOM OF REACTION COORDINATE. 
C          LPARAM    = RC: 1 FOR LENGTH, 2 FOR ANGLE, AND 3 FOR DIHEDRAL 
C          REACT(100)= REACTION COORDINATE PARAMETERS 
C          LOC(1,I)  = LABEL OF ATOM TO BE OPTIMISED. 
C          LOC(2,I)  = 1 FOR LENGTH, 2 FOR ANGLE, AND 3 FOR DIHEDRAL. 
C          NVAR      = NUMBER OF PARAMETERS TO BE OPTIMISED. 
C          XPARAM    = STARTING VALUE OF PARAMETERS TO BE OPTIMISED. 
C 
************************************************************************ 
C *** INPUT THE TRIAL GEOMETRY  \IE.  KGEOM=0\ 
C   LABEL(I) = THE ATOMIC NUMBER OF ATOM\I\. 
C            = 99, THEN THE I-TH ATOM IS A DUMMY ATOM USED ONLY TO 
C              SIMPLIFY THE DEFINITION OF THE MOLECULAR GEOMETRY. 
C   GEO(1,I) = THE INTERNUCLEAR SEPARATION \IN ANGSTROMS\ BETWEEN ATOMS 
C              NA(I) AND (I). 
C   GEO(2,I) = THE ANGLE NB(I):NA(I):(I) INPUT IN DEGREES; STORED IN 
C              RADIANS. 
C   GEO(3,I) = THE ANGLE BETWEEN THE VECTORS NC(I):NB(I) AND NA(I):(I) 
C              INPUT IN DEGREES - STORED IN RADIANS. 
C  LOPT(J,I) = -1 IF GEO(J,I) IS THE REACTION COORDINATE. 
C            = +1 IF GEO(J,I) IS A PARAMETER TO BE OPTIMISED 
C            =  0 OTHERWISE. 
C *** NOTE:    MUCH OF THIS DATA IS NOT        INCLUDED FOR THE FIRST 3 ATOMS. 
C     ATOM1  INPUT LABELS(1) ONLY. 
C     ATOM2  INPUT LABELS(2) AND GEO(1,2) SEPARATION BETWEEN ATOMS 1+2 
C     ATOM3  INPUT LABELS(3), GEO(1,3)    SEPARATION BETWEEN ATOMS 2+3 
C              AND GEO(2,3)              ANGLE ATOM1 : ATOM2 : ATOM3 
C 
************************************************************************ 
C 
      DIMENSION LOPT(3,NUMATM) 
      CHARACTER*80 KEYWRD,KOMENT,TITLE,LINE 
      CHARACTER KEYS(80)*1, SPACE*1, SPACE2*2, CH*1, CH2*2 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TITLES/ KOMENT,TITLE 
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /MESH  / LATOM1, LPARA1, LATOM2, LPARA2 
      COMMON /ISTOPE/ AMS(107) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM) 
     1               ,NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR) 
     1               ,LOCDEP(MAXPAR) 
      COMMON /OPTIM / IMP,IMP0 
      COMMON /PRECI / SCFCV,SCFTOL,EG(3),ESTIM(3),PMAX(3),KTYP(MAXPAR) 
      LOGICAL NOCHEK, INT 
      DIMENSION IZOK(107), IZOKAM1(107), COORD(3,NUMATM),VALUE(40)
      EQUIVALENCE (KEYS(1),KEYWRD) 
************************************************************************ 
*     PERIODIC TABLE OF THE ELEMENTS, A '1' MEANS THAT THE ELEMENT IS 
*     ALLOWED AT THE MNDO LEVEL. 
*GROUP1 2     'F' SHELL                 'D' SHELL           3 4 5 6 7 8 
* 
      DATA IZOK/ 
     11,                                                              0, 
     21,1,                                                  1,1,1,1,1,0, 
     31,0,                                                  1,1,1,1,1,0, 
     41,0,                             0,0,0,1,0,0,0,0,0,1, 0,1,0,0,1,0, 
     50,0,                             0,0,0,0,0,0,0,0,0,0, 0,1,0,0,1,0, 
     60,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,1, 0,1,0,0,0,0, 
     70,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0, 1,1,1,1,1/ 
*
*
      DATA IZOKAM1/
     11,                                                              0,
     20,0,                                                  1,1,1,1,1,0,
     30,0,                                                  1,1,1,1,1,0,
     40,0,                             0,0,0,0,0,0,0,0,0,1, 0,1,0,0,1,0,
     50,0,                             0,0,0,0,0,0,0,0,0,0, 0,1,0,0,1,0,
     60,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,1, 0,0,0,0,0,0,
     70,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0, 1,1,1,1,1/
*
* 
* 99=DUMMY ATOM, 103-106 ARE SPARKLES 
************************************************************************ 
      DATA SPACE, SPACE2/' ','  '/ 
      SAVE
C 
      READ(5,'(A)')KEYWRD,KOMENT,TITLE 
      ILOWA = ICHAR('a') 
      ILOWZ = ICHAR('z') 
      ICAPA = ICHAR('A') 
************************************************************************ 
      DO 10 I=1,80 
         ILINE=ICHAR(KEYWRD(I:I)) 
         IF(ILINE.GE.ILOWA.AND.ILINE.LE.ILOWZ) THEN 
            KEYWRD(I:I)=CHAR(ILINE+ICAPA-ILOWA) 
         ENDIF 
   10 CONTINUE 
************************************************************************ 
      IF(INDEX(KEYWRD,'ECHO').NE.0)THEN 
         REWIND 5 
         DO 30 I=1,1000 
            READ(5,'(A)',END=40)KEYWRD 
            DO 20 J=80,2,-1 
   20       IF(KEYWRD(J:J).NE.' ')GOTO 30 
            J=1 
   30    WRITE(6,'(1X,A)')KEYWRD(1:J) 
      ENDIF 
   40 REWIND 5 
      IF(INDEX(KEYWRD,'ECHO').NE.0)WRITE(6,'(''1'')') 
      READ(5,'(A)')KEYWRD,KOMENT,TITLE 
************************************************************************ 
      DO 50 I=1,80 
         ILINE=ICHAR(KEYWRD(I:I)) 
         IF(ILINE.GE.ILOWA.AND.ILINE.LE.ILOWZ) THEN 
            KEYWRD(I:I)=CHAR(ILINE+ICAPA-ILOWA) 
         ENDIF 
   50 CONTINUE 
************************************************************************ 
      IF(KEYWRD(1:1) .NE. SPACE) THEN 
         CH=KEYWRD(1:1) 
         KEYWRD(1:1)=SPACE 
         DO 60 I=2,80 
            CH2=KEYWRD(I:I) 
            KEYWRD(I:I)=CH 
            CH=CH2 
            IF(KEYWRD(I:I+1) .EQ. SPACE2) GOTO 70 
   60    CONTINUE 
   70    CONTINUE 
      ENDIF 
      NOCHEK=INDEX(KEYWRD,'EXTER').NE.0 
      CALL GETGEO (5,LABELS,GEO,LOPT,NA,NB,NC,AMS,NATOMS,INT) 
C 
C 
C OUTPUT FILE TO UNIT 6 
C 
C    WRITE HEADER 
      IF (INDEX(KEYWRD,'MINDO') .NE. 0) THEN 
         WRITE(6,'(1X,16(''*****'')//29X,''MINDO/3 CALCULATION RESULT 
     1S'',      28X,///1X,16(''*****'') )') 
      ELSE IF (INDEX(KEYWRD,'AM1') .NE. 0) THEN 
         WRITE(6,'(1X,16(''*****'')//29X,''AM1 CALCULATION RESULTS'', 
     1      28X,///1X,16(''*****'') )') 
      ELSE 
         WRITE(6,'(1X,16(''*****'')//29X,''MNDO CALCULATION RESULTS'' 
     1,      28X,///1X,16(''*****'') )') 
      ENDIF 
      WRITE(6,'('' *'',20X,''VERSION '',F5.2)')VERSON 
C 
C CHECK DATA 
C 
      DO 80 I=1,NATOMS 
         IF(.NOT. NOCHEK) THEN 
C
           IF(INDEX(KEYWRD,'AM1') .NE. 0) THEN
            IF (IZOKAM1(LABELS(I)) .EQ. 0 ) THEN 
               WRITE(6,'('' ATOMIC NUMBER '',I3,'' IS NOT AVAILABLE '', 
     1        ''IN AM1'')') LABELS(I) 
               STOP 
            END IF 
           ELSE
            IF (IZOK(LABELS(I)) .EQ. 0 ) THEN 
               WRITE(6,'('' ATOMIC NUMBER '',I3,'' IS NOT AVAILABLE '', 
     1        ''IN MNDO'')') LABELS(I) 
               STOP 
            END IF 
           ENDIF
C
         ENDIF 
         IF (LABELS(I) .LE. 0 ) THEN 
            WRITE(6,'('' ATOMIC NUMBER OF '',I3,'' ?'')') LABELS(I) 
            STOP 
         ENDIF 
         IF (  NA(I).GE.I.OR. NB(I).GE.I.OR. NC(I).GE.I 
     1  .OR. (NA(I).EQ.NB(I))   .AND. I.GT.1 
     2  .OR. (NA(I).EQ.NC(I).OR.NB(I).EQ.NC(I))  .AND. I.GT.2 
     3    ) THEN 
            WRITE(6,'('' ATOM NUMBER '',I3,'' IS ILLDEFINED'')') I 
            STOP 
         ENDIF 
   80 CONTINUE 
C 
C WRITE KEYWORDS BACK TO USER AS FEEDBACK 
      CALL WRTKEY (KEYWRD) 
      WRITE(6,'(1X,80(''*''))') 
C 
C CONVERT ANGLES TO RADIANS 
      DO 90 I=1,NATOMS 
         DO 90 J=2,3 
            GEO(J,I) = GEO(J,I) * 0.01745329252D00 
   90 CONTINUE 
C 
C FILL IN GEO MATRIX IF NEEDED 
      NDEP=0 
      IF( INDEX(KEYWRD,'SYM') .NE. 0) CALL GETSYM 
      IF(NDEP.NE.0) CALL SYMTRY 
C 
C INITIALIZE FLAGS FOR OPTIMIZE AND PATH 
      IFLAG = 0 
      NVAR  = 0 
      LATOM = 0 
      NUMAT=0 
      IMP=INDEX(KEYWRD,'PRINT=') 
      IF(IMP.NE.0) IMP=READA(KEYWRD,IMP) 
      IMP0=IMP 
      DO 120 I=1,NATOMS 
         IF(LABELS(I).NE.99.AND.LABELS(I).NE.107)NUMAT=NUMAT+1 
         DO 120 J=1,3 
            IF (LOPT(J,I) ) 100, 120, 110 
C    FLAG FOR PATH 
  100       CONVRT=1.D0 
            IF ( IFLAG .NE. 0 ) THEN 
               IF (INDEX(KEYWRD,'STEP1').NE.0) THEN 
                  LPARA1=LPARAM 
                  LATOM1=LATOM 
                  LPARA2=J 
                  LATOM2=I 
                  LATOM=0 
                  IFLAG=0 
                  GOTO 120 
               ELSE 
                  WRITE(6,'('' ONLY ONE REACTION COORDINATE PERMITTED'') 
     1') 
                  STOP 
               ENDIF 
            END IF 
            LATOM  = I 
            LPARAM = J 
            IF(J.GT.1) CONVRT=0.01745329252D00 
            REACT(1)  = GEO(J,I) 
            IREACT=1 
            IFLAG = 1 
            GO TO 120 
C    FLAG FOR OPTIMIZE 
  110       NVAR = NVAR + 1 
            LOC(1,NVAR) = I 
            LOC(2,NVAR) = J 
            XPARAM(NVAR)   = GEO(J,I) 
            KTYP(NVAR)=J 
  120 CONTINUE 
C READ IN PATH VALUES 
      IF (IFLAG.EQ.0) GO TO 160 
  130 READ(5,'(A)',END=150) LINE 
      CALL NUCHAR(LINE,VALUE,NREACT) 
      DO 140 I=1,NREACT 
         IJ=IREACT+I 
         IF (IJ.GT.100) THEN 
            WRITE(6,'(///,''    ONLY ONE HUNDRED POINTS ALLOWED IN REACT 
     1ION'','' COORDINATE'')') 
            STOP 
         ENDIF 
  140 REACT(IJ)=VALUE(I)*CONVRT 
      IREACT=IREACT+NREACT 
      GO TO 130 
  150 CONTINUE 
      DEGREE=1.D0 
      IF(LPARAM.GT.1)DEGREE=57.29578D0 
      IF(IREACT.LE.1) THEN 
         WRITE(6,'(//10X,'' NO POINTS SUPPLIED FOR REACTION PATH'')') 
         WRITE(6,'(//10X,'' GEOMETRY AS READ IN IS AS FOLLOWS'')') 
         CALL GEOUT 
         STOP 
      ELSE 
         WRITE(6,'(//10X,'' POINTS ON REACTION COORDINATE'')') 
         WRITE(6,'(10X,8F8.2)')(REACT(I)*DEGREE,I=1,IREACT) 
      ENDIF 
      IEND=IREACT+1 
      REACT(IEND)=-1.D12 
C 
C OUTPUT GEOMETRY AS FEEDBACK 
C 
  160 WRITE(6,'(1X,A)')KEYWRD,KOMENT,TITLE 
      CALL GEOUT 
      IF (INDEX(KEYWRD,'PARAM')+INDEX(KEYWRD,'NOXYZ') .EQ. 0) THEN 
         CALL GMETRY(GEO,COORD) 
         WRITE(6,'(//10X,''CARTESIAN COORDINATES '',/)') 
         WRITE(6,'(4X,''NO.'',7X,''ATOM'',9X,''X'', 
     1  9X,''Y'',9X,''Z'',/)') 
         L=0 
         DO 170 I=1,NATOMS 
            IF(LABELS(I) .EQ. 99.OR.LABELS(I).EQ.107) GOTO 170 
            L=L+1 
            WRITE(6,'(I6,7X,I3,4X,3F10.4)') 
     1  L,LABELS(I),(COORD(J,L),J=1,3) 
  170    CONTINUE 
      ENDIF 
      IF (   INDEX(KEYWRD,' XYZ') .NE.0) THEN 
         IF ( INT.AND.(NDEP .NE. 0 .OR.  NVAR.LT.3*NUMAT-6)) THEN 
            IF (NDEP.NE.0) 
     1WRITE(6,'(//10X,'' INTERNAL COORDINATES READ IN, AND SYMMETRY'' 
     2,/10X,'' SPECIFIED, BUT CALCULATION TO BE RUN IN CARTESIAN '' 
     3,''COORDINATES'')') 
            IF (NVAR.LT.3*NUMAT-6) 
     1WRITE(6,'(//10X,'' INTERNAL COORDINATES READ IN, AND'', 
     2'' CALCULATION '',/10X,''TO BE RUN IN CARTESIAN COORDINATES, '', 
     3/10X,''BUT NOT ALL COORDINATES MARKED FOR OPTIMISATION'')') 
            WRITE(6,'(//10X,'' THIS INVOLVES A LOGICALLLY ABSURD CHOICE' 
     1',/10X,'' SO THE CALCULATION IS TERMINATED AT THIS POINT'')') 
            STOP 
         ENDIF 
         SUMX=0.D0 
         SUMY=0.D0 
         SUMZ=0.D0 
         DO 180 J=1,NUMAT 
            SUMX=SUMX+COORD(1,J) 
            SUMY=SUMY+COORD(2,J) 
  180    SUMZ=SUMZ+COORD(3,J) 
         SUMX=SUMX/NUMAT 
         SUMY=SUMY/NUMAT 
         SUMZ=SUMZ/NUMAT 
         DO 190 J=1,NUMAT 
            GEO(1,J)=COORD(1,J)-SUMX 
            GEO(2,J)=COORD(2,J)-SUMY 
  190    GEO(3,J)=COORD(3,J)-SUMZ 
         NA(1)=99 
         J=0 
         NVAR=1 
         DO 210 I=1,NATOMS 
            IF (LABELS(I).NE.99) THEN 
               J=J+1 
  200          IF (LOC(1,NVAR) .EQ. I) THEN 
                  XPARAM(NVAR)=GEO(LOC(2,NVAR),J) 
C#                      LOC(2,NVAR)=K 
                  LOC(1,NVAR)=J 
                  NVAR=NVAR+1 
                  GOTO 200 
               ENDIF 
               LABELS(J)=LABELS(I) 
            ENDIF 
  210    CONTINUE 
         NVAR=NVAR-1 
         NATOMS=NUMAT 
      ELSE 
         IF ( .NOT. INT.AND.(NDEP .NE. 0 .OR.  NVAR.LT.3*NUMAT-6)) THEN 
            IF (NDEP.NE.0) 
     1WRITE(6,'(//10X,'' CARTESIAN COORDINATES READ IN, AND SYMMETRY'' 
     2,/10X,'' SPECIFIED, BUT CALCULATION TO BE RUN IN INTERNAL '' 
     3,''COORDINATES'')') 
            IF (NVAR.LT.3*NUMAT-6) 
     1WRITE(6,'(//10X,'' CARTESIAN COORDINATES READ IN, AND'', 
     2'' CALCULATION '',/10X,''TO BE RUN IN INTERNAL COORDINATES, '', 
     3/10X,''BUT NOT ALL COORDINATES MARKED FOR OPTIMISATION'')') 
            WRITE(6,'(//10X,''MOPAC, BY DEFAULT, USES INTERNAL COORDINAT 
     1ES'',/10X,''TO SPECIFY CARTESIAN COORDINATES USE KEY-WORD :XYZ:'', 
     2/10X,''YOUR CURRENT CHOICE OF KEY-WORDS INVOLVES A LOGICALLLY '', 
     3/10X,''ABSURD CHOICE SO THE CALCULATION IS TERMINATED AT THIS '' 
     4,''POINT'')') 
            STOP 
         ENDIF 
      ENDIF 
      RETURN 
      END 
      FUNCTION READA (A,ISTART) 
      IMPLICIT REAL (A-H,O-Z) 
      CHARACTER*1 A(80) 
       SAVE
      NINE=ICHAR('9') 
      IZERO=ICHAR('0') 
      MINUS=ICHAR('-') 
      IDOT=ICHAR('.') 
      IDIG=0 
      C1=0 
      C2=0 
      ONE=1.D0 
      X = 1.D0 
      DO 10 J=ISTART,80 
         N=ICHAR(A(J)) 
         IF(N.LE.NINE.AND.N.GE.IZERO .OR. N.EQ.MINUS.OR.N.EQ.IDOT)GOTO 2 
     10 
   10 CONTINUE 
      READA=0.D0 
      RETURN 
   20 CONTINUE 
      DO 30 I=J,80 
         N=ICHAR(A(I)) 
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN 
            IDIG=IDIG+1 
            IF (IDIG.GT.10) GOTO 60 
            C1=C1*10+N-IZERO 
         ELSE IF (N.EQ.MINUS.AND.I.EQ.J) THEN 
            ONE=-1.D0 
         ELSE IF (N.EQ.IDOT) THEN 
            GOTO 40 
         ELSE 
            GOTO 60 
         ENDIF 
   30 CONTINUE 
   40 CONTINUE 
      IDIG=0 
      DO 50 II=I+1,80 
         N=ICHAR(A(II)) 
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN 
            IDIG=IDIG+1 
            IF (IDIG.GT.10) GOTO 60 
            C2=C2*10+N-IZERO 
            X = X /10 
         ELSE 
            GOTO 60 
         ENDIF 
   50 CONTINUE 
C 
C PUT THE PIECES TOGETHER 
C 
   60 CONTINUE 
      READA= ONE * ( C1 + C2 * X) 
      RETURN 
      END 
      SUBROUTINE REPP(NI,NJ,RIJ,RI,CORE) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION RI(22),CORE(4,2) 
      COMMON /MULTIP/ DD(107),QQ(107),ADD(107,3) 
      COMMON /CORE/ TORE(107) 
      COMMON /NATORB/ NATORB(107) 
C*********************************************************************** 
C 
C  REPP CALCULATES THE TWO-ELECTRON REPULSION INTEGRALS AND THE 
C       NUCLEAR ATTRACTION INTEGRALS. 
C 
C     ON INPUT RIJ     = INTERATOMIC DISTANCE 
C              NI      = ATOM NUMBER OF FIRST ATOM 
C              NJ      = ATOM NUMBER OF SECOND ATOM 
C    (REF)     ADD     = ARRAY OF GAMMA, OR TWO-ELECTRON ONE-CENTER, 
C                        INTEGRALS. 
C    (REF)     TORE    = ARRAY OF NUCLEAR CHARGES OF THE ELEMENTS 
C    (REF)     DD      = ARRAY OF DIPOLE CHARGE SEPARATIONS 
C    (REF)     QQ      = ARRAY OF QUADRUPOLE CHARGE SEPARATIONS 
C 
C     THE COMMON BLOCKS ARE INITIALISED IN BLOCK-DATA, AND NEVER CHANGED 
C 
C    ON OUTPUT RI      = ARRAY OF TWO-ELECTRON REPULSION INTEGRALS 
C              CORE    = 4 X 2 ARRAY OF ELECTRON-CORE ATTRACTION 
C                        INTEGRALS 
C 
C*********************************************************************** 
      SAVE
      R=RIJ/0.529167D00 
      PP=2.0D00 
      P2=4.0D00 
      P3=8.0D00 
      P4=16.0D00 
C 
C *** THIS ROUTINE COMPUTES THE TWO-CENTRE REPULSION INTEGRALS AND THE 
C *** NUCLEAR ATTRACTION INTEGRALS. 
C *** THE TWO-CENTRE REPULSION INTEGRALS (OVER LOCAL COORDINATES) ARE 
C *** STORED AS FOLLOWS (WHERE P-SIGMA = O,  AND P-PI = P AND P* ) 
C     (SS/SS)=1,   (SO/SS)=2,   (OO/SS)=3,   (PP/SS)=4,   (SS/OS)=5, 
C     (SO/SO)=6,   (SP/SP)=7,   (OO/SO)=8,   (PP/SO)=9,   (PO/SP)=10, 
C     (SS/OO)=11,  (SS/PP)=12,  (SO/OO)=13,  (SO/PP)=14,  (SP/OP)=15, 
C     (OO/OO)=16,  (PP/OO)=17,  (OO/PP)=18,  (PP/PP)=19,  (PO/PO)=20, 
C     (PP/P*P*)=21,   (P*P/P*P)=22. 
C *** THE STORAGE OF THE NUCLEAR ATTRACTION INTEGRALS  CORE(KL/IJ) IS 
C     (SS/)=1,   (SO/)=2,   (OO/)=3,   (PP/)=4 
C     WHERE IJ=1 IF THE ORBITALS CENTRED ON ATOM I,  =2 IF ON ATOM J. 
C *** NI AND NJ ARE THE ATOMIC NUMBERS OF THE TWO ELEMENTS. 
C 
      DO 10 I=1,22 
   10 RI(I)=0.0D0 
      DO 20 I=1,8 
   20 CORE(I,1)=0.0D0 
C 
C     ATOMIC UNITS ARE USED IN THE CALCULATION 
C     DEFINE CHARGE SEPARATIONS. 
C 
      DA=DD(NI) 
      DB=DD(NJ) 
      QA=QQ(NI) 
      QB=QQ(NJ) 
      TD = 2.D00 
      OD = 1.D00 
      FD = 4.D00 
C 
C     HYDROGEN - HYDROGEN 
C 
      AEE=0.25D00*(OD/ADD(NI,1)+OD/ADD(NJ,1))**2 
      EE=OD/SQRT(R**2+AEE) 
      RI(1)=EE*27.21D00 
      CORE(1,1)=-TORE(NJ)*RI(1) 
      CORE(1,2)=-TORE(NI)*RI(1) 
      IF (NATORB(NI).LT.3.AND.NATORB(NJ).LT.3) RETURN 
      IF (NATORB(NI).LT.3) GO TO 30 
C 
C     HEAVY ATOM - HYDROGEN 
C 
      ADE=0.25D00*(OD/ADD(NI,2)+OD/ADD(NJ,1))**2 
      AQE=0.25D00*(OD/ADD(NI,3)+OD/ADD(NJ,1))**2 
      DZE=-OD/SQRT((R+DA)**2+ADE)+OD/SQRT((R-DA)**2+ADE) 
      QZZE=OD/SQRT((R-TD*QA)**2+AQE)-TD/SQRT(R**2+AQE)+OD/ 
     1SQRT((R+TD*QA)**2+AQE) 
      QXXE=TD/SQRT(R**2+FD*QA**2+AQE)-TD/SQRT(R**2+AQE) 
      DZE=DZE/PP 
      QXXE=QXXE/P2 
      QZZE=QZZE/P2 
      RI(2)=-DZE 
      RI(3)=EE+QZZE 
      RI(4)=EE+QXXE 
      IF (NATORB(NJ).LT.3) GO TO 40 
C 
C     HYDROGEN - HEAVY ATOM 
C 
   30 CONTINUE 
      AED=0.25D00*(OD/ADD(NI,1)+OD/ADD(NJ,2))**2 
      AEQ=0.25D00*(OD/ADD(NI,1)+OD/ADD(NJ,3))**2 
      EDZ=-OD/SQRT((R-DB)**2+AED)+OD/SQRT((R+DB)**2+AED) 
      EQZZ=OD/SQRT((R-TD*QB)**2+AEQ)-TD/SQRT(R**2+AEQ)+OD/ 
     1SQRT((R+TD*QB)**2+AEQ) 
      EQXX=TD/SQRT(R**2+FD*QB**2+AEQ)-TD/SQRT(R**2+AEQ) 
      EDZ=EDZ/PP 
      EQXX=EQXX/P2 
      EQZZ=EQZZ/P2 
      RI(5)=-EDZ 
      RI(11)=EE+EQZZ 
      RI(12)=EE+EQXX 
      IF (NATORB(NI).LT.3) GO TO 40 
C 
C     HEAVY ATOM - HEAVY ATOM 
C     CAUTION. ADD REPLACES ADD(1,1) IN /MULTIP/ AND MUST BE RESET. 
C 
      ADD(1,1)=0.25D00*(OD/ADD(NI,2)+OD/ADD(NJ,2))**2 
      ADQ=0.25D00*(OD/ADD(NI,2)+OD/ADD(NJ,3))**2 
      AQD=0.25D00*(OD/ADD(NI,3)+OD/ADD(NJ,2))**2 
      AQQ=0.25D00*(OD/ADD(NI,3)+OD/ADD(NJ,3))**2 
      DXDX=TD/SQRT(R**2+(DA-DB)**2+ADD(1,1)) 
     1-TD/SQRT(R**2+(DA+DB)**2+ADD(1,1)) 
      DZDZ=OD/SQRT((R+DA-DB)**2+ADD(1,1)) 
     1+OD/SQRT((R-DA+DB)**2+ADD(1,1))-OD/SQRT(( 
     2R-DA-DB)**2+ADD(1,1))-OD/SQRT((R+DA+DB)**2+ADD(1,1)) 
      DZQXX=-TD/SQRT((R+DA)**2+FD*QB**2+ADQ)+TD/SQRT((R-DA)**2 
     1+FD*QB**2+ 
     2ADQ)+TD/SQRT((R+DA)**2+ADQ)-TD/SQRT((R-DA)**2+ADQ) 
      QXXDZ=-TD/SQRT((R-DB)**2+FD*QA**2+AQD)+TD/SQRT((R+DB)**2 
     1+FD*QA**2+ 
     2AQD)+TD/SQRT((R-DB)**2+AQD)-TD/SQRT((R+DB)**2+AQD) 
      DZQZZ=-OD/SQRT((R+DA-TD*QB)**2+ADQ)+OD/SQRT((R-DA-TD* 
     1QB)**2+ADQ)-OD/SQRT((R+DA+TD*QB)**2+ADQ)+OD/SQRT((R-DA+TD*QB) 
     2**2+ADQ)-TD/SQRT((R-DA)**2+ADQ)+TD/SQRT((R+DA)**2+ADQ) 
      QZZDZ=-OD/SQRT((R+TD*QA-DB)**2+AQD)+OD/SQRT((R+TD*QA+ 
     1DB)**2+AQD)-OD/SQRT((R-TD*QA-DB)**2+AQD)+OD/SQRT((R-2.D 
     200*QA+DB)**2+AQD)+TD/SQRT((R-DB)**2+AQD)-TD/SQRT((R+DB)**2 
     3+AQD) 
      QXXQXX=TD/SQRT(R**2+FD*(QA-QB)**2+AQQ)+TD/SQRT(R**2+FD*(QA+QB)**2+ 
     1AQQ)-FD/SQRT(R**2+FD*QA**2+AQQ)-FD/SQRT(R**2+FD*QB**2+AQQ)+FD/SQRT 
     2(R**2+AQQ) 
      QXXQYY=FD/SQRT(R**2+FD*QA**2+FD*QB**2+AQQ)-FD/SQRT(R**2+FD*QA**2+A 
     1QQ)-FD/SQRT(R**2+FD*QB**2+AQQ)+FD/SQRT(R**2+AQQ) 
      QXXQZZ=TD/SQRT((R-TD*QB)**2+FD*QA**2+AQQ)+TD/SQRT((R+TD*QB)**2+FD* 
     1QA**2+AQQ)-TD/SQRT((R-TD*QB)**2+AQQ)-TD/SQRT((R+TD*QB)**2+AQQ)-FD/ 
     2SQRT(R**2+FD*QA**2+AQQ)+FD/SQRT(R**2+AQQ) 
      QZZQXX=TD/SQRT((R+TD*QA)**2+FD*QB**2+AQQ)+TD/SQRT((R-TD*QA)**2+FD* 
     1QB**2+AQQ)-TD/SQRT((R+TD*QA)**2+AQQ)-TD/SQRT((R-TD*QA)**2+AQQ)-FD/ 
     2SQRT(R**2+FD*QB**2+AQQ)+FD/SQRT(R**2+AQQ) 
      QZZQZZ=OD/SQRT((R+TD*QA-TD*QB)**2+AQQ)+OD/SQRT((R+TD*QA+TD*QB)**2+ 
     1AQQ)+OD/SQRT((R-TD*QA-TD*QB)**2+AQQ)+OD/SQRT((R-TD*QA+TD*QB)**2+AQ 
     2Q)-TD/SQRT((R-TD*QA)**2+AQQ)-TD/SQRT((R+TD*QA)**2+AQQ)-TD/SQRT((R- 
     3TD*QB)**2+AQQ)-TD/SQRT((R+TD*QB)**2+AQQ)+FD/SQRT(R**2+AQQ) 
      DXQXZ=-TD/SQRT((R-QB)**2+(DA-QB)**2+ADQ)+TD/SQRT((R+QB)**2+(DA-QB) 
     1**2+ADQ)+TD/SQRT((R-QB)**2+(DA+QB)**2+ADQ)-TD/SQRT((R+QB)**2+(DA+Q 
     2B)**2+ADQ) 
      QXZDX=-TD/SQRT((R+QA)**2+(QA-DB)**2+AQD)+TD/SQRT((R-QA)**2+(QA-DB) 
     1**2+AQD)+TD/SQRT((R+QA)**2+(QA+DB)**2+AQD)-TD/SQRT((R-QA)**2+(QA+D 
     2B)**2+AQD) 
      QXYQXY=FD/SQRT(R**2+TD*(QA-QB)**2+AQQ)+FD/SQRT(R**2+TD*(QA+QB)**2+ 
     1AQQ)-8.D00/SQRT(R**2+TD*(QA**2+QB**2)+AQQ) 
      QXZQXZ=TD/SQRT((R+QA-QB)**2+(QA-QB)**2+AQQ)-TD/SQRT((R+QA+QB)**2+( 
     1QA-QB)**2+AQQ)-TD/SQRT((R-QA-QB)**2+(QA-QB)**2+AQQ)+TD/SQRT((R-QA+ 
     2QB)**2+(QA-QB)**2+AQQ)-TD/SQRT((R+QA-QB)**2+(QA+QB)**2+AQQ)+TD/SQR 
     3T((R+QA+QB)**2+(QA+QB)**2+AQQ)+TD/SQRT((R-QA-QB)**2+(QA+QB)**2+AQQ 
     4)-TD/SQRT((R-QA+QB)**2+(QA+QB)**2+AQQ) 
      DXDX=DXDX/P2 
      DZDZ=DZDZ/P2 
      DZQXX=DZQXX/P3 
      QXXDZ=QXXDZ/P3 
      DZQZZ=DZQZZ/P3 
      QZZDZ=QZZDZ/P3 
      DXQXZ=DXQXZ/P3 
      QXZDX=QXZDX/P3 
      QXXQXX=QXXQXX/P4 
      QXXQYY=QXXQYY/P4 
      QXXQZZ=QXXQZZ/P4 
      QZZQXX=QZZQXX/P4 
      QZZQZZ=QZZQZZ/P4 
      QXZQXZ=QXZQXZ/P4 
      QXYQXY=QXYQXY/P4 
      RI(6)=DZDZ 
      RI(7)=DXDX 
      RI(8)=-EDZ-QZZDZ 
      RI(9)=-EDZ-QXXDZ 
      RI(10)=-QXZDX 
      RI(13)=-DZE-DZQZZ 
      RI(14)=-DZE-DZQXX 
      RI(15)=-DXQXZ 
      RI(16)=EE+EQZZ+QZZE+QZZQZZ 
      RI(17)=EE+EQZZ+QXXE+QXXQZZ 
      RI(18)=EE+EQXX+QZZE+QZZQXX 
      RI(19)=EE+EQXX+QXXE+QXXQXX 
      RI(20)=QXZQXZ 
      RI(21)=EE+EQXX+QXXE+QXXQYY 
      RI(22)=0.5D0*(QXXQXX-QXXQYY) 
      ADD(1,1)=ADD(1,2) 
   40 CONTINUE 
C 
C     CONVERT INTO EV. 
C 
      DO 50 I=2,22 
   50 RI(I)=RI(I)*27.21D00 
C 
C     CALCULATE CORE-ELECTRON ATTRACTIONS. 
C 
      CORE(2,1)=-TORE(NJ)*RI(2) 
      CORE(3,1)=-TORE(NJ)*RI(3) 
      CORE(4,1)=-TORE(NJ)*RI(4) 
      CORE(2,2)=-TORE(NI)*RI(5) 
      CORE(3,2)=-TORE(NI)*RI(11) 
      CORE(4,2)=-TORE(NI)*RI(12) 
      RETURN 
      END 
      SUBROUTINE ROTATE (NI,NJ,XI,XJ,W,KR,E1B,E2A,ENUC,CUTOFF) 
      IMPLICIT REAL (A-H,O-Z) 
      COMMON /EULER / TVEC(3,3),ID 
      COMMON /NATORB/ NATORB(107) 
      COMMON /TWOEL3/ F03(107) 
      COMMON /ALPHA3/ ALP3(153) 
      COMMON /ALPHA / ALP(107) 
      COMMON /CORE  / TORE(107) 
      COMMON /IDEAS / FN1(107,10),FN2(107,10),FN3(107,10),NFN(107) 
      COMMON /ALPTM / ALPTM(30), EMUDTM(30) 
      COMMON /KEYWRD/ KEYWRD 
C----------------------------------------------------------------------- 
C     THIS ROUTINE COMPUTES THE REPULSION AND NUCLEAR ATTRACTION 
C     INTEGRALS OVER MOLECULAR-FRAME COORDINATES. 
C 
C  INPUT  NI     = ATOMIC NUMBER OF FIRST ATOM. 
C         NJ     = ATOMIC NUMBER OF SECOND ATOM. 
C         XI     = COORDINATE OF FIRST ATOM. 
C         XJ     = COORDINATE OF SECOND ATOM. 
C 
C  OUTPUT W      = ARRAY OF TWO-ELECTRON REPULSION INTEGRALS. 
C         E1B,E2A= ARRAY OF ELECTRON-NUCLEAR ATTRACTION INTEGRALS, 
C                  E1B = ELECTRON ON ATOM NI ATTRACTING NUCLEUS OF NJ. 
C         ENUC   = NUCLEAR-NUCLEAR REPULSION TERM. 
C  (REVISED, D.L., DEWAR GROUP, 1986) 
C----------------------------------------------------------------------- 
      CHARACTER*80 KEYWRD 
      DIMENSION X(3),Y(3),Z(3),RI(22),CORE(4,2) 
     .         ,BUF(99),ROT(6,7),L1SCAT(9),L2SCAT(99) 
      DIMENSION XI(3),XJ(3),W(100),E1B(10),E2A(10) 
      LOGICAL AM1 
      DATA ITYPE /1/ 
      DATA L1SCAT / 2, 4, 7, 3, 5, 6, 8, 9,10 / 
      DATA L2SCAT /11,31,61,21,41,51,71,81,91, 2, 4, 7, 3, 5, 6, 8, 9,10 
     A            ,12,32,34,62,64,67,14,17,37 
     B            ,22,42,52,72,82,92,13,15,16,18,19,20 
     C            ,24,44,54,74,84,94,33,35,36,38,39,40 
     D            ,27,47,57,77,87,97,63,65,66,68,69,70 
     E            ,23,25,26,28,29,30 
     F            ,43,45,46,48,49,50 
     G            ,53,55,56,58,59,60 
     H            ,73,75,76,78,79,80 
     I            ,83,85,86,88,89,90 
     J            ,93,95,96,98,99,100 / 
C 
C     INTERATOMIC DISTANCE. 
C     --------------------- 
      SAVE
      RIJ=0.D0 
      DO 10 I=1,3 
      X(I)=XI(I)-XJ(I) 
   10 RIJ=RIJ+X(I)**2 
C     CHECK POLYMER AND UNIT CELL 
      IF(ID.NE.0.AND.RIJ.LT.0.2D0) THEN 
         DO 15 I=1,10 
         E1B(I)=0.D0 
   15    E2A(I)=0.D0 
         W(KR)=0.D0 
         ENUC=0.D0 
         RETURN 
      ENDIF 
C 
C     FIND OPTION : MINDO OR MNDO/AM1. 
C     -------------------------------- 
   20 GOTO (30,40,70) ITYPE 
   30 IF(INDEX(KEYWRD,'MINDO') .NE. 0) THEN 
         ITYPE=2 
      ELSE 
         AM1= (INDEX(KEYWRD,'AM1') .NE. 0) 
         ITYPE=3 
      ENDIF 
      GO TO 20 
C 
C     WE ARE IN MINDO. 
C     ---------------- 
   40 SUM=14.399D0/SQRT(RIJ+(7.1995D0/F03(NI)+7.1995D0/F03(NJ))**2) 
C     THE 2-CENTRE 2-ELECTRON INTEGRAL IS DIVIDED BY FOUR. 
      W(1)=SUM*0.25D0 
      KR=KR+1 
      L=0 
      DO 60 I=1,4 
      DO 50 J=1,I 
      L=L+1 
      E1B(L)=0.D0 
   50 E2A(L)=0.D0 
      E1B(L)=-SUM*TORE(NJ) 
   60 E2A(L)=-SUM*TORE(NI) 
      II=MAX(NI,NJ) 
      NBOND=(II*(II-1))/2+NI+NJ-II 
      RIJ=SQRT(RIJ) 
      SCALE=0 
      IF(NATORB(NI).EQ.0) SCALE=EXP(-ALP(NI)*RIJ) 
      IF(NATORB(NJ).EQ.0) SCALE=SCALE+EXP(-ALP(NI)*RIJ) 
      IF(NBOND.LT.154) THEN 
         IF(NBOND.EQ.22 .OR. NBOND .EQ. 29) THEN 
            SCALE=ALP3(NBOND)*EXP(-RIJ) 
         ELSE 
            SCALE=EXP(-ALP3(NBOND)*RIJ) 
         ENDIF 
      ENDIF 
      IF(ABS(TORE(NI)).GT.20.AND.ABS(TORE(NJ)).GT.20) THEN 
         ENUC=0.D0 
      ELSE IF (RIJ.LT.1.D0.AND.NATORB(NI)*NATORB(NJ).EQ.0) THEN 
         ENUC=0.D0 
      ELSE 
         ENUC=TORE(NI)*TORE(NJ)*SUM 
     1       +ABS(TORE(NI)*TORE(NJ)*(14.399D0/RIJ-SUM)*SCALE) 
      ENDIF 
      RETURN 
C 
C     WE ARE IN MNDO/AM1. 
C     ------------------- 
C     THE INTEGRALS OVER LOCAL FRAME COORDINATES ARE EVALUATED BY 
C     SUBROUTINE REPP AND RETURNED IN RI AS FOLLOWS 
C     (WHERE P-SIGMA = O,   AND P-PI = P AND P* ) 
C     (SS/SS)=1,   (SO/SS)=2,   (OO/SS)=3,   (PP/SS)=4,   (SS/OS)=5, 
C     (SO/SO)=6,   (SP/SP)=7,   (OO/SO)=8,   (PP/SO)=9,   (PO/SP)=10, 
C     (SS/OO)=11,  (SS/PP)=12,  (SO/OO)=13,  (SO/PP)=14,  (SP/OP)=15, 
C     (OO/OO)=16,  (PP/OO)=17,  (OO/PP)=18,  (PP/PP)=19,  (PO/PO)=20, 
C     (PP/P*P*)=21,   (P*P/P*P)=22. 
C 
C     THE STORAGE OF THE NUCLEAR ATTRACTION INTEGRALS  CORE(KL/IJ) IS 
C     -(SS/)=1,   -(SO/)=2,   -(OO/)=3,   -(PP/)=4 
C 
   70 RIJ=MIN(SQRT(RIJ),CUTOFF) 
      CALL REPP(NI,NJ,RIJ,RI,CORE) 
      GAM=RI(1) 
      E1B(1)=CORE(1,1) 
      E2A(1)=CORE(1,2) 
      IB=MIN(NATORB(NI),4)-1 
      JB=MIN(NATORB(NJ),4)-1 
C     DISCARD SPARKLE 
      IF (IB.LT.0.OR.JB.LT.0) GO TO 200 
C 
C * * LIGHT-LIGHT. 
C 
C     (SS/SS) 
      KI=1 
      W(1)=GAM*0.25D0 
      IF(IB.EQ.0.AND.JB.EQ.0) GO TO 200 
C 
C * * LIGHT-HEAVY AND/OR HEAVY-LIGHT. 
C 
C     PREPARE HALVING OF SOME (IJ/KL) 
      DO 80 I=2,5 
   80 RI( I)=RI( I)*0.5D0 
      RI(11)=RI(11)*0.5D0 
      RI(12)=RI(12)*0.5D0 
C     BUILD 1-P ROTATION VECTORS X,Y,Z. 
      A=1.D0/RIJ 
      DO 90 I=1,3 
   90 X(I)=X(I)*A 
      IF(ABS(X(3)).GT.0.999999999999D0) THEN 
         X(3)=SIGN(1.D0,X(3)) 
         Y(1)=0.D0 
         Y(2)=1.D0 
         Y(3)=0.D0 
         Z(1)=1.D0 
         Z(2)=0.D0 
         Z(3)=0.D0 
      ELSE 
         Z(3)=SQRT(1.D0-X(3)**2) 
         A=1.D0/Z(3) 
         Y(1)=-A*X(2)*SIGN(1.D0,X(1)) 
         Y(2)=ABS(A*X(1)) 
         Y(3)=0.D0 
         Z(1)=-A*X(1)*X(3) 
         Z(2)=-A*X(2)*X(3) 
      ENDIF 
C     BUILD FIRST 2-P ROTATION VECTORS. 
      IJ=0 
      DO 100 I=1,3 
      DO 100 J=1,I 
      IJ=IJ+1 
      ROT(IJ,1)=X(I)*X(J) 
  100 ROT(IJ,2)=Y(I)*Y(J)+Z(I)*Z(J) 
      KBUF=1 
      IF (IB.GT.0) THEN 
C        (PS/SS) AND CORE(PS) 
         DO 110 I=1,3 
         W(I+1)=CORE(2,1)*X(I) 
  110    BUF(I)=RI(2)*X(I) 
         CALL MXM (ROT,6,CORE(3,1),2,W(5),1) 
C        (PP/SS) 
         CALL MXM (ROT,6,RI(3),2,BUF(4),1) 
         BUF(4)=BUF(4)*0.5D0 
         BUF(6)=BUF(6)*0.5D0 
         BUF(9)=BUF(9)*0.5D0 
         KBUF=10 
         CALL SCATTER (9,E1B,L1SCAT,W(2)) 
      ENDIF 
      IF (JB.GT.0) THEN 
C        (SS/PS) AND CORE(SP) 
         DO 120 I=2,4 
         W(I)=CORE(2,2)*X(I-1) 
         BUF(KBUF)=RI(5)*X(I-1) 
  120    KBUF=KBUF+1 
         CALL MXM (ROT,6,CORE(3,2),2,W(5),1) 
C        (SS/PP) 
         CALL MXM (ROT,6,RI(11),2,BUF(KBUF),1) 
         BUF(KBUF  )=BUF(KBUF  )*0.5D0 
         BUF(KBUF+2)=BUF(KBUF+2)*0.5D0 
         BUF(KBUF+5)=BUF(KBUF+5)*0.5D0 
         CALL SCATTER (9,E2A,L1SCAT,W(2)) 
      ENDIF 
      IF (IB.EQ.0.OR.JB.EQ.0) THEN 
C 
C * * *  HEAVY-LIGHT OR LIGHT-HEAVY ONLY. 
C 
C        SCATTER BUF IN CANONICAL ORDER 
         CALL SCATTER (9,W,L1SCAT,BUF) 
         KI=10 
      ELSE 
C 
C * * *  HEAVY-HEAVY ONLY. 
C 
C        (PS/PS) 
         CALL MXM (ROT,6,RI(6),2,BUF(19),1) 
         BUF(25)=BUF(20) 
         BUF(26)=BUF(22) 
         BUF(27)=BUF(23) 
C        COMPLETE 2-P ROTATION VECTORS 
         IJ=0 
         DO 130 I=1,3 
         DO 130 J=1,I 
         IJ=IJ+1 
         ROT(IJ,3)=X(I)*Y(J)+X(J)*Y(I) 
         ROT(IJ,4)=X(I)*Z(J)+X(J)*Z(I) 
         ROT(IJ,5)=Y(I)*Z(J)+Y(J)*Z(I) 
         ROT(IJ,6)=Y(I)*Y(J) 
  130    ROT(IJ,7)=Z(I)*Z(J) 
         DO 140 I=1,7 
         ROT(1,I)=ROT(1,I)*0.5D0 
         ROT(3,I)=ROT(3,I)*0.5D0 
  140    ROT(6,I)=ROT(6,I)*0.5D0 
C        (PP/PS) AND (PS/PP) 
         IJ=2 
CDIR$ IVDEP 
         DO 150 I=1,3 
         W(IJ  )=RI( 8)*X(I) 
         W(IJ+1)=RI( 9)*X(I) 
         W(IJ+2)=RI(10)*Y(I) 
         W(IJ+3)=RI(10)*Z(I) 
         W(IJ+4)=RI(13)*X(I) 
         W(IJ+5)=RI(14)*X(I) 
         W(IJ+6)=RI(15)*Y(I) 
         W(IJ+7)=RI(15)*Z(I) 
  150    IJ=IJ+8 
         CALL MXM (ROT,6,W(2),4,BUF(28),6) 
C        (PP/PP) 
         IJ=2 
CDIR$ IVDEP 
         DO 160 I=1,6 
         W(IJ  )=RI(16)*ROT(I,1)+RI(17)*ROT(I,2) 
         W(IJ+1)=RI(18)*ROT(I,1) 
         W(IJ+2)=RI(20)*ROT(I,3) 
         W(IJ+3)=RI(20)*ROT(I,4) 
         W(IJ+4)=RI(22)*ROT(I,5) 
         W(IJ+5)=RI(19)*ROT(I,6)+RI(21)*ROT(I,7) 
         W(IJ+6)=RI(19)*ROT(I,7)+RI(21)*ROT(I,6) 
  160    IJ=IJ+7 
         CALL MXM (ROT,6,W(2),7,BUF(64),6) 
C        SCATTER BUF IN CANONICAL ORDER 
         CALL SCATTER (99,W,L2SCAT,BUF) 
         KI=100 
      ENDIF 
C 
C     THE REPULSION INTEGRALS OVER MOLECULAR FRAME (W) HAVE BEEN STORED 
C     IN CANONICAL ORDER I.E. (I,J/K,L) WHERE J.LE.I  AND  L.LE.K 
C     AND L VARIES MOST RAPIDLY AND I LEAST RAPIDLY. 
C     (ANTI-NORMAL COMPUTER STORAGE). 
C     THEY ARE HALVED IF (I=J OR K=L) AND (I NE K), 
C     THEY ARE DIVIDED BY FOUR IF (I=J) AND (K=L). 
C 
C 
C * * UPDATE THE CORE-CORE REPULSION ENERGY 
C 
  200 IF(ABS(TORE(NI)).GT.20.AND.ABS(TORE(NJ)).GT.20) THEN 
C        SPARKLE-SPARKLE INTERACTION 
         ENUC=0.D0 
         RETURN 
      ELSE IF (RIJ.LT.1.D0.AND.NATORB(NI)*NATORB(NJ).EQ.0) THEN 
         ENUC=0.D0 
         RETURN 
      ENDIF 
      SCALE = EXP(-ALP(NI)*RIJ)+EXP(-ALP(NJ)*RIJ) 
      IF (NI.EQ.24.AND.NJ.EQ.24) THEN 
         SCALE = EXP(-ALPTM(NI)*RIJ)+EXP(-ALPTM(NJ)*RIJ) 
      ENDIF 
      NT=NI+NJ 
      IF(NT.EQ.8.OR.NT.EQ.9) THEN 
       IF(NI.EQ.7.OR.NI.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NI)*RIJ) 
       IF(NJ.EQ.7.OR.NJ.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NJ)*RIJ) 
      ENDIF 
      ENUC = TORE(NI)*TORE(NJ)*GAM
      SCALE=ABS(SCALE * ENUC)
C
C   Code for B-X bonds
C
      IF(NI .NE. 5 .AND. NJ .NE. 5)GOTO 290
      NT=NI+NJ
C   B-H
      IF (NT.EQ.6 .AND. AM1) THEN
C
          DO 281 IG=1,9
          IF(NI.EQ.5) THEN
          IF(IG.GE.4 .AND. IG.LE.5)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(ABS(FN1(NJ,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ELSE
          IF(ABS(FN1(NI,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(IG.GE.4 .AND. IG.LE.5)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ENDIF
  281     CONTINUE 
C
          GOTO 282
          ENDIF
C
      IF (NT.EQ.11 .AND. AM1) THEN
C
C   B-C
          DO 299 IG=1,9
          IF(NI.EQ.5) THEN
          IF(IG.GE.6 .AND. IG.LE.7)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(ABS(FN1(NJ,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ELSE
          IF(ABS(FN1(NI,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(IG.GE.6 .AND. IG.LE.7)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ENDIF
  299     CONTINUE 
C
          GOTO 282
          ENDIF
C  B-Halogen
C
      IF ((NT.EQ.14 .AND. AM1) .OR. (NT.EQ.22 .AND. AM1) .OR.
     +(NT.EQ.40 .AND. AM1) .OR. (NT.EQ.58 .AND. AM1)) THEN
          DO 291 IG=1,9
          IF(NI.EQ.5) THEN
          IF(IG.GE.8 .AND. IG.LE.9)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(ABS(FN1(NJ,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ELSE
          IF(ABS(FN1(NI,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(IG.GE.8 .AND. IG.LE.9)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ENDIF
  291     CONTINUE 
C
          GOTO 282
          ENDIF
C  B-X
C
      IF (AM1) THEN
          DO 292 IG=1,9
          IF(NI.EQ.5) THEN
          IF(IG.GE.1 .AND. IG.LE.3)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(ABS(FN1(NJ,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ELSE
          IF(ABS(FN1(NI,IG)).GT.0.D0)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
          IF(IG.GE.1 .AND. IG.LE.3)
     +SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ* 
     +FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
             ENDIF
  292     CONTINUE 
C
          GOTO 282
      ENDIF
  290     CONTINUE 
C
      IF( AM1 )THEN 
         SCALE1=0.D0 
         DO 210 IG=1,NFN(NI) 
  210    SCALE1=SCALE1 + 
     1   FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2) 
         DO 211 IG=1,NFN(NJ) 
  211    SCALE1=SCALE1 + 
     1   FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2) 
         SCALE=SCALE+SCALE1*TORE(NI)*TORE(NJ)/RIJ 
      ENDIF 
  282 CONTINUE
      ENUC=ENUC+SCALE 
C 
C     UPDATE COUNTER OF W FILE. 
C 
      KR=KR+KI 
      RETURN 
      END 
      SUBROUTINE SAVOPT (LEN1,LEN2,FLAG) 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C     THIS ROUTINE ALLOWS SAVING/RESTARTING OF OPTIMIZATION ROUTINES: 
C     CHAIN,LTRD,PATH,POWELL 
C     THE DATA TO BE WRITEN/READ ON FILE 9 MUST BE IN /OPTIM/, 
C     ACCORDING TO THE FOLLOWING EQUIVALENCED RULE : 
C     COMMON /OPTIM / ISAVE1(MAXPAR,LEN1),ISAVE2(LEN2) 
C     THE DENSITY MATRICES ARE ALSO SAVED ON UNIT 10 AS THEY WILL BE 
C     READ IN ROUTINE 'ITER' WHEN RESTARTING. 
C     ON INPUT FLAG = .T. FOR A RESTART (READ  ON FILE  9) 
C                     .F. FOR A SAVE    (WRITE ON FILES 9 & 10 ) 
      COMMON /OPTIM / ISAVE(MAXPAR,1) 
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) 
      COMMON /TIME  / TIME0 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     .                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     .                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ELEMTS/ ELEMNT(107) 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR), 
     1                     LOCDEP(MAXPAR) 
      COMMON /TITLES/ KOMENT,TITLE 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), JDUMY, DUMY(MAXPAR) 
      DIMENSION IEL1(3),QQ(3) 
      CHARACTER ELEMNT*2, KEYWRD*80,KOMENT*80, TITLE*80 
      LOGICAL FLAG 
      SAVE
      OPEN(UNIT=9,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 9 
      OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED') 
      REWIND 10 
C 
C     RESTART SECTION 
      IF ( FLAG ) THEN 
         IF(LEN1.GT.0) THEN 
            DO 10 J=1,LEN1 
            READ(9,END=200)(ISAVE(I,J),I=1,MAXPAR) 
   10       CONTINUE 
         ENDIF 
         IF(LEN2.GT.0) THEN 
            ICOL=LEN1+1 
            READ(9,END=250)(ISAVE(I,ICOL),I=1,LEN2) 
         ENDIF 
         RETURN 
      ENDIF 
C 
C     SAVE SECTION 
      IPRT=ISAVE(4,1) 
      CALL SECOND (TFLY) 
      WRITE(IPRT,100) TFLY-TIME0 
      LINEAR=(NORBS*(NORBS+1))/2 
      WRITE(10)(PA(I),I=1,LINEAR) 
      IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR) 
      IF(LEN1.GT.0) THEN 
         DO 20 J=1,LEN1 
  20     WRITE(9)(ISAVE(I,J),I=1,MAXPAR) 
      ENDIF 
      IF(LEN2.GT.0) THEN 
         ICOL=LEN1+1 
         WRITE(9)(ISAVE(I,ICOL),I=1,LEN2) 
      ENDIF 
C 
C     PRINTOUT MINIMUM INFORMATION BEFORE TO DIE... 
      WRITE(IPRT,'(/10X,'' CURRENT VALUES OF GEOMETRIC VARIABLES'',/)') 
      DEGREE=57.29577951D0 
      GEO(2,1)=0.D0 
      GEO(3,1)=0.D0 
      GEO(1,1)=0.D0 
      GEO(2,2)=0.D0 
      GEO(3,2)=0.D0 
      GEO(3,3)=0.D0 
      IVAR=1 
      NA(1)=0 
      WRITE(IPRT,'(1X,A)')KEYWRD,KOMENT,TITLE 
      DO 60 I=1,NATOMS 
      DO 40 J=1,3 
   40 IEL1(J)=0 
   50 CONTINUE 
      IF(LOC(1,IVAR).EQ.I) THEN 
         IEL1(LOC(2,IVAR))=1 
         IVAR=IVAR+1 
         GOTO 50 
      ENDIF 
      IF(I.LT.4) THEN 
         IEL1(3)=0 
         IF(I.LT.3) THEN 
            IEL1(2)=0 
            IF(I.LT.2) IEL1(1)=0 
         ENDIF 
      ENDIF 
      IF(I.EQ.LATOM)IEL1(LPARAM)=-1 
      QQ(1)=GEO(1,I) 
      QQ(2)=GEO(2,I)*DEGREE 
      QQ(3)=GEO(3,I)*DEGREE 
   60 WRITE(IPRT,110) ELEMNT(LABELS(I)),(QQ(K),IEL1(K),K=1,3) 
     .               ,NA(I),NB(I),NC(I) 
      I=0 
      X=0.D0 
      WRITE(IPRT,120) I,X,I,X,I,X,I,I,I,I 
      IF(NDEP.NE.0)THEN 
         DO 70 I=1,NDEP 
   70    WRITE(IPRT,130) LOCPAR(I),IDEPFN(I),LOCDEP(I) 
         WRITE(IPRT,*) 
      ENDIF 
C     NOW THE RUN IS DEAD. 
      STOP 
C 
C     ERROR SECTION 
  200 WRITE(ISAVE(4,1),201) J 
      STOP 
  250 WRITE(ISAVE(4,1),251) 
C 
  100 FORMAT(//' * * * *** TIME IS UP]]] *** * * * ALL DATA SAVED ON UNI 
     .T 9 AND 10'/ 
     .' * * * ELAPSED TIME IN THIS RUN :',F10.2,' SECONDS'/ 
     .' * * * TO RESTART, ADD *ONLY* THE KEYWORD ''RESTART''.'//) 
  110 FORMAT(2X,A2,3(F12.6,I3),I4,2I3) 
  120 FORMAT(I4,   3(F12.6,I3),I4,2I3) 
  130 FORMAT(3(I4,',')) 
  201 FORMAT(' UNEXPECTED END-OF-FILE 9 IN ''SAVOPT'' WITH ROW #',I5) 
  251 FORMAT(' UNEXPECTED END-OF-FILE 9 IN ''SAVOPT'' WITH LEN2',I10) 
      END 
      SUBROUTINE SEARCH(XPARAM,ALPHA,NVAR,GMIN,OK) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION XPARAM(*) 
************************************************************************ 
* 
* SEARCH PERFORMS A LINE SEARCH FOR POWSQ. IT MINIMISES THE NORM OF 
*        THE GRADIENT VECTOR IN THE DIRECTION SIG. 
* 
* ON INPUT  XPARAM = CURRENT POINT IN NVAR DIMENSIONAL SPACE. 
*           ALPHA  = INITIAL STEP SIZE ALONG SIG. 
*           SIG    = SEARCH DIRECTION VECTOR IN /OPTIM/. 
*           NVAR   = NUMBER OF PARAMETERS IN SIG (& XPARAM) 
*           GMIN   = NOT DEFINED. 
*           GMIN1  = GRADIENT VECTOR AT CURRENT POINT. 
* 
* ON OUTPUT XPARAM = NEW CURRENT POINT (MINIMUM IN DIRECTION SIG). 
*           ALPHA  = OPTIMUM STEP SIZE FOUND 
*           GMIN   = GRADIENT NORM AT MINIMUM. 
*           GMIN1  = GRADIENT VECTOR AT MINIMUM. 
*           OK     =.TRUE. IF IMPROVEMENT IN GRADIENT NORM. 
*           GNEXT1 = INTERMEDIATE GRADIENT ALONG SEARCH. WILL BE USED 
*                    TO UPDATE THE HESSIAN MATRIX IN 'POWSQ'. 
************************************************************************ 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,HESS(MAXPAR,MAXPAR),PMAT(MAXHES) 
     1               ,BMAT(MAXPAR,MAXPAR),GMIN1(MAXPAR),GMIDUM 
     2               ,IDUM,LOOP,SIG(MAXPAR),XBEST(MAXPAR),GNEXT,AMIN 
     3               ,ANEXT,PVEC(MAXPAR*MAXPAR),EIG(MAXPAR),P(MAXPAR) 
     4               ,Q(MAXPAR),WORK(MAXPAR),GNEXT1(MAXPAR) 
     5               ,GRAD(MAXPAR),XREF(MAXPAR),GREF(MAXPAR) 
     6               ,XMIN1(MAXPAR) 
      CHARACTER*80 KEYWRD 
      LOGICAL FIRST, DEBUG, FAIL, OK 
      DATA  FIRST /.TRUE./ 
      SAVE
      IF( FIRST ) THEN 
         FIRST = .FALSE. 
C 
C    TOLG   = CRITERION FOR EXIT BY RELATIVE CHANGE IN GRADIENT. 
C 
         DEBUG=(INDEX(KEYWRD,'SEARCH') .NE. 0) 
         LOOKS=0 
         TINY=0.1D0 
         TOLERG=0.02D0 
         G=100.D0 
         ALPHA=0.1D0 
      ENDIF 
      OK=.FALSE. 
      DO 10 I=1,NVAR 
         GREF(I)  =GMIN1(I) 
         GNEXT1(I)=GMIN1(I) 
         XMIN1(I) =XPARAM(I) 
   10 XREF(I)  =XPARAM(I) 
      IF(ABS(ALPHA) .GT. 0.2)ALPHA=SIGN(0.2D0,ALPHA) 
      IF(DEBUG) THEN 
         WRITE(IPRT,'('' SEARCH DIRECTION VECTOR'')') 
         WRITE(IPRT,'(6F12.6)')(SIG(I),I=1,NVAR) 
         WRITE(IPRT,'('' INITIAL GRADIENT VECTOR'')') 
         WRITE(IPRT,'(6F12.6)')(GMIN1(I),I=1,NVAR) 
      ENDIF 
      GB=DOT(GMIN1,GREF,NVAR) 
      IF(DEBUG) WRITE(IPRT,'('' GRADIENT AT START OF SEARCH:'',F16.6)') 
     1SQRT(GB) 
      GSTORE=GB 
      AMIN=0.D0 
      GMINN=1.D9 
C 
C 
      TA=0.D0 
      GA=GB 
      GB=1.D9 
      ITRYS=0 
      GOTO 30 
   20 SUM=GA/(GA-GB) 
      ITRYS=ITRYS+1 
      IF(ABS(SUM) .GT. 3.D0) SUM=SIGN(3.D0,SUM) 
      ALPHA=(TB-TA)*SUM+TA 
C 
C         XPARAM IS THE GEOMETRY OF THE PREDICTED MINIMUM ALONG THE LINE 
C 
   30 DO 40 I=1,NVAR 
   40 XPARAM(I)=XREF(I)+ALPHA*SIG(I) 
C 
C         CALCULATE GRADIENT NORM AND GRADIENTS AT THE PREDICTED MINIMUM 
C 
      CALL COMPFG (XPARAM,FUNCT,FAIL, GRAD, .TRUE.) 
      IF(FAIL) STOP 
      LOOKS=LOOKS+1 
C 
C          G IS THE PROJECTION OF THE GRADIENT ALONG SIG. 
C 
      G=DOT(GREF,GRAD,NVAR) 
      GTOT=SQRT(DOT(GRAD,GRAD,NVAR)) 
      IF(DEBUG.OR.IMP.GT.1) 
     1WRITE(IPRT,'('' LOOKS'',I3,'' ALPHA ='',F12.6,'' GRADIENT'',F12.3, 
     2'' G  ='',F16.6)') LOOKS,ALPHA,GTOT,G 
      IF(GTOT .LT. GMINN) THEN 
         GMINN=GTOT 
         IF(ABS(AMIN-ALPHA) .GT.1.D-2) THEN 
* 
* WE CAN MOVE ANEXT TO A POINT NEAR, BUT NOT TOO NEAR, AMIN, SO THAT THE 
* SECOND DERIVATIVESWILLBEREALISTIC(D2E/DX2=(GNEXT1-GMIN1)/(ANEXT-AMIN)) 
* 
            ANEXT=AMIN 
            CALL SCOPY (NVAR,GMIN1,1,GNEXT1,1) 
         ENDIF 
         AMIN=ALPHA 
         CALL SCOPY (NVAR,GRAD,1,GMIN1,1) 
         IF (GMINN.LT.GMIN) THEN 
            CALL SCOPY (NVAR,XPARAM,1,XMIN1,1) 
            GMIN=GMINN 
         ENDIF 
      ENDIF 
      IF(ITRYS .GT. 8) GOTO 50 
      IF (ABS(G/GSTORE).LT.TINY .OR. ABS(G) .LT. TOLERG) GO TO 50 
      IF(ABS(G) .LT. MAX(ABS(GA),ABS(GB)) .OR. 
     1     GA*GB .GT. 0.D0 .AND. G*GA .LT. 0.D0) THEN 
C   G IS AN IMPROVEMENT ON GA OR GB. 
         OK=.TRUE. 
         IF(ABS(GB) .LT. ABS(GA))THEN 
            TA=ALPHA 
            GA=G 
            GO TO 20 
         ELSE 
            TB=ALPHA 
            GB=G 
            GO TO 20 
         ENDIF 
      ELSE 
         IF(IMP.GT.0.AND..NOT.OK) 
     .   WRITE(IPRT,'(//10X,'' FAILED IN SEARCH, SEARCH CONTINUING'')') 
      ENDIF 
   50 GMINN=SQRT(DOT(GMIN1,GMIN1,NVAR)) 
      GMIN=GMINN 
      CALL SCOPY (NVAR,XMIN1,1,XPARAM,1) 
      IF(DEBUG.OR.IMP.GT.3) THEN 
         WRITE(IPRT,'('' AT EXIT FROM SEARCH'')') 
         WRITE(IPRT,'('' XPARAM'',6F12.6)')(XPARAM(I),I=1,NVAR) 
         WRITE(IPRT,'('' GNEXT1'',6F12.6)')(GNEXT1(I),I=1,NVAR) 
         WRITE(IPRT,'('' GMIN1 '',6F12.6)')(GMIN1 (I),I=1,NVAR) 
         WRITE(IPRT,'('' AMIN, ANEXT,GMIN'',4F12.6)')AMIN,ANEXT,GMIN 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE SOLROT (NI,NJ,XI,XJ,WJ,WK,KR,E1B,E2A,ENUC,CUTOFF) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XI(3), XJ(3), WJ(100), WK(100), E1B(10), E2A(10) 
************************************************************************ 
* 
*   SOLROT FORMS THE TWO-ELECTRON TWO-ATOM J AND K INTEGRAL STRINGS. 
*          ON EXIT WJ = "J"-TYPE INTEGRALS 
*                  WK = "K"-TYPE INTEGRALS 
* 
*      FOR MOLECULES, WJ = WK. 
************************************************************************ 
      COMMON /EULER / TVEC(3,3), ID 
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U,KDUM(6) 
      DIMENSION WSUM(100), WBITS(100), LIMS(3,2), XJUC(3), E1BITS(10), 
     1E2BITS(10), WMAX(100) 
      LOGICAL FIRST 
      EQUIVALENCE (L1L,LIMS(1,1)) 
      DATA FIRST/.TRUE./ 
      SAVE
      IF(FIRST)THEN 
         FIRST=.FALSE. 
         DO 10 I=1,ID 
            LIMS(I,1)=-1 
   10    LIMS(I,2)= 1 
         DO 20 I=ID+1,3 
            LIMS(I,1)=0 
   20    LIMS(I,2)=0 
      ENDIF 
      ONE=1.D0 
      IF(XI(1).EQ.XJ(1) .AND. XI(2).EQ.XJ(2) .AND. XI(3).EQ. XJ(3)) 
     1ONE=0.5D0 
      DO 30 I=1,100 
         WMAX(I)=0.D0 
         WSUM(I)=0.D0 
   30 WBITS(I)=0.D0 
      NEQUAL=1 
      DO 40 I=1,10 
         E1B(I)=0.D0 
   40 E2A(I)=0.D0 
      ENUC=0.D0 
      DO 90 I=L1L,L1U 
         DO 90 J=L2L,L2U 
            DO 90 K=L3L,L3U 
               DO 50 L=1,3 
   50          XJUC(L)=XJ(L)+TVEC(L,1)*I+TVEC(L,2)*J+TVEC(L,3)*K 
               KB=1 
               CALL ROTATE (NI,NJ,XI,XJUC,WBITS,KB,E1BITS,E2BITS, 
     1ENUBIT,CUTOFF) 
C#      WRITE(6,'(3I4,3F14.7)')I,J,K,(XJUC(L)-XI(L),L=1,3) 
C#      CALL VECPRT(E1BITS,4) 
               KB=KB-1 
               DO 60 II=1,KB 
   60          WSUM(II)=WSUM(II)+WBITS(II) 
               IF(WMAX(1).LT.WBITS(1))THEN 
                  DO 70 II=1,KB 
   70             WMAX(II)=WBITS(II) 
               ENDIF 
               DO 80 II=1,10 
                  E1B(II)=E1B(II)+E1BITS(II) 
   80          E2A(II)=E2A(II)+E2BITS(II) 
               ENUC=ENUC+ENUBIT*ONE 
   90 CONTINUE 
      IF(ONE.LT.0.9D0) THEN 
         DO 100 I=1,KB 
  100    WMAX(I)=0.D0 
      ENDIF 
      DO 110 I=1,KB 
         WK(I)=WMAX(I) 
  110 WJ(I)=WSUM(I) 
      KR=KB+KR 
      RETURN 
      END 
      SUBROUTINE SWAP(C,N,MDIM,NOCC,IFILL) 
      IMPLICIT  REAL (A-H,O-Z) 
      DIMENSION C(MDIM,MDIM),PSI(200),STDPSI(200) 
      SAVE
C****************************************************************** 
C 
C        SWAP ENSURES THAT A NAMED MOLECULAR ORBITAL IFILL IS FILLED 
C ON INPUT 
C          C = EIGENVECTORS IN A MDIM*MDIM MATRIX 
C          N = NUMBER OF ORBITALS 
C          NOCC = NUMBER OF OCCUPIED ORBITALS 
C          IFILL = FILLED ORBITAL 
C****************************************************************** 
      IF(IFILL.GT.0) GOTO 20 
C 
C     WE NOW DEFINE THE FILLED ORBITAL 
C 
      IFILL=-IFILL 
      DO 10 I=1,N 
         STDPSI(I)=C(I,IFILL) 
   10 PSI(I)=C(I,IFILL) 
      RETURN 
   20 CONTINUE 
C 
C     FIRST FIND THE LOCATION OF IFILL 
C 
      SUM=0.D0 
      DO 30 I=1,N 
   30 SUM=SUM+PSI(I)*C(I,IFILL) 
      IF(ABS(SUM).GT.0.7071D0) GOTO 90 
C 
C     IFILL HAS MOVED] 
C 
      SUMMAX=0.D0 
      DO 50 IFILL=1,N 
         SUM=0.D0 
         DO 40 I=1,N 
   40    SUM=SUM+STDPSI(I)*C(I,IFILL) 
         SUM=ABS(SUM) 
         IF(SUM.GT.SUMMAX)JFILL=IFILL 
         IF(SUM.GT.SUMMAX)SUMMAX=SUM 
         IF(SUM.GT.0.7071D0) GOTO 90 
   50 CONTINUE 
      DO 70 IFILL=1,N 
         SUM=0.D0 
         DO 60 I=1,N 
   60    SUM=SUM+PSI(I)*C(I,IFILL) 
         SUM=ABS(SUM) 
         IF(SUM.GT.SUMMAX)JFILL=IFILL 
         IF(SUM.GT.SUMMAX)SUMMAX=SUM 
         IF(SUM.GT.0.7071D0) GOTO 90 
   70 CONTINUE 
   80 FORMAT(' SUM VERY SMALL, SUM =',F12.6,' JFILL=',I3) 
      IFILL=JFILL 
   90 CONTINUE 
C 
C    STORE THE NEW VECTOR IN PSI 
C 
C      DO 22 I=1,N 
C  22  PSI(I)=C(I,IFILL) 
C 
C    NOW CHECK TO SEE IF IFILL IS FILLED 
C 
      IF(IFILL.LE.NOCC) RETURN 
C 
C    ITS EMPTY, SO SWAP IT WITH THE HIGHEST FILLED 
C 
      DO 100 I=1,N 
         X=C(I,NOCC) 
         C(I,NOCC)=C(I,IFILL) 
         C(I,IFILL)=X 
  100 CONTINUE 
      RETURN 
      END 
      SUBROUTINE SYMTRY 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR), 
     1         LOCDEP(MAXPAR) 
C********************************************************************** 
C 
C  SYMTRY COMPUTES THE BOND LENGTHS AND ANGLES THAT ARE FUNCTIONS OF 
C         OTHER BOND LENGTHS AND ANGLES. 
C 
C ON INPUT GEO     = KNOWN INTERNAL COORDINATES 
C          NDEP    = NUMBER OF DEPENDENCY FUNCTIONS. 
C          IDEPFN  = ARRAY OF DEPENDENCY FUNCTIONS. 
C          LOCDEP  = ARRAY OF LABELS OF DEPENDENT ATOMS. 
C          LOCPAR  = ARRAY OF LABELS OF REFERENCE ATOMS. 
C 
C  ON OUTPUT THE ARRAY "GEO" IS FILLED 
C*********************************************************************** 
C 
C     NOW COMPUTE THE DEPENDENT PARAMETERS. 
C 
      SAVE
      DO 10 I=1,NDEP 
         CALL HADDON (VALUE,LOCN,IDEPFN(I),LOCPAR(I),GEO) 
         J=LOCDEP(I) 
   10 GEO(LOCN,J)=VALUE 
      RETURN 
      END 
      SUBROUTINE THERMO(A,B,C,LINEAR,SYM,WT,VIBS,NVIBS) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION VIBS(*) 
      LOGICAL LINEAR 
      CHARACTER*80 KEYWRD, KOMENT, TITLE 
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TITLES/ KOMENT,TITLE 
C 
C 
C   THERMO CALCULATES THE VARIOUS THERMODYNAMIC QUANTITIES FOR A 
C   SPECIFIED TEMPERATURE GIVEN THE VIBRATIONAL FREQUENCIES, MOMENTS OF 
C   INERTIA, MOLECULAR WEIGHT AND SYMMETRY NUMBER. 
C 
C   REFERENCE: G.HERZBERG MOLECULAR SPECTRA AND MOLECULAR STRUCTURE 
C              VOL 2, CHAP. 5 
C 
C   ----    TABLE OF SYMMETRY NUMBERS    ---- 
C 
C        C1 CI CS     1      D2 D2D D2H  4       C(INF)V   1 
C        C2 C2V C2H   2      D3 D3D D3H  6       D(INF)H   2 
C        C3 C3V C3H   3      D4 D4D D4H  8       T TD     12 
C        C4 C4V C4H   4      D6 D6D D6H  12      OH       24 
C        C6 C6V C6H   6      S6          3 
C 
C 
C   PROGRAM LIMITATIONS:  THE EQUATIONS USED ARE APPROPRIATE TO THE 
C   HIGH TEMPERATURE LIMIT AND WILL BEGIN TO BE INADEQUATE AT TEMPERA- 
C   TURES BELOW ABOUT 100 K.  SECONDLY THIS PROGRAM IS ONLY APPROPRIATE 
C   IN THE CASE OF MOLECULES IN WHICH THERE IS NO FREE ROTATION 
C 
C 
C 
C 
******************************************************************* 
* 
*  THE FOLLOWING CONSTANTS ARE NOW DEFINED: 
*          PI  = CIRCUMFERENCE TO DIAMETER OF A CIRCLE 
*          R   = GAS CONSTANT IN CALORIES/MOLE 
*          H   = PLANCK'S CONSTANT IN ERG-SECONDS 
*          AK  = BOLTZMANN CONSTANT IN ERG/DEGREE 
*          AC  = SPEED OF LIGHT IN CM/SEC 
******************************************************************* 
      DATA PI /3.14159D0 / 
      DATA R/1.98726D0/ 
      DATA H/6.626D-27/ 
      DATA AK/1.3807D-16/ 
      DATA AC/2.99776D+10/ 
******************************************************************* 
      SAVE
      IT1=200 
      IT2=400 
      ISTEP=10 
      I=INDEX(KEYWRD,'THERMO(') 
      IF(I.NE.0) THEN 
         IT1=READA(KEYWRD,I) 
         IF(IT1.LT.100) THEN 
            WRITE(6,'(//10X,''TEMPERATURE RANGE STARTS TOO LOW,'', 
     1'' LOWER BOUND IS RESET TO 30K'')') 
            IT1=100 
         ENDIF 
         I=INDEX(KEYWRD,',') 
         IF(I.NE.0) THEN 
            KEYWRD(I:I)=' ' 
            IT2=READA(KEYWRD,I) 
            IF(IT2.LT.IT1) THEN 
               IT2=IT1+200 
               ISTEP=10 
               GOTO 10 
            ENDIF 
            I=INDEX(KEYWRD,',') 
            IF(I.NE.0) THEN 
               KEYWRD(I:I)=' ' 
               ISTEP=READA(KEYWRD,I) 
               IF(ISTEP.LT.1)ISTEP=1 
            ELSE 
               ISTEP=(IT2-IT1)/20 
               IF(ISTEP.EQ.0)ISTEP=1 
               IF(ISTEP.GE.2.AND. ISTEP.LT.5)ISTEP=2 
               IF(ISTEP.GE.5.AND. ISTEP.LT.10)ISTEP=5 
               IF(ISTEP.GE.10.AND. ISTEP.LT.20)ISTEP=10 
               IF(ISTEP.GT.20.AND. ISTEP.LT.50)ISTEP=20 
               IF(ISTEP.GT.50.AND. ISTEP.LT.100)ISTEP=50 
               IF(ISTEP.GT.100)ISTEP=100 
            ENDIF 
         ELSE 
            IT2=IT1+200 
         ENDIF 
      ENDIF 
   10 CONTINUE 
      WRITE(6,'(//,A)')TITLE 
      WRITE(6,'(A)')KOMENT 
      IF(LINEAR) THEN 
         WRITE(6,'(//10X,''MOLECULE IS LINEAR'')') 
      ELSE 
         WRITE(6,'(//10X,''MOLECULE IS NOT LINEAR'')') 
      ENDIF 
      WRITE(6,'(/10X,''THERE ARE'',I3,'' GENUINE VIBRATIONS IN THIS '', 
     1''SYSTEM'')')NVIBS 
      WRITE(6,20) 
   20 FORMAT(10X,'THIS THERMODYNAMICS CALCULATION IS LIMITED TO',/ 
     110X,'MOLECULES WHICH HAVE NO INTERNAL ROTATIONS'//) 
      WRITE(6,'(//20X,''CALCULATED THERMODYNAMIC PROPERTIES'')') 
      WRITE(6,'(/,''   TEMP. (K)   PARTITION FUNCTION      ENTHALPY'', 
     1''     HEAT CAPACITY    ENTROPY'')') 
      WRITE(6,'(  ''                                        CAL/MOL'', 
     1''       CAL/K/MOL     CAL/K/MOL'',/)') 
      DO 30 I=1,NVIBS 
   30 VIBS(I)=ABS(VIBS(I)) 
      DO 70 ITEMP=IT1,IT2,ISTEP 
         T=ITEMP 
C   ***   INITIALISE SOME VARIABLES   *** 
         C1=H*AC/AK/T 
         QV=1.0D0 
         HV=0.0D0 
         E0=0.0D0 
         CPV=0.0D0 
         SV1=0.0D0 
         SV2=0.0D0 
C   ***   CONSTRUCT THE FREQUENCY DEPENDENT PARTS OF PARTITION FUNCTION 
         DO 40 I=1,NVIBS 
            WI=VIBS(I) 
            EWJ=EXP(-WI*C1) 
            QV=QV/(1-EWJ) 
            HV=HV+WI*EWJ/(1-EWJ) 
            E0=E0+WI 
            CPV=CPV+WI*WI*EWJ/(1-EWJ)/(1-EWJ) 
            SV1=SV1+LOG(1.0D0-EWJ) 
   40    SV2=SV2+WI*EWJ/(1-EWJ) 
C   ***   FINISH CALCULATION OF VIBRATIONAL PARTS   *** 
         HV=HV*R*H*AC/AK 
         E0=E0*1.4295D0 
         CPV=CPV*R*C1*C1 
         SV=SV2*R*C1-R*SV1 
C   ***   NOW CALCULATE THE ROTATIONAL PARTS  (FIRST LINEAR MOLECULES 
         IF(.NOT.LINEAR) GOTO 50 
         QR=1/(C1*A*SYM) 
         HR=R*T 
         CPR=R 
         SR=R*(LOG(T*AK/(H*AC*A*SYM)))+R 
         GOTO 60 
   50    QR=SQRT(PI/(A*B*C*C1*C1*C1))/SYM 
         HR=3.0D0*R*T/2.0D0 
         CPR=3.0D0*R/2.0D0 
         SR=0.5D0*R*(3.D0*LOG(T*AK/(H*AC)) 
     1-2.D0*LOG(SYM)+LOG(PI/(A*B*C))+3.D0) 
   60    CONTINUE 
C   ***   CALCULATE INTERNAL CONTRIBUTIONS   *** 
         QINT=QV*QR 
         HINT=HV+HR 
         CPINT=CPV+CPR 
         SINT=SV+SR 
C   ***   CONSTRUCT TRANSLATION CONTRIBUTIONS   *** 
         QTR=(SQRT(2.D0*PI*WT*T*AK*1.6606D-24)/H)**3 
         HTR=5.0D0*R*T/2.0D0 
         CPTR=5.0D0*R/2.0D0 
         STR=2.2868D0*(5.0D0*LOG10(T)+3.0D0*LOG10(WT))-2.3135D0 
C   ***   CONSTRUCT TOTALS   *** 
         CPTOT=CPTR+CPINT 
         STOT=STR+SINT 
         HTOT=HTR+HINT 
C   ***   OUTPUT SECTION   *** 
         WRITE(6,'(/,I7,''  VIB.'',G18.4 
     1           ,6X,3F14.8        )')ITEMP,QV,  HV,  CPV,  SV 
         WRITE(6,'(7X,''  ROT.'',G13.3 
     1           ,6X,3F14.3        )')      QR,  HR,  CPR,  SR 
         WRITE(6,'(7X,''  INT.'',G13.3 
     1           ,6X,3F14.3        )')      QINT,HINT,CPINT,SINT 
         WRITE(6,'(7X,''  TRA.'',G13.3,6X,3F14.3)') 
     1                                      QTR, HTR, CPTR, STR 
         WRITE(6,'(7X,''  TOT.'',13X,7X,3F14.4)') 
     1                                      HTOT,CPTOT,STOT 
   70 CONTINUE 
      END 
      SUBROUTINE UPDATE(IPARAM, IELMNT, PARAM, MODE,KFN) 
      IMPLICIT REAL (A-H,O-Z) 
************************************************************************ 
* 
*  UPDATE UPDATES THE COMMON BLOCKS WHICH HOLD ALL THE PARAMETERS FOR 
*         RUNNING MNDO. 
*         IPARAM REFERS TO THE TYPE OF PARAMETER, 
*         IELMNT REFERS TO THE ELEMENT, 
*         PARAM IS THE VALUE OF THE PARAMETER, AND 
*         IF MODE = 1 THEN A COMMON BLOCK IS UPDATED, 
*         IF MODE = 2 THEN A DATUM IS EXTRACTED FROM THE COMMON BLOCK. 
* 
************************************************************************ 
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107),ZPM(107), 
     1ZDM(107), BETASM(107), BETAPM(107), BETADM(107), ALPM(107), 
     2EISOLM(107), DDM(107), QQM(107), AMM(107), ADM(107), AQM(107) 
     3,GSSM(107),GSPM(107),GPPM(107),GP2M(107),HSPM(107), POLVOM(107) 
      COMMON /EXPONT/ ZS(107),ZP(107),ZD(107) 
     1       /NATORB/ NATORB(107) 
     2       /BETAS / BETAS(107),BETAP(107),BETAD(107) 
     3       /VSIPS / VS(107),VP(107),VD(107) 
     4       /ONELEC/ USS(107),UPP(107),UDD(107) 
     5       /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107) 
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 
     7                ,GSD(107),GPD(107),GDD(107) 
     8       /ALPHA / ALP(107) 
     9       /IDEAS / GUESS1(107,10), GUESS2(107,10), GUESS3(107,10) 
     A               ,NGUESS(107) 
      COMMON /GAUSS / FN1(107),FN2(107) 
      SAVE
      GOTO 
     1(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170,180, 
     2190,200,210,220,230,240,250),IPARAM 
   10 USS (IELMNT)=PARAM 
      USSM(IELMNT)=PARAM 
      RETURN 
   20 UPP (IELMNT)=PARAM 
      UPPM(IELMNT)=PARAM 
      RETURN 
   30 UDD (IELMNT)=PARAM 
      UDDM(IELMNT)=PARAM 
      RETURN 
   40 ZS (IELMNT)=PARAM 
      ZSM(IELMNT)=PARAM 
      RETURN 
   50 ZP (IELMNT)=PARAM 
      ZPM(IELMNT)=PARAM 
      RETURN 
   60 ZD (IELMNT)=PARAM 
      ZDM(IELMNT)=PARAM 
      RETURN 
   70 BETAS (IELMNT)=PARAM 
      BETASM(IELMNT)=PARAM 
      RETURN 
   80 BETAP (IELMNT)=PARAM 
      BETAPM(IELMNT)=PARAM 
      RETURN 
   90 BETAD (IELMNT)=PARAM 
      BETADM(IELMNT)=PARAM 
      RETURN 
  100 GSS (IELMNT)=PARAM 
      GSSM(IELMNT)=PARAM 
      RETURN 
  110 GSP (IELMNT)=PARAM 
      GSPM(IELMNT)=PARAM 
      RETURN 
  120 GPP (IELMNT)=PARAM 
      GPPM(IELMNT)=PARAM 
      RETURN 
  130 GP2 (IELMNT)=PARAM 
      GP2M(IELMNT)=PARAM 
      RETURN 
  140 HSP (IELMNT)=PARAM 
      HSPM(IELMNT)=PARAM 
      RETURN 
  150 RETURN 
  160 RETURN 
  170 RETURN 
  180 ALP (IELMNT)=PARAM 
      ALPM(IELMNT)=PARAM 
      RETURN 
  190 RETURN 
  200 RETURN 
  210 RETURN 
  220 GUESS1(IELMNT,KFN)=PARAM 
      NGUESS(IELMNT)=MAX(NGUESS(IELMNT),KFN) 
      RETURN 
  230 GUESS2(IELMNT,KFN)=PARAM 
      RETURN 
  240 GUESS3(IELMNT,KFN)=PARAM 
      RETURN 
  250 NATORB(IELMNT)=PARAM 
      I=INT(PARAM+0.5) 
      IF(I.NE.9.AND.I.NE.4.AND.I.NE.1)THEN 
         WRITE(6,'(///10X,'' UNACCEPTABLE VALUE FOR NO. OF ORBITALS'', 
     1'' ON ATOM'')') 
         STOP 
      ENDIF 
      END 
      SUBROUTINE VECPRT (A,NUMB) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION  A(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /ELEMTS/ ELEMNT(107) 
C********************************************************************** 
C 
C  VECPRT PRINTS A LOWER-HALF TRIANGLE OF A SQUARE MATRIX, THE 
C         LOWER-HALF TRIANGLE BEING STORED IN PACKED FORM IN THE 
C         ARRAY "A" 
C 
C ON INPUT: 
C      A      = ARRAY TO BE PRINTED 
C      NUMB   = SIZE OF ARRAY TO BE PRINTED 
C(REF) NUMAT  = NUMBER OF ATOMS IN THE MOLECULE (THIS IS NEEDED TO 
C               DECIDE IF AN ATOMIC ARRAY OR ATOMIC ORBITAL ARRAY IS 
C               TO BE PRINTED 
C(REF) NAT    = LIST OF ATOMIC NUMBERS 
C(REF) NFIRST = LIST OF ORBITAL COUNTERS 
C(REF) NLAST  = LIST OF ORBITAL COUNTERS 
C 
C  NONE OF THE ARGUMENTS ARE ALTERED BY THE CALL OF VECPRT 
C 
C********************************************************************* 
      DIMENSION NATOM(200) 
      CHARACTER * 6 LINE(21) 
      CHARACTER*2 ELEMNT,ATORBS(9), ITEXT(200),JTEXT(200) 
      DATA ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/ 
      SAVE
      IF(NUMAT.NE.0.AND.NUMAT.EQ.NUMB) THEN 
C 
C    PRINT OVER ATOM COUNT 
C 
         DO 10 I=1,NUMAT 
            ITEXT(I)='  ' 
            JTEXT(I)=ELEMNT(NAT(I)) 
            NATOM(I)=I 
   10    CONTINUE 
      ELSE 
         IF (NUMAT.NE.0.AND.NLAST(NUMAT) .EQ. NUMB) THEN 
            DO 30 I=1,NUMAT 
               JLO=NFIRST(I) 
               JHI=NLAST(I) 
               L=NAT(I) 
               K=0 
               DO 20 J=JLO,JHI 
                  K=K+1 
                  ITEXT(J)=ATORBS(K) 
                  JTEXT(J)=ELEMNT(L) 
                  NATOM(J)=I 
   20          CONTINUE 
   30       CONTINUE 
         ELSE 
            NUMB=ABS(NUMB) 
            DO 40 I=1,NUMB 
               ITEXT(I) = '  ' 
               JTEXT(I) = '  ' 
   40       NATOM(I)=I 
         ENDIF 
      END IF 
      NUMB=ABS(NUMB) 
      DO 50 I=1,21 
   50 LINE(I)='------' 
      LIMIT=(NUMB*(NUMB+1))/2 
      KK=8 
      NA=1 
   60 LL=0 
      M=MIN0((NUMB+1-NA),6) 
      MA=2*M+1 
      M=NA+M-1 
      WRITE(6,100)(ITEXT(I),JTEXT(I),NATOM(I),I=NA,M) 
      WRITE (6,110) (LINE(K),K=1,MA) 
      DO 80 I=NA,NUMB 
         LL=LL+1 
         K=(I*(I-1))/2 
         L=MIN0((K+M),(K+I)) 
         K=K+NA 
         IF ((KK+LL).LE.50) GO TO 70 
         WRITE (6,120) 
         WRITE (6,100) (ITEXT(N),JTEXT(N),NATOM(N),N=NA,M) 
         WRITE (6,110) (LINE(N),N=1,MA) 
         KK=4 
         LL=0 
   70    WRITE (6,130) ITEXT(I),JTEXT(I),NATOM(I),(A(N),N=K,L) 
   80 CONTINUE 
      IF (L.GE.LIMIT) GO TO 90 
      KK=KK+LL+4 
      NA=M+1 
      IF ((KK+NUMB+1-NA).LE.50) GO TO 60 
      KK=4 
      WRITE (6,120) 
      GO TO 60 
   90 RETURN 
C 
  100 FORMAT (1H0/9X,10(2X,A2,1X,A2,I3,1X)) 
  110 FORMAT (1H ,21A6) 
  120 FORMAT (1H1) 
  130 FORMAT (1H ,A2,1X,A2,I3,10F11.6) 
C 
      END 
      SUBROUTINE VECRED(A,NUMB, IR) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION  A(*) 
C********************************************************************** 
C 
C  VECRED READS A LOWER-HALF TRIANGLE OF A SQUARE MATRIX, THE 
C         LOWER-HALF TRIANGLE BEING STORED IN PACKED FORM IN THE 
C         ARRAY "A" 
C 
C ON INPUT: 
C      A      = ARRAY TO BE PRINTED 
C      NUMB   = SIZE OF ARRAY TO BE PRINTED 
C      IR     = CHANNEL NUMBER FOR INPUT 
C(REF) NUMAT  = NUMBER OF ATOMS IN THE MOLECULE (THIS IS NEEDED TO 
C               DECIDE IF AN ATOMIC ARRAY OR ATOMIC ORBITAL ARRAY IS 
C               TO BE PRINTED 
C(REF) NAT    = LIST OF ATOMIC NUMBERS 
C(REF) NFIRST = LIST OF ORBITAL COUNTERS 
C(REF) NLAST  = LIST OF ORBITAL COUNTERS 
C 
C 
C********************************************************************* 
      CHARACTER * 6 LINE(21) 
      CHARACTER*2 ATORBS(9) 
      DATA ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/ 
      SAVE
      NUMB=ABS(NUMB) 
      LIMIT=(NUMB*(NUMB+1))/2 
      KK=8 
      NA=1 
   20 LL=0 
      M=MIN0((NUMB+1-NA),6) 
      MA=2*M+1 
      M=NA+M-1 
      READ( IR,'(A)')DUMC,DUMC,DUMC 
      DO 40 I=NA,NUMB 
         LL=LL+1 
         K=(I*(I-1))/2 
         L=MIN0((K+M),(K+I)) 
         K=K+NA 
         IF ((KK+LL).LE.50) GO TO 30 
         READ( IR,'(A)')DUMC,DUMC,DUMC 
         KK=4 
         LL=0 
   30    READ( IR,'(A9,10F11.6)')DUMY,(A(N),N=K,L) 
   90 FORMAT (1H ,A2,1X,A2,I3,10F11.6) 
   40 CONTINUE 
      IF (L.GE.LIMIT) GO TO 50 
      KK=KK+LL+4 
      NA=M+1 
      IF ((KK+NUMB+1-NA).LE.50) GO TO 20 
      KK=4 
C#      READ( IR,'(A)')DUMC 
      GO TO 20 
   50 CONTINUE 
C 
   60 FORMAT (1H0/9X,10(2X,A2,1X,A2,I3,1X)) 
   70 FORMAT (1H ,21A6) 
   80 FORMAT (1H1) 
C#      CALL VECPRT(A,NUMB) 
C 
      RETURN 
      END 
      SUBROUTINE VECWRT (A,NUMB,IW) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      DIMENSION  A(*) 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     +                NCLOSE,NOPEN 
C********************************************************************** 
C 
C  VECWRT OUTPUTS A LOWER-HALF TRIANGLE OF A SQUARE MATRIX TO 
C         CHANNEL IW, THE LOWER-HALF TRIANGLE BEING STORED IN 
C         PACKED FORM IN THE ARRAY "A" 
C 
C ON INPUT: 
C      A      = ARRAY TO BE PRINTED 
C      NUMB   = SIZE OF ARRAY TO BE PRINTED 
C      IW     = CHANNEL NUMBER FOR OUTPUT 
C(REF) NUMAT  = NUMBER OF ATOMS IN THE MOLECULE (THIS IS NEEDED TO 
C               DECIDE IF AN ATOMIC ARRAY OR ATOMIC ORBITAL ARRAY IS 
C               TO BE PRINTED 
C(REF) NAT    = LIST OF ATOMIC NUMBERS 
C(REF) NFIRST = LIST OF ORBITAL COUNTERS 
C(REF) NLAST  = LIST OF ORBITAL COUNTERS 
C 
C  NONE OF THE ARGUMENTS ARE ALTERED BY THE CALL OF VECPRT 
C 
C********************************************************************* 
      DIMENSION NATOM(MAXORB) 
      CHARACTER * 6 LINE(21) 
      CHARACTER*2 ELEMNT(107),ATORBS(9), ITEXT(MAXORB),JTEXT(MAXORB) 
      DATA ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/ 
      DATA ELEMNT/' H','He', 
     2 'Li','Be',' B',' C',' N',' O',' F','Ne', 
     3 'Na','Mg','Al','Si',' P',' S','Cl','Ar', 
     4 ' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu', 
     4 'Zn','Ga','Ge','As','Se','Br','Kr', 
     5 'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag', 
     5 'Cd','In','Sn','Sb','Te',' I','Xe', 
     6 'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy', 
     6 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir','Pt', 
     6 'Au','Hg','Tl','Pb','Bi','Po','At','Rn', 
     7 'Fr','Ra','Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','XX', 
     8 'Fm','Md','No','++',' +','--',' -','  '/ 
      SAVE
      IF(NUMAT.EQ.NUMB) THEN 
C 
C    PRINT OVER ATOM COUNT 
C 
          DO 10 I=1,NUMAT 
              ITEXT(I)='  ' 
              JTEXT(I)=ELEMNT(NAT(I)) 
              NATOM(I)=I 
  10          CONTINUE 
          ELSE 
          IF (NLAST(NUMAT) .EQ. NUMB) THEN 
              DO 30 I=1,NUMAT 
                  JLO=NFIRST(I) 
                  JHI=NLAST(I) 
                  L=NAT(I) 
                  K=0 
                  DO 20 J=JLO,JHI 
                      K=K+1 
                      ITEXT(J)=ATORBS(K) 
                      JTEXT(J)=ELEMNT(L) 
                      NATOM(J)=I 
  20              CONTINUE 
  30          CONTINUE 
              ELSE 
              NUMB=ABS(NUMB) 
              DO 40 I=1,NUMB 
                  ITEXT(I) = '  ' 
                  JTEXT(I) = '  ' 
  40              NATOM(I)=I 
              ENDIF 
          END IF 
      NUMB=ABS(NUMB) 
      DO 50 I=1,21 
  50       LINE(I)='------' 
      LIMIT=(NUMB*(NUMB+1))/2 
      KK=8 
      NA=1 
  60  LL=0 
      M=MIN0((NUMB+1-NA),6) 
      MA=2*M+1 
      M=NA+M-1 
      WRITE(IW,100)(ITEXT(I),JTEXT(I),NATOM(I),I=NA,M) 
      WRITE(IW,110) (LINE(K),K=1,MA) 
      DO 80 I=NA,NUMB 
         LL=LL+1 
         K=(I*(I-1))/2 
         L=MIN0((K+M),(K+I)) 
         K=K+NA 
         IF ((KK+LL).LE.50) GO TO 70 
C#         WRITE (IW,120) 
         WRITE (IW,100) (ITEXT(N),JTEXT(N),NATOM(N),N=NA,M) 
         WRITE (IW,110) (LINE(N),N=1,MA) 
         KK=4 
         LL=0 
  70     WRITE (IW,130) ITEXT(I),JTEXT(I),NATOM(I),(A(N),N=K,L) 
  80  CONTINUE 
      IF (L.GE.LIMIT) GO TO 90 
      KK=KK+LL+4 
      NA=M+1 
      IF ((KK+NUMB+1-NA).LE.50) GO TO 60 
      KK=4 
C#      WRITE (IW,120) 
      GO TO 60 
  90  RETURN 
C 
 100  FORMAT (1H0/9X,10(2X,A2,1X,A2,I3,1X)) 
 110  FORMAT (1H ,21A6) 
 120  FORMAT (1H1) 
 130  FORMAT (1H ,A2,1X,A2,I3,10F11.6) 
C 
      END 
      SUBROUTINE WRITE(TIME0,FUNCT) 
      IMPLICIT REAL (A-H,O-Z) 
      REAL MECI 
       INCLUDE "SIZES"
      COMMON /KEYWRD/ KEYWRD 
      COMMON /TITLES/ KOMENT,TITLE 
      COMMON /ELEMTS/ ELEMNT(107) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM) 
      COMMON /HMATRX/ H(MPACK) 
      COMMON /FOKMAT/ F(MPACK), FB(MPACK) 
      COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) 
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR) 
     1               ,LOCDEP(MAXPAR) 
      COMMON /REPATH/ LATOM,LPARAM,REACT(100) 
      COMMON /NUMSCF/ NSCF,NBIDUL 
      COMMON /WMATRX/ WJ(N2ELEC),WK(N2ELEC*2),NWDUM(NUMATM+1) 
      COMMON /ATHEAT/ ATHEAT 
      COMMON /CORE  / CORE(107) 
      COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MAXPAR**2-MPACK) 
      COMMON /CIDATA/ VECTCI(NMECI**2),XXDUM,NCI1,NCI2,NCI3 
     1               ,NCIDUM((1+NMECI*2)*NMECI**2) 
      COMMON /MESAGE/ IFLEPO,IITER 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      COMMON /ENUCLR/ ENUCLR 
      COMMON /ELECT / ELECT 
      COMMON /GRADNT/ GRAD(MAXPAR), GNORM 
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 
     2                NCLOSE,NOPEN,NDUMY,FRACT 
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT 
      COMMON /SCRAH2/ PQKL(NRELAX*MORB2) 
************************************************************************ 
* 
*   WRITE PRINTS OUT MOST OF THE RESULTS. 
*         IT SHOULD NOT ALTER ANY PARAMETERS, SO THAT IT CAN BE CALLED 
*         AT ANY CONVENIENT TIME. 
* 
************************************************************************ 
      DIMENSION Q(MAXORB), Q2(MAXORB), COORD(3,NUMATM), GCOORD(MAXPAR) 
     1,IEL1(107), NELEMT(107), IEL2(107) 
      DIMENSION W(N2ELEC) 
      DIMENSION DUMY(3) 
      LOGICAL UHF, CI, SINGLT, TRIPLT, EXCITD, PRTGRA, XYZ, FIRST, FAIL 
      CHARACTER TYPE(3)*11, IDATE*24, CALCN(2)*5, GTYPE*13, GRTYPE*14, 
     1          FLEPO(13)*58, ITER(2)*58, NUMBRS(11)*1 
      CHARACTER*2 ELEMNT, IELEMT(20), SPNTYP*7, CALTYP*7 
      CHARACTER*80 KEYWRD,KOMENT,TITLE 
      EQUIVALENCE (W,WJ) 
      DATA TYPE/'BOND       ','ANGLE      ','DIHEDRAL   '/ 
      DATA CALCN /'     ','ALPHA'/ 
      DATA NUMBRS /'0','1','2','3','4','5','6','7','8','9',' '/ 
      DATA FIRST /.TRUE./ 
      DATA FLEPO/ 
     1' 1SCF WAS SPECIFIED, SO FLETCHER-POWELL WAS NOT USED      ', 
     2' GRADIENTS WERE INITIALLY ACCEPTABLY SMALL                ', 
     3' HERBERTS TEST WAS SATISFIED IN FLETCHER-POWELL           ', 
     4' THE LINE MINIMISATION FAILED TWICE IN A ROW.   TAKE CARE]', 
     5' FLETCHER POWELL FAILED DUE TO COUNTS EXCEEDED. TAKE CARE]', 
     6' PETERS TEST WAS SATISFIED IN FLETCHER-POWELL OPTIMISATION', 
     7' THIS MESSAGE SHOULD NEVER APPEAR, CONSULT A PROGRAMMER]] ', 
     8' GRADIENT TEST NOT PASSED, BUT FURTHER WORK NOT JUSTIFIED ', 
     9' A FAILURE HAS OCCURRED, TREAT RESULTS WITH CAUTION]]     ', 
     1' GEOMETRY OPTIMISED : ENERGY MINIMISED                    ', 
     2' GEOMETRY OPTIMISED : GRADIENT NORM MINIMISED             ', 
     3' TIME OR CYCLES EXCEEDED, OPTIMIZATION NOT COMPLETED      ', 
     4'                                                          '/ 
      DATA ITER/ 
     1' SCF FIELD WAS ACHIEVED                                   ', 
     2'  ++++----**** FAILED TO ACHIEVE SCF. ****----++++        '/ 
C 
C SUMMARY OF RESULTS (NOTE: THIS IS IN A SUBROUTINE SO IT 
C          CAN BE USED BY THE PATH OPTION) 
      SAVE
      PI=3.141592653589D0 
      IDATE=' ' 
      IF(IFLEPO.LE.0.OR.IFLEPO.GT.13) IFLEPO=7 
      IUHF=MIN(INDEX(KEYWRD,'UHF'),1)+1 
      PRTGRA=(INDEX(KEYWRD,'GRAD').NE.0) 
      LINEAR=(NORBS*(NORBS+1))/2 
      XYZ=(INDEX(KEYWRD,' XYZ') .NE. 0) 
      SINGLT=(INDEX(KEYWRD,'SING') .NE. 0) 
      TRIPLT=(INDEX(KEYWRD,'TRIP') .NE. 0) 
      EXCITD=(INDEX(KEYWRD,'EXCI') .NE. 0) 
      SPNTYP='GROUND ' 
      IF(SINGLT) SPNTYP='SINGLET' 
      IF(TRIPLT) SPNTYP='TRIPLET' 
      IF(EXCITD) SPNTYP='EXCITED' 
      CI=(INDEX(KEYWRD,'C.I.') .NE. 0) 
      IF(INDEX(KEYWRD,'MIND') .NE. 0) THEN 
         CALTYP='MINDO/3' 
      ELSEIF(INDEX(KEYWRD,'AM1') .NE. 0) THEN 
         CALTYP='  AM1  ' 
      ELSE 
         CALTYP=' MNDO  ' 
      ENDIF 
      UHF=(IUHF.EQ.2) 
      CALL DATE(IDATE) 
      DEGREE=57.29577951D0 
      IF(NA(1).EQ.99)THEN 
         DEGREE=1.D0 
         TYPE(1)='           ' 
         TYPE(2)='           ' 
         TYPE(3)='           ' 
      ENDIF 
      GNORM=0.D0 
      IF(NVAR.NE.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 
      WRITE(IPRT,'(1X,A)')KEYWRD,KOMENT,TITLE 
      WRITE(IPRT,'(//4X,A58)')FLEPO(IFLEPO) 
      WRITE(IPRT,'(4X,A58)')ITER(IITER) 
      WRITE(IPRT,'(//30X,A7,''  CALCULATION'')')CALTYP 
      WRITE(IPRT,'(60X,''VERSION '',F5.2)')VERSON 
      IF(IITER.EQ.2)THEN 
C 
C   RESULTS ARE MEANINGLESS. DON'T PRINT ANYTHING] 
C 
         WRITE(IPRT,'(//,'' FOR SOME REASON THE SCF CALCULATION FAILED. 
     .'',/ 
     1,'' THE RESULTS WOULD BE MEANINGLESS, SO WILL NOT BE PRINTED.'',/, 
     2'' TRY TO FIND THE REASON FOR THE FAILURE BY USING "PL".'',/, 
     3'' CHECK YOUR GEOMETRY AND ALSO TRY USING SHIFT OR PULAY. '')') 
         CALL GEOUT 
         STOP 
      ENDIF 
      WRITE(IPRT,'(////10X,''FINAL HEAT OF FORMATION ='',F13.6,'' KCAL'' 
     1)')FUNCT 
      IF(LATOM.EQ.0) WRITE(IPRT,'(/)') 
      WRITE(IPRT,'(    10X,''ELECTRONIC ENERGY       ='',F13.6,'' EV'' 
     1)')ELECT 
      WRITE(IPRT,'(    10X,''CORE-CORE REPULSION     ='',F13.6,'' EV'' 
     1)')ENUCLR 
      IF(LATOM.EQ.0) WRITE(IPRT,'(1X)') 
      IF(NVAR.NE.0) 
     1WRITE(IPRT,'(    10X,''GRADIENT NORM           ='',F13.6)')GNORM 
      IF(LATOM.NE.0) THEN 
C 
C   WE NEED TO CALCULATE THE REACTION COORDINATE GRADIENT. 
C 
         MVAR=NVAR 
         LOC11=LOC(1,1) 
         LOC21=LOC(2,1) 
         NVAR=1 
         LOC(1,1)=LATOM 
         LOC(2,1)=LPARAM 
         XREACT=GEO(LPARAM,LATOM) 
         CALL DERIV(GCOORD,FAIL) 
         NVAR=MVAR 
         LOC(1,1)=LOC11 
         LOC(2,1)=LOC21 
         GRTYPE=' KCAL/ANGSTROM' 
         IF(LPARAM.EQ.1)THEN 
            WRITE(IPRT,'(    10X,''FOR REACTION COORDINATE ='',F13.6 
     1        ,'' ANGSTROMS'')')XREACT 
         ELSE 
            IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN  ' 
            WRITE(IPRT,'(    10X,''FOR REACTION COORDINATE ='',F13.6 
     1        ,'' DEGREES'')')XREACT*DEGREE 
         ENDIF 
         WRITE(IPRT,'(    10X,''REACTION GRADIENT       ='',F13.6,A14 
     1    )')GCOORD(1),GRTYPE 
         IF(FAIL) WRITE(IPRT,'('' * * * *** WARNING *** * * * SCF '', 
     1''DIVERGENCE IN GRADIENT COMPUTATION''/ 
     2'' WHEN DERIV CALLED BY WRITE ... SOME COMPONENTS MEANINGLESS'')') 
      ENDIF 
      IF(NALPHA.GT.0)THEN 
         EIONIS=-MAX(EIGS(NALPHA), EIGB(NBETA)) 
      ELSEIF(NELECS.EQ.1)THEN 
         EIONIS=-EIGS(1) 
      ELSEIF(NELECS.GT.1) THEN 
         EIONIS=-MAX(EIGS(NCLOSE), EIGS(NOPEN)) 
      ELSE 
         EIONIS=0.D0 
      ENDIF 
      NOPN=NOPEN-NCLOSE 
C   CORRECTION TO I.P. OF DOUBLETS 
      IF(NOPN.EQ.1)THEN 
C        NOTE ... IJKL USES /SCRACH/ AND PQKL AS WORKING ARRAYS. 
         CALL IJKL (C,NORBS,NOPEN,1,W,PQKL,NRELAX*MORB2,XIIII,1 
     .             ,PQKL,.FALSE.) 
         EIONIS=EIONIS+0.5D0*XIIII 
      ENDIF 
      WRITE(IPRT,'(       10X,''IONISATION POTENTIAL    ='',F13.6)') 
     .EIONIS 
      WRITE(IPRT,'(55X,A24)')IDATE 
      IF( UHF ) THEN 
         WRITE(IPRT,'(    10X,''NO. OF ALPHA ELECTRONS  ='',I6)')NALPHA 
         WRITE(IPRT,'(    10X,''NO. OF BETA  ELECTRONS  ='',I6)')NBETA 
      ELSE 
         WRITE(IPRT,'(    10X,''NO. OF FILLED LEVELS    ='',I6)')NCLOSE 
         IF(NOPN.NE.0) THEN 
            WRITE(IPRT,'( 10X,''AND NO. OF OPEN LEVELS  ='',I6)')NOPN 
         ENDIF 
      ENDIF 
      SUMW=0 
      DO 10 I=1,NUMAT 
   10 SUMW=SUMW+ATMASS(I) 
      IF(SUMW.GT.0.1D0) 
     +WRITE(IPRT,'(    10X,''MOLECULAR WEIGHT        ='',F10.3)')SUMW 
      IF(LATOM.EQ.0) WRITE(IPRT,'(/)') 
      WRITE(IPRT,'(10X,''SCF CALCULATIONS  =   '',I5 )') NSCF 
      CALL SECOND (TFLY) 
      TIM=TFLY-TIME0 
      I=TIM*0.000001D0 
      TIM=TIM-I*1000000 
      WRITE(IPRT,'(10X,''COMPUTATION TIME  ='',F11.2,'' SECONDS'')') TIM 
      IF( NDEP .NE. 0 )CALL SYMTRY 
      IF(NA(1).NE.99) THEN 
         DO 50 J=1,NATOMS 
            DO 50 I=1,3 
               X=GEO(I,J) 
               GOTO (40, 30, 20) I 
   20          X=X - AINT(X/(2.D0*PI)+SIGN(0.4999D0,X)-0.0001D0)*PI*2.D0 
               GEO(3,J)=X 
               GOTO 40 
   30          X=X - AINT(X/(2.D0*PI))*PI*2.D0 
               IF(X.LT.0)X=X+PI*2.D0 
               IF(X .GT. PI) THEN 
                  GEO(3,J)=GEO(3,J)+PI 
                  X=2.D0*PI-X 
               ENDIF 
               GEO(2,J)=X 
   40          CONTINUE 
   50    CONTINUE 
      ENDIF 
      DO 60 I=1,NVAR 
   60 XPARAM(I)=GEO(LOC(2,I),LOC(1,I)) 
      CALL GMETRY(GEO,COORD) 
      IF(PRTGRA)THEN 
         WRITE(IPRT,'(///7X,''FINAL  POINT  AND  DERIVATIVES'',/)') 
         WRITE(IPRT,'(''   PARAMETER     ATOM    TYPE  '' 
     1    ,''          VALUE       GRADIENT'')') 
      ENDIF 
      SUM=0.5D0 
      DO 70 I=1,NUMAT 
   70 SUM=SUM+CORE(NAT(I)) 
      I=SUM 
      KCHRGE=I-NCLOSE-NOPEN-NALPHA-NBETA 
C 
C    WRITE OUT THE GEOMETRIC VARIABLES 
C 
      IF(PRTGRA) THEN 
         DO 80 I=1,NVAR 
            J=LOC(2,I) 
            K=LOC(1,I) 
            L=LABELS(K) 
            XI=XPARAM(I) 
            IF(J.NE.1) XI=XI*DEGREE 
            IF(J.EQ.1.OR.NA(1).EQ.99)THEN 
               GTYPE='KCAL/ANGSTROM' 
            ELSE 
               GTYPE='KCAL/RADIAN  ' 
            ENDIF 
   80    WRITE(IPRT,'(I7,I11,1X,A2,4X,A11,F13.6,F13.6,2X,A13)') 
     1I,K,ELEMNT(L),TYPE(J),XI,GRAD(I),GTYPE 
      ENDIF 
C 
C     WRITE OUT THE GEOMETRY 
C 
      WRITE(IPRT,'(///)') 
      CALL GEOUT 
      IF (INDEX(KEYWRD,'NOIN') .EQ. 0) THEN 
C 
C   WRITE OUT THE INTERATOMIC DISTANCES 
C 
         L=0 
         DO 90 I=1,NUMAT 
            DO 90 J=1,I 
               L=L+1 
   90    RXYZ(L)=SQRT((COORD(1,I)-COORD(1,J))**2+ 
     1                         (COORD(2,I)-COORD(2,J))**2+ 
     2                         (COORD(3,I)-COORD(3,J))**2) 
         WRITE(IPRT,'(//10X,''  INTERATOMIC DISTANCES'')') 
         CALL VECPRT(RXYZ,NUMAT) 
      ENDIF 
      IF (INDEX(KEYWRD,'VECT') .NE. 0) THEN 
         WRITE(IPRT,'(//10X,A5,'' EIGENVECTORS  '')')CALCN(IUHF) 
         CALL MATOUT (C,EIGS,NORBS,NORBS,NORBS) 
         IF(UHF) THEN 
            WRITE(IPRT,'(//10X,'' BETA EIGENVECTORS  '')') 
            CALL MATOUT (CBETA,EIGB,NORBS,NORBS,NORBS) 
         ENDIF 
      ELSE 
         WRITE(IPRT,'(//10X,A5,''   EIGENVALUES'',/)')CALCN(IUHF) 
         WRITE(IPRT,'(8F10.5)')(EIGS(I),I=1,NORBS) 
         IF(UHF) THEN 
            WRITE(IPRT,'(//10X,'' BETA EIGENVALUES '')') 
            WRITE(IPRT,'(8F10.5)')(EIGB(I),I=1,NORBS) 
         ENDIF 
      END IF 
      IF((CI.OR.NOPEN.NE.NCLOSE.OR.INDEX(KEYWRD,'SIZE').NE.0) 
     1 .AND. INDEX(KEYWRD,'MECI')+INDEX(KEYWRD,'ESR').NE.0)THEN 
         WRITE(IPRT,'(//10X, 
     1''MULTI-ELECTRON CONFIGURATION INTERACTION CALCULATION'',//)') 
         NMOS=0 
         NCIS=0 
         IF(INDEX(KEYWRD,'C.I.=').NE.0) 
     1      NMOS=READA(KEYWRD,INDEX(KEYWRD,'C.I.=')+5) 
C 
C   SET UP C.I. PARAMETERS 
C   NMOS IS NO. OF M.O.S USED IN C.I. 
C   NCIS IS CHANGE IN SPIN, OR NUMBER OF STATES 
C 
         IF(NMOS.EQ.0) NMOS=NOPEN-NCLOSE 
         IF(NCIS.EQ.0) THEN 
            IF(TRIPLT.OR.INDEX(KEYWRD,'QUAR').NE.0)NCIS=1 
            IF(INDEX(KEYWRD,'QUIN')+INDEX(KEYWRD,'SEXT').NE.0)NCIS=2 
         ENDIF 
         X=MECI(EIGS,C,CBETA,EIGB, NORBS,NMOS,NCIS,.TRUE.,.FALSE.) 
         CALL MECIP (P,C,CBETA,NORBS,PQKL,NCI2) 
      ENDIF 
      WRITE(IPRT,'(//13X,'' NET ATOMIC CHARGES AND DIPOLE '', 
     1''CONTRIBUTIONS'',/)') 
      WRITE(IPRT,'(8X,'' ATOM NO.   TYPE          CHARGE        ATOM'' 
     1,''  ELECTRON DENSITY'')') 
      CALL CHRGE(P,Q) 
      DO 100 I=1,NUMAT 
         L=NAT(I) 
         Q2(I)=CORE(L) - Q(I) 
  100 WRITE(IPRT,'(I12,9X,A2,4X,F13.4,F16.4)') 
     1I,ELEMNT(L),Q2(I),Q(I) 
      IF(KCHRGE.EQ.0) DIP= DIPOLE(P,Q2,COORD,DUMY) 
      IF (INDEX(KEYWRD,'NOXY') .EQ. 0) THEN 
         WRITE(IPRT,'(//10X,''CARTESIAN COORDINATES '',/)') 
         WRITE(IPRT,'(4X,''NO.'',7X,''ATOM'',15X,''X'', 
     1  9X,''Y'',9X,''Z'',/)') 
         WRITE(IPRT,'(I6,8X,A2,14X,3F10.4)') 
     1  (I,ELEMNT(NAT(I)),(COORD(J,I),J=1,3),I=1,NUMAT) 
      END IF 
      IF (INDEX(KEYWRD,'FOCK') .NE. 0) THEN 
         WRITE(IPRT,'('' FOCK MATRIX IS '')') 
         CALL VECPRT(F,NORBS) 
      END IF 
      IF (INDEX(KEYWRD,'DENS') .NE. 0) THEN 
         WRITE(IPRT,'('' DENSITY MATRIX IS '')') 
         CALL VECPRT(P,NORBS) 
      ELSE 
         WRITE(IPRT,'(//10X,''ATOMIC ORBITAL ELECTRON POPULATIONS'',/)') 
         WRITE(IPRT,'(8F10.5)')(P((I*(I+1))/2),I=1,NORBS) 
      END IF 
      IF(INDEX(KEYWRD,' PI') .NE. 0) THEN 
         WRITE(IPRT,'(//10X,''SIGMA-PI BOND-ORDER MATRIX'')') 
         CALL DENROT 
      ENDIF 
      IF(UHF) THEN 
         SZ=ABS(NALPHA-NBETA)*0.5D0 
         SS2=SZ*SZ 
         L=0 
         DO 120 I=1,NORBS 
            DO 110 J=1,I 
               L=L+1 
               PA(L)=PA(L)-PB(L) 
  110       SS2=SS2+PA(L)**2 
  120    SS2=SS2-0.5D0*PA(L)**2 
         WRITE(IPRT,'(//20X,''(SZ)    ='',F10.6)')SZ 
         WRITE(IPRT,'(  20X,''(S**2)  ='',F10.6)')SS2 
         IF(INDEX(KEYWRD,'SPIN') .NE. 0) THEN 
            WRITE(IPRT,'(//10X,''SPIN DENSITY MATRIX'')') 
            CALL VECPRT(PA,NORBS) 
         ELSE 
            WRITE(IPRT,'(//10X,''ATOMIC ORBITAL SPIN POPULATIONS'',/)') 
            WRITE(IPRT,'(8F10.5)')(PA((I*(I+1))/2),I=1,NORBS) 
         ENDIF 
         IF(INDEX(KEYWRD,'HYPE') .NE. 0) THEN 
C 
C  WORK OUT THE HYPERFINE COUPLING CONSTANTS. 
C 
            WRITE(IPRT,'(//10X,''    HYPERFINE COUPLING COEFFICIENTS'' 
     .                ,/)') 
            J=(NALPHA-1)*NORBS 
            DO 130 K=1,NUMAT 
               I=NFIRST(K) 
  130       Q(K)=PA((I*(I+1))/2)*0.3333333D0+C(I+J)**2*0.66666666D0 
            WRITE(IPRT,'(5(2X,A2,I2,F9.5,1X))') 
     1    (ELEMNT(NAT(I)),I,Q(I),I=1,NUMAT) 
         ENDIF 
         DO 140 I=1,LINEAR 
  140    PA(I)=P(I)-PB(I) 
      ENDIF 
      IF (INDEX(KEYWRD,'BOND') .NE. 0) THEN 
         CALL BONDS(P) 
      END IF 
      I=NCLOSE+NALPHA 
      IF (INDEX(KEYWRD,'LOCA') .NE. 0) THEN 
         CALL LOCAL(C,NORBS,I,EIGS) 
         IF(NBETA.NE.0)THEN 
            WRITE(IPRT,'(//10X,'' LOCALISED BETA MOLECULAR ORBITALS'')') 
            CALL LOCAL(CBETA,NORBS,NBETA,EIGB) 
         ENDIF 
      END IF 
      IF (INDEX(KEYWRD,'1ELE') .NE. 0) THEN 
         WRITE(IPRT,'('' FINAL ONE-ELECTRON MATRIX '')') 
         CALL VECPRT(H,NORBS) 
      END IF 
      IF(INDEX(KEYWRD,'ENPA') .NE. 0) 
     1CALL ENPART(UHF,H,PA,PB,P,Q,COORD) 
      DO 150 I=1,107 
  150 NELEMT(I)=0 
      DO 160 I=1,NUMAT 
         IGO=NAT(I) 
         IF (IGO.GT.107) GO TO 160 
         NELEMT(IGO)=NELEMT(IGO)+1 
  160 CONTINUE 
      ICHFOR=0 
      IF (NELEMT(6).EQ.0) GO TO 170 
      ICHFOR=1 
      IELEMT(1)=ELEMNT(6) 
      NZS=NELEMT(6) 
      IF (NZS.LT.10) THEN 
         IF (NZS.EQ.1) THEN 
            IEL1(1)=11 
         ELSE 
            IEL1(1)=NZS+1 
         ENDIF 
         IEL2(1)=11 
      ELSE 
         KFRST=NZS/10 
         KSEC=NZS-(10*KFRST) 
         IEL1(1)=KFRST+1 
         IEL2(1)=KSEC+1 
      ENDIF 
  170 NELEMT(6)=0 
      DO 180 I=1,107 
         IF (NELEMT(I).EQ.0) GO TO 180 
         ICHFOR=ICHFOR+1 
         IELEMT(ICHFOR)=ELEMNT(I) 
         NZS=NELEMT(I) 
         IF (NZS.LT.10) THEN 
            IF (NZS.EQ.1) THEN 
               IEL1(ICHFOR)=11 
            ELSE 
               IEL1(ICHFOR)=NZS+1 
            ENDIF 
            IEL2(ICHFOR)=11 
         ELSE 
            KFRST=NZS/10 
            KSEC=NZS-(10*KFRST) 
            IEL1(ICHFOR)=KFRST+1 
            IEL2(ICHFOR)=KSEC+1 
         ENDIF 
  180 CONTINUE 
      IF(INDEX(KEYWRD,'DENO') .NE. 0) THEN 
      OPEN(UNIT=10,STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 10
         WRITE(10)(PA(I),I=1,LINEAR) 
         IF(UHF)WRITE(10)(PB(I),I=1,LINEAR) 
         CLOSE (10) 
      ENDIF 
      IF(INDEX(KEYWRD,'DENM') .NE. 0) THEN 
          REWIND 15 
          IF (UHF) THEN 
             CALL VECWRT(PA,NORBS,15) 
             CALL VECWRT(PB,NORBS,15) 
          ELSE 
             CALL VECWRT(P,NORBS,15) 
          ENDIF 
      ENDIF 
      IF (INDEX(KEYWRD,'MULL') +INDEX(KEYWRD,'GRAP') .NE. 0) THEN 
         IF (INDEX(KEYWRD,'MULL') .NE. 0) THEN 
            WRITE(IPRT,'(/10X,'' MULLIKEN POPULATION ANALYSIS'')') 
         ELSE 
            WRITE(IPRT,'(/10X,'' DATA FOR GRAPH WRITTEN TO DISK'')') 
         ENDIF 
         CALL MULLIK(C,UHF,H,NORBS) 
      END IF 
C 
C   ***************************************************************** 
C   *                                                               * 
C   *      SUMMARY OF OUTPUT ON FILE IWRITE ( . ARC FILE )          * 
C   *                                                               * 
C   ***************************************************************** 
C 
C     NOT DONE IF OPTIMISATION NOT ACHIEVED 
      IF (IFLEPO.EQ.5 .OR. IFLEPO.EQ.9 .OR. IFLEPO.EQ.12) RETURN 
C 
      IF(FIRST)THEN 
         OPEN(UNIT=12,STATUS='UNKNOWN') 
         REWIND 12 
         FIRST=.FALSE. 
      ENDIF 
      IWRITE=12 
      WRITE(IWRITE,'(//20X,'' SUMMARY OF '',A7, 
     1'' CALCULATION'',/)')CALTYP 
      WRITE(IWRITE,'(60X,''VERSION '',F5.2)')VERSON 
      WRITE (IWRITE,190) (IELEMT(I),NUMBRS(IEL1(I)),NUMBRS(IEL2(I)) 
     1,I=1,ICHFOR) 
  190 FORMAT (//,1X,17(A2,A1,A1)) 
      WRITE(IWRITE,'(55X,A24)')IDATE 
      WRITE(IWRITE,'(1X,A)')KOMENT,TITLE 
      WRITE(IWRITE,'(//4X,A58)')FLEPO(IFLEPO) 
      WRITE(IWRITE,'(4X,A58)')ITER(IITER) 
      WRITE(IWRITE,'(//10X,''HEAT OF FORMATION       ='' 
     1,F13.6,'' KCAL'')')FUNCT 
      WRITE(IWRITE,'(  10X,''ELECTRONIC ENERGY       ='' 
     1,F13.6,'' EV'')')ELECT 
      WRITE(IWRITE,'(  10X,''CORE-CORE REPULSION     ='' 
     1,F13.6,'' EV'')')ENUCLR 
      IF(PRTGRA) 
     1WRITE(IWRITE,'(  10X,''GRADIENT NORM           ='' 
     2,F13.6)')GNORM 
      IF(LATOM.NE.0) THEN 
         XREACT=GEO(LPARAM,LATOM) 
         GRTYPE=' KCAL/ANGSTROM' 
         IF(LPARAM.EQ.1)THEN 
            WRITE(IWRITE,'(    10X,''FOR REACTION COORDINATE ='',F13.4 
     1        ,'' ANGSTROMS'')')XREACT 
         ELSE 
            IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN  ' 
            WRITE(IWRITE,'(    10X,''FOR REACTION COORDINATE ='',F13.4 
     1        ,'' DEGREES'')')XREACT*DEGREE 
         ENDIF 
         WRITE(IWRITE,'(    10X,''REACTION GRADIENT       ='',F13.6,A14 
     1    )')GCOORD(1),GRTYPE 
         IF(FAIL) WRITE(IWRITE,'('' * * * *** WARNING *** * * * SCF '', 
     1''DIVERGENCE IN GRADIENT COMPUTATION''/ 
     2'' WHEN DERIV CALLED BY WRITE ... SOME COMPONENTS MEANINGLESS'')') 
      ENDIF 
      IF(KCHRGE .EQ. 0) 
     1WRITE(IWRITE,'(  10X,''DIPOLE                  ='' 
     2,F12.5, '' DEBYE'')')DIP 
      IF(UHF) THEN 
         WRITE(IWRITE,'(  10X,''(SZ)                    ='',F13.6)')SZ 
         WRITE(IWRITE,'(  10X,''(S**2)                  ='',F13.6)')SS2 
         WRITE(IWRITE,'(  10X,''NO. OF ALPHA ELECTRONS  ='',I6)')NALPHA 
         WRITE(IWRITE,'(  10X,''NO. OF BETA  ELECTRONS  ='',I6)')NBETA 
      ELSE 
         WRITE(IWRITE,'(  10X,''NO. OF FILLED LEVELS    ='',I6)')NCLOSE 
         NOPN=NOPEN-NCLOSE 
         IF(NOPN.NE.0) 
     1WRITE(IWRITE,'(  10X,''AND NO. OF OPEN LEVELS  ='',I6)')NOPN 
      ENDIF 
      IF(CI) 
     1WRITE(IWRITE,'(  10X,''CONFIGURATION INTERACTION WAS USED'')') 
      IF(KCHRGE.NE.0) 
     1WRITE(IWRITE,'(  10X,''CHARGE ON SYSTEM        ='',I6)')KCHRGE 
      WRITE(IWRITE,'(  10X,''IONISATION POTENTIAL    ='' 
     1,F13.6,'' EV'')')EIONIS 
      WRITE(IWRITE,'(  10X,''MOLECULAR WEIGHT        ='',F10.3)')SUMW 
      WRITE(IWRITE,'(  10X,''SCF CALCULATIONS        ='' 
     1,I6 )') NSCF 
      CALL SECOND (TFLY) 
      TIM=TFLY-TIME0 
      I=TIM 
      TIM=TIM-I/1000000 
      WRITE(IWRITE,'(  10X,''COMPUTATION TIME        ='' 
     1,F9.2,'' SECONDS'')') TIM 
      WRITE(IWRITE,'(//10X,''FINAL GEOMETRY OBTAINED'',33X,''CHARGE'')') 
      WRITE(IWRITE,'(1X,A)')KEYWRD,KOMENT,TITLE 
      NA1=NA(1) 
      IF(XYZ) CALL XYZINT(GEO,NATOMS,NA,NB,NC,1.D0,COORD) 
      DEGREE=57.29577951D0 
      COORD(2,1)=0.D0 
      COORD(3,1)=0.D0 
      COORD(1,1)=0.D0 
      COORD(2,2)=0.D0 
      COORD(3,2)=0.D0 
      COORD(3,3)=0.D0 
      IVAR=1 
      NA(1)=0 
      L=0 
      DO 220 I=1,NATOMS 
         DO 200 J=1,3 
            IF(.NOT.XYZ)COORD(J,I)=GEO(J,I) 
  200    IEL1(J)=0 
  210    CONTINUE 
         IF(LOC(1,IVAR).EQ.I) THEN 
            IEL1(LOC(2,IVAR))=1 
            IVAR=IVAR+1 
            GOTO 210 
         ENDIF 
         IF(I.LT.4) THEN 
            IEL1(3)=0 
            IF(I.LT.3) THEN 
               IEL1(2)=0 
               IF(I.LT.2) THEN 
                  IEL1(1)=0 
               ENDIF 
            ENDIF 
         ENDIF 
         IF(I.EQ.LATOM)IEL1(LPARAM)=-1 
         Q(1)=COORD(1,I) 
         Q(2)=COORD(2,I)*DEGREE 
         Q(3)=COORD(3,I)*DEGREE 
         IF(LABELS(I).LT.99)THEN 
            L=L+1 
            WRITE(IWRITE,'(2X,A2,3(F12.6,I3),I4,2I3,F13.4)') 
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I),Q2(L) 
         ELSE 
            WRITE(IWRITE,'(2X,A2,3(F12.6,I3),I4,2I3,F13.4)') 
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I) 
         ENDIF 
  220 CONTINUE 
      NA(1)=NA1 
      I=0 
      X=0.D0 
      WRITE(IWRITE,'(I4,3(F12.6,I3),I4,2I3)') 
     1    I,X,I,X,I,X,I,I,I,I 
      DO 230 I=1,NDEP 
  230 WRITE(IWRITE,'(3(I4,'',''))')LOCPAR(I),IDEPFN(I),LOCDEP(I) 
      WRITE(IWRITE,'(///)') 
      NSCF=0 
      RETURN 
      END 
      SUBROUTINE WRTKEY(KEYWRD) 
      IMPLICIT REAL (A-H,O-Z) 
      COMMON / OPTIM/ IMP,IMP0,LEC,IPRT 
      CHARACTER*80 KEYWRD 
      LOGICAL UHF, TRIP, BIRAD, EXCI, CI, FAIL 
      LOGICAL AM1, MNDO, MINDO3 
      CHARACTER SPACE*1, DOT*1, ZERO*1, NINE*1, CH*1 
      DATA SPACE,DOT,ZERO,NINE /' ','.','0','9'/ 
      SAVE
      NINT(X)=INT(X+SIGN(0.5D0,X)) 
C 
      KNTROL=0 
      FAIL=.FALSE. 
C 
C  RESTART 
      IF (INDEX(KEYWRD,'REST') .NE. 0 ) WRITE(IPRT,240) 
C 
C  0 OR 1 SCF 
      IF (INDEX(KEYWRD,'0SCF') .NE. 0 ) WRITE(IPRT,890) 
      IF (INDEX(KEYWRD,'1SCF') .NE. 0 ) WRITE(IPRT,410) 
C 
C  2-D GRID 
      IF (INDEX(KEYWRD,'STEP') .NE. 0 ) THEN 
         KNTROL=KNTROL+1 
         WRITE(IPRT,970) 
      ENDIF 
C 
C  OPTIMISATION SECTION 
      IF (INDEX(KEYWRD,'NEWT') .NE. 0 ) THEN 
         WRITE(IPRT,900) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'LTRD') .NE. 0 ) THEN 
         WRITE(IPRT,910) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'POWE') .NE. 0 ) THEN 
         WRITE(IPRT,920) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'PATH') .NE. 0 ) THEN 
         WRITE(IPRT,930) 
         KNTROL=KNTROL+1 
         IF (INDEX(KEYWRD,'T.V.') .NE. 0 ) WRITE(IPRT,950) 
         IF (INDEX(KEYWRD,'WEIG') .NE. 0 ) WRITE(IPRT,960) 
      ENDIF 
      IF (INDEX(KEYWRD,'CHAI') .NE. 0 ) THEN 
         WRITE(IPRT,940) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'FORC') .NE. 0 ) THEN 
         WRITE(IPRT,430) 
         KNTROL=KNTROL+1 
         IF (INDEX(KEYWRD,' LET') .NE. 0 ) WRITE(IPRT,620) 
         IF (INDEX(KEYWRD,'THER') .NE. 0 )THEN 
            WRITE(IPRT,850) 
            I=INDEX(KEYWRD,' ROT') 
            IF(I.NE.0) THEN 
               WRITE(IPRT,860)NINT(READA(KEYWRD,I)) 
            ELSE 
               WRITE(IPRT,' 
     1       (//10X,'' YOU MUST SUPPLY THE SYMMETRY NUMBER "ROT"'')') 
               FAIL=.TRUE. 
            ENDIF 
         ENDIF 
         IF (INDEX(KEYWRD,'TRANS(') .NE. 0 ) THEN 
            WRITE(IPRT,600) 
         ELSEIF (INDEX(KEYWRD,'TRANS=') .NE. 0 ) THEN 
            WRITE(IPRT,590)NINT(READA(KEYWRD,INDEX(KEYWRD,'TRANS='))) 
         ELSEIF (INDEX(KEYWRD,'TRANS(') .NE. 0 ) THEN 
            WRITE(IPRT,580) 
         ENDIF 
      ENDIF 
      IF (INDEX(KEYWRD,'SIGM') .NE. 0 ) THEN 
         WRITE(IPRT,550) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'NLLS') .NE. 0 ) THEN 
         WRITE(IPRT,560) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,'SADD') .NE. 0 ) THEN 
         WRITE(IPRT,610) 
         I=  INDEX(KEYWRD,'BAR=') 
         IF (I.NE.0) WRITE(IPRT,740)     READA(KEYWRD,I) 
         KNTROL=KNTROL+1 
      ENDIF 
      IF (INDEX(KEYWRD,' DRC') .NE. 0 ) THEN 
         WRITE(IPRT,140) 
         KNTROL=KNTROL+1 
         I=  INDEX(KEYWRD,'DRC=') 
         IF (I.NE.0) WRITE(IPRT,150)     READA(KEYWRD,I) 
         I= INDEX(KEYWRD,'KINE') 
         IF (I.NE.0) WRITE(IPRT,160)     READA(KEYWRD,I) 
      ENDIF 
      IF ( KNTROL              .EQ. 0 ) THEN 
         WRITE(IPRT,980) 
         IF (INDEX(KEYWRD,'FULS') .NE. 0  .OR. 
     .       INDEX(KEYWRD,'PREC') .NE. 0) WRITE(IPRT,1010) 
      ELSE IF (KNTROL          .GT. 1 ) THEN 
         WRITE(IPRT,880) 
         FAIL=.TRUE. 
      ENDIF 
      I=  INDEX(KEYWRD,'CYCLES=') 
      IF (I.NE.0) WRITE(IPRT,840)NINT(READA(KEYWRD,I)) 
      I=  INDEX(KEYWRD,'GNORM=') 
      IF (I.NE.0) WRITE(IPRT,670)     READA(KEYWRD,I) 
      I=  INDEX(KEYWRD,'PRINT=') 
      IF (I.NE.0) WRITE(IPRT,650)NINT(READA(KEYWRD,I)) 
      IF (INDEX(KEYWRD,' XYZ') .NE. 0 ) WRITE(IPRT,190) 
      IF (INDEX(KEYWRD,'GEO-') .NE. 0 ) WRITE(IPRT,100) 
      I= (INDEX(KEYWRD,'ROOT=')) 
      IF (I.NE.0) WRITE(IPRT,570)NINT(READA(KEYWRD,I)) 
      IF (INDEX(KEYWRD,'PREC') .NE. 0 ) WRITE(IPRT,460) 
C 
C  SYMMETRY CONDITION 
      IF (INDEX(KEYWRD,'SYM' ) .NE. 0 ) WRITE(IPRT,370) 
C 
C  INITIAL & FINAL PRINTOUT 
      IF (INDEX(KEYWRD,'NOIN') .NE. 0 ) WRITE(IPRT,470) 
      IF (INDEX(KEYWRD,'NOXY') .NE. 0 ) WRITE(IPRT,540) 
      IF (INDEX(KEYWRD,'VECT') .NE. 0 ) WRITE(IPRT,40) 
      IF (INDEX(KEYWRD,'DENS') .NE. 0 ) WRITE(IPRT,50) 
      IF (INDEX(KEYWRD,'SPIN') .NE. 0 ) WRITE(IPRT,60) 
      IF (INDEX(KEYWRD,'HYPE') .NE. 0 ) WRITE(IPRT,790) 
      IF (INDEX(KEYWRD,'TIME') .NE. 0 ) WRITE(IPRT,70) 
      IF (INDEX(KEYWRD,'BOND') .NE. 0 ) WRITE(IPRT,90) 
      IF (INDEX(KEYWRD,'FOCK') .NE. 0 ) WRITE(IPRT,110) 
      IF (INDEX(KEYWRD,'1ELE') .NE. 0 ) WRITE(IPRT,120) 
      IF (INDEX(KEYWRD,' ESR') .NE. 0 ) WRITE(IPRT,130) 
      IF (INDEX(KEYWRD,'LOCA') .NE. 0 ) WRITE(IPRT,170) 
      IF (INDEX(KEYWRD,'MULL') .NE. 0 ) WRITE(IPRT,180) 
      IF (INDEX(KEYWRD,' PI' ) .NE. 0 ) WRITE(IPRT,200) 
      IF (INDEX(KEYWRD,'ENPA') .NE. 0 ) WRITE(IPRT,530) 
      IF (INDEX(KEYWRD,'ECHO') .NE. 0 ) WRITE(IPRT,210) 
      IF (INDEX(KEYWRD,'GRAD') .NE. 0 ) WRITE(IPRT,260) 
      IF (INDEX(KEYWRD,'POLA') .NE. 0 ) WRITE(IPRT,220) 
C 
C  NON-STANDARD OUTPUT (FILES) 
      IF (INDEX(KEYWRD,'ISOT') .NE. 0 ) WRITE(IPRT,480) 
      IF (INDEX(KEYWRD,'DENO') .NE. 0 ) WRITE(IPRT,490) 
C 
C  DEBUG... 
      IF (INDEX(KEYWRD,'DEBU') .NE. 0 ) WRITE(IPRT,230) 
      IF (INDEX(KEYWRD,'DERINU').NE.0 ) WRITE(IPRT,1030) 
      IF (INDEX(KEYWRD,'FAIL') .NE. 0 ) WRITE(IPRT,1040) 
C 
C  ... AND DEDICATED PRINTOUT 
      IF (INDEX(KEYWRD,'DEBUGP').NE. 0 ) WRITE(IPRT,750) 
      IF (INDEX(KEYWRD,'FLEP') .NE. 0 ) WRITE(IPRT,80) 
      IF (INDEX(KEYWRD,'COMP') .NE. 0 ) WRITE(IPRT,630) 
      IF (INDEX(KEYWRD,'DERI') .NE. 0 ) WRITE(IPRT,640) 
      IF (INDEX(KEYWRD,'DCAR') .NE. 0 ) WRITE(IPRT,660) 
      IF (INDEX(KEYWRD,'FMAT') .NE. 0 ) WRITE(IPRT,680) 
      IF (INDEX(KEYWRD,'HCOR') .NE. 0 ) WRITE(IPRT,690) 
      IF (INDEX(KEYWRD,'ITER') .NE. 0 ) WRITE(IPRT,700) 
      IF (INDEX(KEYWRD,'LINM') .NE. 0 ) WRITE(IPRT,720) 
      IF (INDEX(KEYWRD,'LOCM') .NE. 0 ) WRITE(IPRT,730) 
      IF (INDEX(KEYWRD,'EIGS') .NE. 0 ) WRITE(IPRT,770) 
      IF (INDEX(KEYWRD,'MOLD') .NE. 0 ) WRITE(IPRT,780) 
      IF (INDEX(KEYWRD,'OPCI') .NE. 0 ) WRITE(IPRT,800) 
      IF (INDEX(KEYWRD,' PL' ) .NE. 0 ) WRITE(IPRT,810) 
      IF (INDEX(KEYWRD,'SEAR') .NE. 0 ) WRITE(IPRT,820) 
      IF (INDEX(KEYWRD,'DERI1').NE. 0 ) WRITE(IPRT,990) 
      IF (INDEX(KEYWRD,'DERI2').NE. 0 ) WRITE(IPRT,1000) 
      IF (INDEX(KEYWRD,'MECI') .NE. 0 ) WRITE(IPRT,1020) 
C 
C  ALLOWED TIME 
      I=INDEX(KEYWRD,' T=') 
      IF(I.NE.0) THEN 
         TIME=READA(KEYWRD,I) 
         DO 10 J=I+3,80 
            CH=KEYWRD(J:J) 
            IF( CH .NE. DOT .AND. (CH .LT. ZERO .OR. CH .GT. NINE)) THEN 
               IF( CH .EQ. 'M') TIME=TIME*60 
               GOTO 20 
            ENDIF 
   10    CONTINUE 
   20    CONTINUE 
         WRITE(IPRT,400)TIME 
      ENDIF 
C 
C  HALF ELECTRON AT SCF LEVEL 
      I=INDEX(KEYWRD,'OPEN(') 
      IF(I.NE.0) THEN 
         IELEC=READA(KEYWRD,I) 
         ILEVEL=READA(KEYWRD,I+7) 
         WRITE(IPRT,390)IELEC,ILEVEL 
      ENDIF 
C 
C  CONFIGURATION INTERACTION 
      CI=(INDEX(KEYWRD,'C.I.').NE.0) 
      I=INDEX(KEYWRD,'C.I.=') 
      IF(I.NE.0)THEN 
         I=READA(KEYWRD,I+5) 
         WRITE(IPRT,420)I 
      ELSEIF (CI) THEN 
         WRITE(IPRT,420)ILEVEL 
      ENDIF 
      I=INDEX(KEYWRD,'MICROS') 
      IF(I.NE.0)THEN 
         I=READA(KEYWRD,I) 
         WRITE(IPRT,380)I 
      ENDIF 
C 
C  CHARGE & MULTIPLICITY 
      I=  INDEX(KEYWRD,'CHARGE=') 
      IF (I.NE.0) WRITE(IPRT,250) NINT(READA(KEYWRD,I)) 
      IF (INDEX(KEYWRD,'SING') .NE. 0 ) WRITE(IPRT,310) 
      IF (INDEX(KEYWRD,'DOUB') .NE. 0 ) WRITE(IPRT,320) 
      IF (INDEX(KEYWRD,'TRIP') .NE. 0 ) WRITE(IPRT,330) 
      IF (INDEX(KEYWRD,'QUAR') .NE. 0 ) WRITE(IPRT,340) 
      IF (INDEX(KEYWRD,'QUIN') .NE. 0 ) WRITE(IPRT,350) 
      IF (INDEX(KEYWRD,'SEXT') .NE. 0 ) WRITE(IPRT,360) 
C 
      UHF=  (INDEX(KEYWRD,'UHF')     .NE. 0 ) 
      IF    (UHF)            WRITE(IPRT,270) 
      BIRAD=(INDEX(KEYWRD,'BIRA')   .NE. 0 ) 
      IF    (BIRAD)          WRITE(IPRT,290) 
      EXCI= (INDEX(KEYWRD,'EXCI') .NE. 0 ) 
      IF    (EXCI)           WRITE(IPRT,300) 
      TRIP= (INDEX(KEYWRD,'TRIP') .NE. 0 ) 
C 
C  MODEL 
      MINDO3= INDEX(KEYWRD,'MINDO') .NE. 0 
      IF (MINDO3) WRITE(IPRT,440) 
      AM1   = INDEX(KEYWRD,'AM1'  ) .NE. 0 
      IF (AM1)    WRITE(IPRT,450) 
      MNDO= .NOT.(MINDO3.OR.AM1) 
      IF (INDEX(KEYWRD,'MNDO' ) .NE. 0 ) MNDO=.TRUE. 
C 
C  DRIVING THE SCF 
      IF (INDEX(KEYWRD,'PULA') .NE. 0 ) WRITE(IPRT,710) 
      IF (INDEX(KEYWRD,'CAMP') + INDEX(KEYWRD,'KING') 
     .                         .NE. 0 ) WRITE(IPRT,760) 
      I=  INDEX(KEYWRD,'SHIFT=') 
      IF (I.NE.0) WRITE(IPRT,500)      READA(KEYWRD,I) 
      IF (INDEX(KEYWRD,'OLDENS') .NE. 0 ) WRITE(IPRT,510) 
      I=  INDEX(KEYWRD,'SCFCRT=') 
      IF (I.NE.0) WRITE(IPRT,520)      READA(KEYWRD,I) 
      I=  INDEX(KEYWRD,'ITRY=') 
      IF (I.NE.0) WRITE(IPRT,870) NINT(READA(KEYWRD,I)) 
      I=  INDEX(KEYWRD,'FILL=') 
      IF (I.NE.0) WRITE(IPRT,830) NINT(READA(KEYWRD,I)) 
C 
C  COMPATIBILITY CONTROL 
      IF(UHF)THEN 
         IF(BIRAD.OR.EXCI.OR.CI)THEN 
            WRITE(IPRT,880) 
            FAIL=.TRUE. 
         ENDIF 
      ELSE 
         IF(EXCI.AND. TRIP) THEN 
            WRITE(IPRT,880) 
            FAIL=.TRUE. 
         ENDIF 
      ENDIF 
      IF ( (MINDO3 .AND. AM1) .OR. (MINDO3 .AND. MNDO) .OR. 
     1     (MNDO .AND. AM1) )   THEN 
         WRITE (IPRT,880) 
         FAIL=.TRUE. 
      ENDIF 
      IF(.NOT.FAIL) THEN 
         RETURN 
      ELSE 
         WRITE(IPRT,'(5X,''-- - CALCULATION ABANDONED, SORRY] - --'')') 
         STOP 
      ENDIF 
   40 FORMAT(' *  VECTORS  - FINAL EIGENVECTORS TO BE PRINTED') 
   50 FORMAT(' *  DENSITY  - FINAL DENSITY MATRIX TO BE PRINTED') 
   60 FORMAT(' *  SPIN     - FINAL UHF SPIN MATRIX TO BE PRINTED') 
   70 FORMAT(' *  TIMES    - TIMES OF VARIOUS STAGES TO BE PRINTED') 
   80 FORMAT(' *  FLEPO    - PRINT DETAILS OF GEOMETRY OPTIMISATION') 
   90 FORMAT(' *  BONDS    - FINAL BOND-ORDER MATRIX TO BE PRINTED') 
  100 FORMAT(' *  GEO-OK   - OVERRIDE INTERATOMIC DISTANCE CHECK') 
  110 FORMAT(' *  FOCK     - LAST FOCK MATRIX TO BE PRINTED') 
  120 FORMAT(' *  1ELECTRON- FINAL ONE-ELECTRON MATRIX TO BE PRINTED') 
  130 FORMAT(' *  ESR      - RHF SPIN DENSITY CALCULATION REQUESTED') 
  140 FORMAT(' *  DRC      - DYNAMIC REACTION COORDINATE CALCULATION') 
  150 FORMAT(' *  DRC=     - HALF-LIFE FOR KINETIC ENERGY LOSS =',F9.2, 
     1' * 10**(-14) SECONDS') 
  160 FORMAT(' *  KINETIC= - ',F7.3,' KCAL KINETIC ENERGY ADDED TO DRC') 
  170 FORMAT(' *  LOCALISE - LOCALISED ORBITALS TO BE PRINTED') 
  180 FORMAT(' *  MULLIK   - THE MULLIKEN ANALYSIS TO BE PERFORMED') 
  190 FORMAT(' *   XYZ     - CARTESIAN COORDINATE SYSTEM TO BE USED') 
  200 FORMAT(' *   PI      - BONDS MATRIX, SPLIT INTO SIGMA-PI-DELL', 
     1' COMPONENTS, TO BE PRINTED') 
  210 FORMAT(' *  ECHO     - ALL INPUT DATA TO BE ECHOED BEFORE RUN') 
  220 FORMAT(' *  POLAR    - CALCULATE THE POLARIZATION VOLUMES') 
  230 FORMAT(' *  DEBUG    - DEBUG OPTION TURNED ON') 
  240 FORMAT(' *  RESTART  - CALCULATION RESTARTED') 
  250 FORMAT(1(' *',/),' *',15X,'  CHARGE ON SYSTEM =',I3,1(/,' *')) 
  260 FORMAT(' *  GRADIENTS- ALL GRADIENTS TO BE PRINTED') 
  270 FORMAT(' *  UHF      - UNRESTRICTED HARTREE-FOCK CALCULATION') 
  280 FORMAT(' *  SINGLET  - STATE REQUIRED MUST BE A SINGLET') 
  290 FORMAT(' *  BIRADICAL- SYSTEM HAS TWO UNPAIRED ELECTRONS') 
  300 FORMAT(' *  EXCITED  - FIRST EXCITED STATE IS TO BE OPTIMISED') 
  310 FORMAT(' *  SINGLET  - SPIN STATE DEFINED AS A SINGLET') 
  320 FORMAT(' *  DOUBLET  - SPIN STATE DEFINED AS A DOUBLET') 
  330 FORMAT(' *  TRIPLET  - SPIN STATE DEFINED AS A TRIPLET') 
  340 FORMAT(' *  QUARTET  - SPIN STATE DEFINED AS A QUARTET') 
  350 FORMAT(' *  QUINTET  - SPIN STATE DEFINED AS A QUINTET') 
  360 FORMAT(' *  SEXTET   - SPIN STATE DEFINED AS A SEXTET') 
  370 FORMAT(' *  SYMMETRY - SYMMETRY CONDITIONS TO BE IMPOSED') 
  380 FORMAT(' *  MICROS=N -',I4,' MICROSTATES TO BE SUPPLIED FOR C.I.') 
  390 FORMAT(' *  OPEN(N,N)- RHF WITH ',I2,' ELECTRONS IN',I2,' LEVELS') 
  400 FORMAT(' *   T=      - A TIME OF',F8.1,' SECONDS REQUESTED') 
  410 FORMAT(' *  1SCF     - READ KEYWORD BUT DO 1 SCF AND THEN STOP ') 
  420 FORMAT(' *  C.I.=N   -',I2,' M.O.S TO BE USED IN C.I.') 
  430 FORMAT(' *  FORCE    - FORCE CALCULATION SPECIFIED') 
  440 FORMAT(' *  MINDO/3  - THE MINDO/3 HAMILTONIAN TO BE USED') 
  450 FORMAT(' *  AM1      - THE AM1 HAMILTONIAN TO BE USED') 
  460 FORMAT(' *  PRECISE  - OPTIMIZATION CRITERIA TO BE INCREASED BY 10 
     . ',                   'TIMES,'/ 
     .       ' *           -     S.C.F.   CRITERIA BY 100 TIMES,'/ 
     .       ' *           - AND USE ACCURATE FINITE DIFFERENCE FORMULA 
     .',                    'IN HESSIAN') 
  470 FORMAT(' *  NOINTER  - INTERATOMIC DISTANCES NOT TO BE PRINTED') 
  480 FORMAT(' *  ISOTOPE  - FORCE MATRIX WRITTEN TO DISK (CHAN. 9 )') 
  490 FORMAT(' *  DENOUT   - DENSITY MATRIX OUTPUT ON CHANNEL 10') 
  500 FORMAT(' *  SHIFT    - A DAMPING FACTOR OF',F8.2,' DEFINED') 
  510 FORMAT(' *  OLDENS   - INITIAL DENSITY MATRIX READ OF DISK') 
  520 FORMAT(' *  SCFCRT   - DEFAULT SCF CRITERION REPLACED BY',F12.8) 
  530 FORMAT(' *  ENPART   - ENERGY TO BE PARTITIONED INTO COMPONENTS') 
  540 FORMAT(' *  NOXYZ    - CARTESIAN COORDINATES NOT TO BE PRINTED') 
  550 FORMAT(' *  SIGMA    - GRADIENTS TO BE MINIMIZED USING SIGMA.') 
  560 FORMAT(' *  NLLSQ    - GRADIENTS TO BE MINIMISED USING NLLSQ.') 
  570 FORMAT(' *  ROOT     - IN A C.I. CALCULATION, ROOT',I2, 
     1                       ' TO BE OPTIMISED.') 
  580 FORMAT(' *  TRANS    - THE REACTION VIBRATION TO BE DELETED FROM', 
     1' THE THERMO CALCULATION') 
  590 FORMAT(' *  TRANS=   - ',I4,' VIBRATIONS ARE TO BE DELETED FROM', 
     1' THE THERMO CALCULATION') 
  600 FORMAT(' *  TRANS(   - SPECIFIC VIBRATIONS TO BE DELETED FROM', 
     1' THE THERMO CALCULATION') 
  610 FORMAT(' *  SADDLE   - TRANSITION STATE TO BE OPTIMISED') 
  620 FORMAT(' *   LET     - DO NOT REDUCE GRADIENTS IN FORCE') 
  630 FORMAT(' *  COMPFG   - PRINT HEAT OF FORMATION CALC''D IN COMPFG') 
  640 FORMAT(' *  DERIV    - PRINT DETAILS OF WORKING IN DERIV') 
  650 FORMAT(' *  PRINT    - PRINTOUT LEVEL IN OPTIMISATION =',I4) 
  660 FORMAT(' *  DCART    - PRINT DETAILS OF WORKING IN DCART') 
  670 FORMAT(' *  GNORM=   - OPTIMIZATION EXIT WHEN GRADIENT NORM BELOW' 
     .                      ,F9.3) 
  680 FORMAT(' *  FMAT     - PRINT DETAILS OF WORKING IN FMAT') 
  690 FORMAT(' *  HCORE    - PRINT DETAILS OF WORKING IN HCORE') 
  700 FORMAT(' *  ITER     - PRINT DETAILS OF WORKING IN ITER') 
  710 FORMAT(' *  PULAY    - PULAY''S METHOD TO BE USED IN SCF') 
  720 FORMAT(' *  LINMIN   - PRINT DETAILS OF WORKING IN LINMIN') 
  730 FORMAT(' *  LOCMIN   - PRINT DETAILS OF WORKING IN LOCMIN') 
  740 FORMAT(' *  BAR=     - REDUCE BAR LENGTH BY A MAX. OF',F7.2) 
  750 FORMAT(' *  DEBUGPULAY-PRINT DETAILS OF WORKING IN PULAY') 
  760 FORMAT(' *  CAMP,KING- THE CAMP-KING CONVERGER TO BE USED') 
  770 FORMAT(' *  EIGS     - PRINT ALL EIGENVALUES IN ITER') 
  780 FORMAT(' *  MOLDAT   - PRINT DETAILS OF WORKING IN MOLDAT') 
  790 FORMAT(' *  HYPERFINE- HYPERFINE COUPLING CONSTANTS TO BE' 
     1,' PRINTED') 
  800 FORMAT(' *  OPCI     - PRINT DETAILS OF WORKING IN OPCI') 
  810 FORMAT(' *   PL      - MONITOR CONVERGANCE IN DENSITY MATRIX') 
  820 FORMAT(' *  SEARCH   - PRINT DETAILS OF WORKING IN SEARCH') 
  830 FORMAT(' *  FILL=    - IN RHF CLOSED SHELL, FORCE M.O.',I3,' TO BE 
     1 FILLED') 
  840 FORMAT(' *  CYCLES=  - DO A MAXIMUM OF ',I4,' CYCLES IN OPTIMIZATI 
     1ON') 
  850 FORMAT(' *  THERMO   - THERMODYNAMIC QUANTITIES TO BE CALCULATED') 
  860 FORMAT(' *  ROT      - SYMMETRY NUMBER OF',I3,' SPECIFIED') 
  870 FORMAT(' *  ITRY=    - DO A MAXIMUM OF',I6,' ITERATIONS FOR SCF') 
  880 FORMAT(' ******************* IMCOMPATIBLE OPTION REQUESTED******') 
  890 FORMAT(' *  0SCF     - AFTER READING AND PRINTING DATA, STOP') 
  900 FORMAT(' *  NEWTON   - MINIMIZE ENERGY USING FULL-NEWTON') 
  910 FORMAT(' *  LTRD     - MINIMISE GRADIENT USING FULL-NEWTON') 
  920 FORMAT(' *  POWELL   - MINIMISE GRADIENT USING POWELL METHOD') 
  930 FORMAT(' *  PATH     - FOLLOW THE DESCENDING REACTION PATH') 
  940 FORMAT(' *  CHAIN    - TRANSITION STATE TO BE OPTIMISED') 
  950 FORMAT(' *  T.V.     - TRANSITION VECTOR TO BE PROVIDED FOR PATH') 
  960 FORMAT(' *  WEIGHT   - WEIGHT TO BE PROVIDED FOR PATH ') 
  970 FORMAT(' *  STEP1    - 2-D GRID CALCULATION TO BE PERFORMED') 
  980 FORMAT(' *           - MINIMIZE ENERGY USING D-F-P  METHOD') 
  990 FORMAT(' *  DERI1    - PRINT DETAILS OF WORKING IN DERI1') 
 1000 FORMAT(' *  DERI2    - PRINT DETAILS OF WORKING IN DERI2') 
 1010 FORMAT(' *  FULSCF   - WITH FULL SCF IN EACH SEARCH') 
 1020 FORMAT(' *  MECI     - PRINT DETAILED RESULTS IN C.I.') 
 1030 FORMAT(' *  DERINU   - ***** ALL DERIVATIVES BY NUMERICAL METHOD') 
 1040 FORMAT(' *  FAIL     - ***** ALL SCF RESTARTED WITH DIAG. DENS.') 
      END 
      SUBROUTINE XYZINT(XYZ,NUMAT,NA,NB,NC,DEGREE,GEO) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XYZ(3,*), NA(*), NB(*), NC(*), GEO(3,*) 
*********************************************************************** 
* 
* XYZINT WORKS OUT THE INTERNAL COORDINATES OF A MOLECULE. 
*        THE "RULES" FOR THE CONNECTIVITY ARE AS FOLLOWS: 
*        ATOM I IS DEFINED AS BEING AT A DISTANCE FROM THE NEAREST 
*        ATOM J, ATOM J ALREADY HAVING BEEN DEFINED. 
*        ATOM I MAKES AN ANGLE WITH ATOM J AND THE ATOM K, WHICH HAS 
*        ALREADY BEEN DEFINED, AND IS THE NEAREST ATOM TO J 
*        ATOM I MAKES A DIHEDRAL ANGLE WITH ATOMS J, K, AND L. L HAVING 
*        BEEN DEFINED AND IS THE NEAREST ATOM TO K 
* 
*        NOTE THAT GEO AND XYZ MUST NOT BE THE SAME IN THE CALL. 
* 
*   ON INPUT XYZ    = CARTESIAN ARRAY OF NUMAT ATOMS 
*            DEGREE = 1 IF ANGLES ARE TO BE IN RADIANS 
*            DEGREE = 57.29578 IF ANGLES ARE TO BE IN DEGREES 
* 
*********************************************************************** 
      SAVE
      NAI1=0 
      NAI2=0 
      DO 20 I=1,NUMAT 
         NA(I)=2 
         NB(I)=3 
         NC(I)=4 
         IM1=I-1 
         IF(IM1.EQ.0)GOTO 20 
         SUM=100.D0 
         DO 10 J=1,IM1 
            R=(XYZ(1,I)-XYZ(1,J))**2+ 
     1          (XYZ(2,I)-XYZ(2,J))**2+ 
     2          (XYZ(3,I)-XYZ(3,J))**2 
            IF(R.LT.SUM.AND.NA(J).NE.J.AND.NB(J).NE.J) THEN 
               SUM=R 
               K=J 
            ENDIF 
   10    CONTINUE 
C 
C   ATOM I IS NEAREST TO ATOM K 
C 
         NA(I)=K 
         IF(I.GT.2)NB(I)=NA(K) 
         IF(I.GT.3)NC(I)=NB(K) 
C 
C   FIND ANY ATOM TO RELATE TO NA(I) 
C 
   20 CONTINUE 
      NA(1)=0 
      NB(1)=0 
      NC(1)=0 
      NB(2)=0 
      NC(2)=0 
      NC(3)=0 
      CALL XYZGEO(XYZ,NUMAT,NA,NB,NC,DEGREE,GEO) 
      RETURN 
      END 
      SUBROUTINE XYZGEO(XYZ,NUMAT,NA,NB,NC,DEGREE,GEO) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XYZ(3,*), NA(*), NB(*), NC(*), GEO(3,*) 
*********************************************************************** 
* 
*   XYZGEO CONVERTS COORDINATES FROM CARTESIAN TO INTERNAL. 
* 
*     ON INPUT XYZ  = ARRAY OF CARTESIAN COORDINATES 
*              NUMAT= NUMBER OF ATOMS 
*              NA   = NUMBERS OF ATOM TO WHICH ATOMS ARE RELATED 
*                     BY DISTANCE 
*              NB   = NUMBERS OF ATOM TO WHICH ATOMS ARE RELATED 
*                     BY ANGLE 
*              NC   = NUMBERS OF ATOM TO WHICH ATOMS ARE RELATED 
*                     BY DIHEDRAL 
* 
*    ON OUTPUT GEO  = INTERNAL COORDINATES IN ANGSTROMS, RADIANS, 
*                     AND RADIANS 
*                     ANGLE BETWEEN 0 AND PI, 
*                     DIHEDRAL BETWEEN -PI AND PI, ACCORDING TO THE 
*                     CLOCKWISE CONVENTION (ANTI TRIGONOMETRIC), 
*                     ( KLYNE & PRELOG,EXPERIENTIA 16, 521(1960) ) 
* 
*********************************************************************** 
      SAVE
      DO 10 I=2,NUMAT 
         J=NA(I) 
         K=NB(I) 
         L=NC(I) 
         IF(I.LT.3) GOTO 10 
         II=I 
         CALL BANGLE(XYZ,II,J,K,GEO(2,I)) 
         GEO(2,I)=GEO(2,I)*DEGREE 
         IF(I.LT.4) GOTO 10 
         CALL DIHED(XYZ,II,J,K,L,GEO(3,I)) 
         GEO(3,I)=GEO(3,I)*DEGREE 
   10 GEO(1,I)= SQRT((XYZ(1,I)-XYZ(1,J))**2+ 
     1                   (XYZ(2,I)-XYZ(2,J))**2+ 
     2                   (XYZ(3,I)-XYZ(3,J))**2) 
      GEO(1,1)=0.D0 
      GEO(2,1)=0.D0 
      GEO(3,1)=0.D0 
      GEO(2,2)=0.D0 
      GEO(3,2)=0.D0 
      GEO(3,3)=0.D0 
      RETURN 
      END 
      SUBROUTINE BANGLE(XYZ,I,J,K,ANGLE) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XYZ(3,*) 
********************************************************************* 
* 
* BANGLE CALCULATES THE ANGLE BETWEEN ATOMS I,J, AND K. THE 
*        CARTESIAN COORDINATES ARE IN XYZ. 
* 
********************************************************************* 
      SAVE
      D2IJ = (XYZ(1,I)-XYZ(1,J))**2+ 
     1       (XYZ(2,I)-XYZ(2,J))**2+ 
     2       (XYZ(3,I)-XYZ(3,J))**2 
      D2JK = (XYZ(1,J)-XYZ(1,K))**2+ 
     1       (XYZ(2,J)-XYZ(2,K))**2+ 
     2       (XYZ(3,J)-XYZ(3,K))**2 
      IF(D2IJ*D2JK.LT.1.D-30) THEN 
         ANGLE=0.D0 
      ELSE 
         D2IK = (XYZ(1,I)-XYZ(1,K))**2+ 
     1          (XYZ(2,I)-XYZ(2,K))**2+ 
     2          (XYZ(3,I)-XYZ(3,K))**2 
         ANGLE=ACOS( 
     .     MAX(-1.D0,MIN(0.5D0*(D2IJ+D2JK-D2IK)/SQRT(D2IJ*D2JK),1.D0)) ) 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DIHED(XYZ,I,J,K,L,ANGLE) 
      IMPLICIT REAL (A-H,O-Z) 
      DIMENSION XYZ(3,*) 
********************************************************************* 
* 
*      DIHED CALCULATES THE DIHEDRAL ANGLE BETWEEN ATOMS I, J, K, 
*            AND L.  THE CARTESIAN COORDINATES OF THESE ATOMS 
*            ARE IN ARRAY XYZ. 
* 
*     DIHED IS A MODIFIED VERSION OF A SUBROUTINE OF THE SAME NAME 
*           WHICH WAS WRITTEN BY DR. W. THEIL IN 1973. 
*           (USE CLOCKWISE CONVENTION) 
********************************************************************* 
      SAVE
      XI1=XYZ(1,I)-XYZ(1,K) 
      XJ1=XYZ(1,J)-XYZ(1,K) 
      XL1=XYZ(1,L)-XYZ(1,K) 
      YI1=XYZ(2,I)-XYZ(2,K) 
      YJ1=XYZ(2,J)-XYZ(2,K) 
      YL1=XYZ(2,L)-XYZ(2,K) 
      ZI1=XYZ(3,I)-XYZ(3,K) 
      ZJ1=XYZ(3,J)-XYZ(3,K) 
      ZL1=XYZ(3,L)-XYZ(3,K) 
C     ROTATE AROUND Z AXIS TO PUT KJ ALONG Y AXIS 
      DIST= SQRT(XJ1**2+YJ1**2+ZJ1**2) 
      IF(DIST.LT.1.D-30) THEN 
         ANGLE=0.D0 
         RETURN 
      ENDIF 
      COSA=MAX(-1.D0,MIN(ZJ1/DIST,1.D0)) 
      IF (1.D0-ABS(COSA).LT.1.D-30) THEN 
         XI2=XI1 
         XL2=XL1 
         YI2=YI1 
         YL2=YL1 
         COSTH=COSA 
         SINTH=0.D0 
      ELSE 
         YXDIST=DIST*SQRT(1.D0-COSA**2) 
         COSPH=YJ1/YXDIST 
         SINPH=XJ1/YXDIST 
         XI2=XI1*COSPH-YI1*SINPH 
         XJ2=XJ1*COSPH-YJ1*SINPH 
         XL2=XL1*COSPH-YL1*SINPH 
         YI2=XI1*SINPH+YI1*COSPH 
         YJ2=XJ1*SINPH+YJ1*COSPH 
         YL2=XL1*SINPH+YL1*COSPH 
         COSTH=COSA 
         SINTH=YJ2/DIST 
      ENDIF 
C     ROTATE KJ AROUND THE X AXIS SO KJ LIES ALONG THE Z AXIS 
      YI3=YI2*COSTH-ZI1*SINTH 
      YL3=YL2*COSTH-ZL1*SINTH 
      CALL DANG(XL2,YL3,XI2,YI3,ANGLE) 
      RETURN 
      END 
      SUBROUTINE DANG(A1,A2,B1,B2,RCOS) 
      IMPLICIT REAL (A-H,O-Z) 
********************************************************************** 
* 
*    DANG  DETERMINES THE ANGLE BETWEEN THE POINTS (A1,A2), (0,0), 
*          AND (B1,B2).  THE RESULT IS PUT IN RCOS, BETWEEN -PI AND PI. 
*          USE TRIGONOMETRIC CONVENTION. 
* 
********************************************************************** 
      SAVE
      ANORM=SQRT(A1**2+A2**2) 
      BNORM=SQRT(B1**2+B2**2) 
      IF(ANORM.LT.1.D-30 .OR. BNORM.LT.1.D-30) THEN 
         RCOS=0.D0 
         ELSE 
         RCOS=ACOS(MAX(-1.D0,MIN((A1*B1+A2*B2)/(ANORM*BNORM),1.D0)) ) 
         IF(A1*B2.LT.A2*B1) RCOS=-RCOS 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE ZPE 
      IMPLICIT REAL(A-H,O-Z) 
       INCLUDE "SIZES"
C     -THE HESSIAN MATRIX ISSUED FROM 'LTRD' IN INTERNAL COORDINATES 
C      IS BACK TRANSFORMED IN CARTESIAN COORDINATES, WITHOUT 
C      TAKING INTO ACCOUNT THE RESIDUAL VALUES OF THE GRADIENT, 
C      THUS AVOIDING FIRST ORDER ARTEFACT INHERENT TO DIRECT COMPUTATION 
C      OF THE HESSIAN IN THE CARTESIAN SPACE. 
C     -THE TRANSFORMATION MATRIX IS WORKED OUT BY ROUTINE 'JINCAR'. 
C     -INPUT AND OUTPUT HESSIAN IN THE SAME STORAGE H IN /OPTIM/. 
C     -DIAGONALIZE THE WEIGHTED FORCE CONSTANT ENERGY, 
C      AND PROVIDE VIBRATIONAL FREQUENCIES AND ZPE CONTRIBUTION. 
C      D.L. (MJS DEWAR GROUP) JUNE 1986 
C 
      COMMON /OPTIM / IMP,IMP0,LEC,IPRT,H(MAXHES),FREQ(MAXPAR) 
     .               ,T(MAXPAR,MAXPAR),COORD(3,NUMATM) 
     .               ,WTMASS(MAXPAR) 
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),NA(NUMATM),NB(NUMATM) 
     .               ,NC(NUMATM) 
      COMMON /ATMASS/ ATMASS(NUMATM) 
      COMMON /GEOM  / GEO(3,NUMATM) 
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR) 
      COMMON /KEYWRD/ KEYWRD 
      DIMENSION HT(MAXPAR,MAXPAR) 
      LOGICAL FAIL 
      CHARACTER KEYWRD*80 
      EQUIVALENCE (HT(1,1),COORD(1,1)) 
      SAVE
C     CONVERSION IN MILLIDYNES/ANGSTR 'FACT'*0.5 
      DATA FACT /3.475625D-3/ 
C     AVOGADRO NUMBER 'AVOGA' 
      DATA AVOGA /6.022045D23/ 
C     PLANCK'S CONSTANT 'PLANCK' (JHZ) 
      DATA PLANCK /6.626176D-34/ 
C     SPEED OF LIGHT 'CSPEED' (CM/SEC) 
      DATA CSPEED /2.99792458D10/ 
C     CONVERSION FACTOR FOR SPEED OF LIGHT AND 2 PI 'C2PI' 
      C2PI=1.D0/(2.99792458D10*3.141592653598D0*2.D0) 
C     CONVERSION FACTOR FOR ZERO POINT ENERGY 
      FACT2=0.5D0*(AVOGA*PLANCK)*CSPEED/4.184D3 
C     ............... 
C     GET THE CARTESIAN (COORD) FROM THE INTERNAL (GEO),DUMMIES        INCLUDED 
      CALL INTCAR (GEO,COORD) 
C     BUILT THE JACOBIAN T(NVAR,NCART);T(I,J)=dINTERNAL(I)/dCARTESIAN(J) 
C     NVAR IS THE NUMBER OF INTERNAL VARIABLES, NCART=3*(NATOMS-DUMMY) 
      CALL JINCAR (COORD,T,NCART,FAIL) 
      IF (FAIL) THEN 
         WRITE(IPRT,150) 
         RETURN 
         ELSE IF(IMP.GT.4) THEN 
C        PRINTOUT THE JACOBIAN 
         WRITE(IPRT,130) 
         DO 10 I=1,NVAR 
   10    WRITE(IPRT,140) I,(T(I,J),J=1,NCART) 
      ENDIF 
C     BACK-TRANSFORM 
      DO 20 J=1,NCART 
   20 CALL SUPDOT(HT(1,J),H,T(1,J),NVAR,1) 
      K=0 
      DO 30 I=1,NCART 
      DO 30 J=1,I 
      K=K+1 
   30 H(K)=FACT*DOT(T(1,I),HT(1,J),NVAR) 
      IF(IMP.GT.3) THEN 
C        PRINTOUT THE FORCE MATRIX IN MILLIDYNES/ANGSTROM 
         WRITE(IPRT,100) 
         I=-NCART 
         CALL VECPRT(H,I) 
      ENDIF 
C     FIND CONVERSION CONSTANTS FOR MASS WEIGHTED SYSTEM 
      NUMAT=NCART/3 
      SQR2=SQRT(2.D0) 
      L=0 
      DO 40 I=1,NUMAT 
      WEIGHT=SQR2/SQRT(ATMASS(I)) 
      DO 40 J=1,3 
      L=L+1 
   40 WTMASS(L)=WEIGHT 
C     CONVERT 0.5*HESSIAN TO MASS WEIGHTED FORCE MATRIX 
      L=0 
      DO 50 I=1,NCART 
      IJ=I-NCART 
      DO 50 J=1,I 
      L=L+1 
      IJ=IJ+NCART 
   50 T(IJ,1)=H(L)*WTMASS(I)*WTMASS(J) 
C     DIAGONALIZE 
      CALL DIAGIV(T,NCART,NCART,FREQ,EPS1) 
C     SWITCH EIGENVALUES TO FREQUENCIES IN WAVE NUMBER 
      FACT3=SQRT(1.D5*AVOGA)*C2PI 
      EPS1=EPS1*FACT3 +1.D0 
      ZPEC=0.D0 
      MODE=0 
      DO 60 I=1,NCART 
      FREQ(I)=FACT3*SIGN(SQRT(ABS(FREQ(I))),FREQ(I)) 
      IF(FREQ(I).GT.EPS1) THEN 
         ZPEC=ZPEC+FREQ(I) 
         MODE=MODE+1 
      ENDIF 
   60 CONTINUE 
      WRITE(IPRT,110) (FREQ(I),I=1,NCART) 
      WRITE(IPRT,120)NVAR,MODE,ZPEC*FACT2 
C 
      RETURN 
  100 FORMAT(' FULL FORCE CONSTANT MATRIX IN CARTESIAN SPACE ', 
     .' (MILLIDYNES/ANGSTROM)') 
  110 FORMAT(' VIBRATIONAL FREQUENCIES (WAVE NUMBER)'/(10F8.1)) 
  120 FORMAT(' THE',I3,'-DIMENSIONAL HESSIAN EXHIBITS',I3,' VIBRATIONS', 
     .' CONTRIBUTING BY'/F10.2,' KCAL/MOLE TO THE ZERO POINT ENERGY') 
  130 FORMAT(/' JACOBIAN MATRIX dinternal(i)/dcartesian(j)'/ 
     .'      X1     Y1     Z1     X2     Y2     Z2     X3  ...') 
  140 FORMAT(I3,11F7.3/(3X,11F7.3)) 
  150 FORMAT(' *** AN OPTIMIZED INTERNAL COORDINATE USES A DUMMY ATOM ** 
     .*'/' ==> NO CALCULATIONS OF THE VIBRATIONAL FREQUENCIES ...'/ 
     .'     REMOVE THE DUMMIES ATOMS OR INVOKE ''FORCE''. SORRY') 
      END 
      SUBROUTINE JINCAR (COORD,T,NCART,FAIL) 
      IMPLICIT REAL(A-H,O-Z) 
C     BUILD THE JACOBIAN MATRIX T(I,J)=dinternal(i)/dcartesian(j) 
C     INTERNAL (ROW) ARE ORDERED AS PROVIDED BY THE INPUT DATA: 
C            ATOM 1     RHO(1)   THETA(2)    PHI(3) 
C            ATOM 2     RHO(4)   THETA(5)    PHI(6) AND SO ON 
C     CARTESIAN (COLUMN) ARE ORDERED AS FOLLOWS: 
C            ATOM 1      X (1)      Y (2)     Z (3) 
C            ATOM 2      X (4)      Y (5)     X (6) AND SO ON 
C     DUMMY ATOMS ARE ACCEPTED IF NOT ENGAGED IN THE DEFINITION OF A 
C     OPTIMIZED INTERNAL COORDINATE. 
C     THE JACOBIAN IS WORKED OUT ANALYTICALLY WITH RESPECT TO THE 
C     SPHERICAL COORDINATES IN THE LOCAL FRAME SPANNED BY NA,NB,NC 
C                             BUT 
C     ONE USES A TWO-POINT FINITE DIFFERENCE METHOD TO GET THE 
C     DERIVATIVES OF THE LOCAL FRAME WITH RESPECT TO THE CARTESIAN OF 
C     NA,NB,NC. 
C     SUCH A MIXED STRATEGY INSURES THE CONTINUITY FOR EITHER 
C     AN ANGLE THETA=0,180 OR A DIHEDRAL PHI=180,-180 
C     AND PROVIDES A GOOD ACCURACY WITH RESPECT TO THE HESSIAN ERROR. 
C     D.L. (MJS DEWAR GROUP) JUNE 1986 
C 
       INCLUDE "SIZES"
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),NA(NUMATM),NB(NUMATM) 
     .               ,NC(NUMATM) 
     .       /GEOM  / GEO(3,NUMATM) 
     .       /GEOVAR/ NVAR,LOC(2,MAXPAR) 
     .       /KEYWRD/ KEYWRD 
     .       /SCRACH/ R(3,3),R1(3,3),R2(3,3),SJ(3,3),XD(3),SJR(3,3) 
     .               ,FILA(3,3),FILB(3,3),LOCXYZ(NUMATM) 
      DIMENSION COORD(3,*),T(MAXPAR,MAXPAR),SP(3,9) 
      EQUIVALENCE (SP(1,1),R(1,1)) 
      CHARACTER KEYWRD*80 
      LOGICAL FLAGA,FLAGB,FAIL 
      SAVE
C 
C     STEP SIZE 'STEP' FOR FINITE DIFFERENCE IN CARTESIAN SPACE. 
      DATA STEP /1.D-6/ 
      STEP2=2.0D0*STEP 
C 
C     COLUMN (I.E. THE CARTESIANS) COUNTER, REMOVING DUMMY ATOMS 
      NCART=0 
      DO 1 I=1,NATOMS 
      IF (LABELS(I).GE.99) GO TO 1 
      LOCXYZ(I)=NCART 
      NCART=NCART+3 
    1 CONTINUE 
      FAIL=.FALSE. 
C 
C     ANALYTICAL EXPRESSIONS FOR FIRST ATOMS 
      NVAR1=1 
      IF (LOC(1,1).EQ.2) THEN 
C        BOND LENGTH 1-2 
         DO 10  I=1,9 
   10    SP(1,I)= 0.D0 
         SP(1,1)=-1.D0 
         SP(1,4)= 1.D0 
         NVAR1=NVAR1+1 
      ENDIF 
      IF (LOC(1,NVAR1).EQ.3) THEN 
         RHO   =GEO(1,3) 
         THETA =GEO(2,3) 
         SINT=SIN(THETA) 
         COST=COS(THETA) 
         IF (LOC(2,NVAR1).EQ.1) THEN 
C           BOND LENGTH 2-3 
            DO 11 I=1,9 
   11       SP(NVAR1,I)=0.D0 
            SP(NVAR1,4)= COST 
            SP(NVAR1,5)=-SINT 
            SP(NVAR1,7)=-COST 
            SP(NVAR1,8)= SINT 
            NVAR1=NVAR1+1 
         ENDIF 
      ENDIF 
      IF (LOC(1,NVAR1).EQ.3) THEN 
C        ANGLE 3-2-1 
         DO 12 I=1,9 
   12    SP(NVAR1,I)=0.D0 
         SP(NVAR1,2)=-1.D0/GEO(1,2) 
         SP(NVAR1,4)=-SINT/RHO 
         SP(NVAR1,7)=-SP(NVAR1,4) 
         SP(NVAR1,8)= COST/RHO 
         SP(NVAR1,5)=-SP(NVAR1,2)-SP(NVAR1,8) 
      ENDIF 
      IF (NVAR1.GT.1) THEN 
C        FILL FIRST ROWS OF THE JACOBIAN T 
         K=0 
         IF(LABELS(1).LT.99) THEN 
            DO 13 J=1,3 
            K=K+1 
            DO 13 I=1,NVAR1 
   13       T(I,K)=SP(I,J) 
         ENDIF 
         IF(LABELS(2).LT.99) THEN 
            DO 14 J=4,6 
            K=K+1 
            DO 14 I=1,NVAR1 
   14       T(I,K)=SP(I,J) 
         ENDIF 
         IF(LABELS(3).LT.99) THEN 
            DO 15 J=7,9 
            K=K+1 
            DO 15 I=1,NVAR1 
   15       T(I,K)=SP(I,J) 
         ENDIF 
         IF (NCART.EQ.K) RETURN 
         K=K+1 
         DO 16 I=1,NVAR1 
         DO 16 J=K,NCART 
   16    T(I,J)=0.D0 
         IF (NVAR1.EQ.NVAR) RETURN 
         NVAR1=NVAR1+1 
      ENDIF 
C 
C     MAIN LOOP ON THE ROW (I.E. THE INTERNAL VARIABLES) 
      NNOLD=0 
      DO 100 N=NVAR1,NVAR 
      NND=LOC(1,N) 
      NTYP=LOC(2,N) 
      IF (NND.NE.NNOLD) THEN 
         NNA=NA(NND) 
         NNB=NB(NND) 
         NNC=NC(NND) 
         NNOLD=NND 
C        FIND THE LOCAL FRAME: R 
         CALL RLOCAL (COORD,NNA,NNB,NNC,R) 
C        SPHERICAL COORDINATES OF D IN THE LOCAL FRAME 
         RHO  =GEO(1,NND) 
         THETA=GEO(2,NND) 
         PHI  =GEO(3,NND) 
         SINT=SIN(THETA) 
         COST=COS(THETA) 
         SINP=SIN(PHI) 
         COSP=COS(PHI) 
C        CARTESIAN COORDINATES OF D IN THE LOCAL FRAME: XD 
         W=RHO*SINT 
         XD(1)=W*COSP 
         XD(2)=W*SINP 
         XD(3)=RHO*COST 
C        JACOBIAN D(SPHERICAL)/D( LOCAL CARTESIAN): SJ 
         SJ(1,1)=SINT*COSP 
         SJ(1,2)=SINT*SINP 
         SJ(1,3)=COST 
         W=COST/RHO 
         SJ(2,1)=W*COSP 
         SJ(2,2)=W*SINP 
         SJ(2,3)=-SINT/RHO 
         IF(ABS(SINT).LT.1.D-30) THEN 
C           (SHOULD NEVER BE USED) 
            SJ(3,1)=0.D0 
            SJ(3,2)=0.D0 
         ELSE 
            W=1.D0/(RHO*SINT) 
            SJ(3,1)=-W*SINP 
            SJ(3,2)= W*COSP 
         ENDIF 
         SJ(3,3)=0.D0 
C        PRODUCT (SJR) = (SJ) * (R)' 
         DO 21 I=1,3 
         DO 21 J=1,3 
         W=0.D0 
         DO 20 K=1,3 
   20    W=W+SJ(I,K)*R(J,K) 
   21    SJR(I,J)=W 
         FLAGA=.FALSE. 
         FLAGB=.FALSE. 
      ENDIF 
C     FILL THE NON ZERO ELEMENTS OF THE ROW NUMBER N ... 
      DO 30 I=1,NCART 
   30 T(N,I)=0.D0 
C     ... DUE TO THE CARTESIAN OF ATOM D 
      IF(LABELS(NND).GE.99) THEN 
         FAIL=.TRUE. 
         RETURN 
      ENDIF 
      DO 40 I=1,3 
   40 T(N,LOCXYZ(NND)+I)=SJR(NTYP,I) 
C     ... DUE TO THE CARTESIAN OF ATOM A 
      IF(LABELS(NNA).GE.99) THEN 
         FAIL=.TRUE. 
         RETURN 
      ENDIF 
      DO 58 I=1,3 
C     BECAUSE OF TRANSLATION: 
      T(N,LOCXYZ(NNA)+I)=-SJR(NTYP,I) 
C     BECAUSE OF ROTATION (CENTRAL DIFFERENCES ON EULERIAN ANGLES): 
      IF(FLAGA) GO TO 58 
      COORD(I,NNA)=COORD(I,NNA)+STEP 
      CALL RLOCAL(COORD,NNA,NNB,NNC,R1) 
      COORD(I,NNA)=COORD(I,NNA)-STEP2 
      CALL RLOCAL(COORD,NNA,NNB,NNC,R2) 
      COORD(I,NNA)=COORD(I,NNA)+STEP 
      DO 50 J=1,9 
   50 R2(J,1)=(R1(J,1)-R2(J,1))/STEP2 
      DO 52 J=1,3 
      DO 52 K=1,3 
      W=0.D0 
      DO 51 L=1,3 
   51 W=W+SJR(J,L)*R2(L,K) 
   52 R1(J,K)=W 
      DO 54 J=1,3 
      W=0.D0 
      DO 53 K=1,3 
   53 W=W+R1(J,K)*XD(K) 
   54 FILA(J,I)=W 
   58 T(N,LOCXYZ(NNA)+I)=T(N,LOCXYZ(NNA)+I)-FILA(NTYP,I) 
      FLAGA=.TRUE. 
      IF(NTYP.NE.1) THEN 
C        ... DUE TO THE CARTESIAN OF ATOM B 
         IF(LABELS(NNB).GE.99) THEN 
            FAIL=.TRUE. 
            RETURN 
         ENDIF 
         DO 68 I=1,3 
C        BECAUSE OF ROTATION (CENTRAL DIFFERENCES ON EULERIAN ANGLES): 
         IF(FLAGB) GO TO 68 
         COORD(I,NNB)=COORD(I,NNB)+STEP 
         CALL RLOCAL(COORD,NNA,NNB,NNC,R1) 
         COORD(I,NNB)=COORD(I,NNB)-STEP2 
         CALL RLOCAL(COORD,NNA,NNB,NNC,R2) 
         COORD(I,NNB)=COORD(I,NNB)+STEP 
         DO 60 J=1,9 
   60    R2(J,1)=(R1(J,1)-R2(J,1))/STEP2 
         DO 62 J=2,3 
         DO 62 K=1,3 
         W=0.D0 
         DO 61 L=1,3 
   61    W=W+SJR(J,L)*R2(L,K) 
   62    R1(J,K)=W 
         DO 64 J=2,3 
         W=0.D0 
         DO 63 K=1,3 
   63    W=W+R1(J,K)*XD(K) 
   64    FILB(J,I)=W 
   68    T(N,LOCXYZ(NNB)+I)=-FILB(NTYP,I) 
         FLAGB=.TRUE. 
      ENDIF 
      IF(NTYP.EQ.3) THEN 
C        ... DUE TO THE CARTESIAN OF ATOM C 
         IF(LABELS(NNC).GE.99) THEN 
            FAIL=.TRUE. 
            RETURN 
         ENDIF 
         DO 78 I=1,3 
C        BECAUSE OF ROTATION (CENTRAL DIFFERENCES ON EULERIAN ANGLES): 
         COORD(I,NNC)=COORD(I,NNC)+STEP 
         CALL RLOCAL(COORD,NNA,NNB,NNC,R1) 
         COORD(I,NNC)=COORD(I,NNC)-STEP2 
         CALL RLOCAL(COORD,NNA,NNB,NNC,R2) 
         COORD(I,NNC)=COORD(I,NNC)+STEP 
         DO 70 J=1,9 
   70    R2(J,1)=(R1(J,1)-R2(J,1))/STEP2 
         DO 72 K=1,3 
         W=0.D0 
         DO 71 L=1,3 
   71    W=W+SJR(3,L)*R2(L,K) 
   72    R1(3,K)=W 
         W=0.D0 
         DO 73 K=1,3 
   73    W=W+R1(3,K)*XD(K) 
   78    T(N,LOCXYZ(NNC)+I)=-W 
      ENDIF 
  100 CONTINUE 
      RETURN 
      END 
      SUBROUTINE RLOCAL (COORD,NA,NB,NC,R) 
      IMPLICIT REAL (A-H,O-Z) 
C     RLOCAL PROVIDES IN R (COLUMNWISE) THE LEFT-HANDED ORTHONORMALIZED 
C     'LOCAL' FRAME SPANNED BY THE ATOMS NA,NB,NC ACCORDING TO: 
C     NA       IS THE ORIGIN OF THE LOCAL FRAME 
C     NA-NB->  IS THE POSITIVE Z AXIS 
C     NC       LIES IN THE XZ PLANE WITH X POSITIVE 
C     THESE CONVENTIONS AGREE WITH THOSE ADOPTED IN BOTH 
C                            'XYZINT' AND 'INTCAR' ROUTINES. 
C     D.L.  (MJS DEWAR GROUP) JUNE 1986 
      DIMENSION COORD(3,*),R(3,3) 
      SAVE
C 
C..... THE FOLLOWING INSTRUCTIONS ARE USELESS IF 'RLOCAL' IS NOT CALLED 
C                                      FOR THE FIRST 3 ATOMS. 
CC     SPECIAL CASES FOR FIRST ATOMS 
C      IF(NA.EQ.0.OR.NB.EQ.0) THEN 
C         DO 1 I=1,9 
C    1    R(I,1)= 0.D0 
C         R(2,1)= 1.D0 
C         R(3,2)=-1.D0 
C         R(1,3)= 1.D0 
C         RETURN 
C      ENDIF 
C      IF(NC.EQ.0) THEN 
C         DO 2 I=1,9 
C    2    R(I,1)= 0.D0 
C         R(2,1)= 1.D0 
C         R(3,2)= 1.D0 
C         R(1,3)=-1.D0 
C         RETURN 
C      ENDIF 
C........... 
C     GENERAL CASE 
      DO 10 I=1,3 
      R(I,3)=COORD(I,NB)-COORD(I,NA) 
   10 R(I,1)=COORD(I,NC)-COORD(I,NB) 
      W=SQRT(DOT(R(1,3),R(1,3),3)) 
C     NORMALIZED Z DIRECTION R(I,3) 
      DO 20 I=1,3 
   20 R(I,3)=R(I,3)/W 
      W=DOT(R,R(1,3),3) 
      DO 30 I=1,3 
   30 R(I,1)=R(I,1)-W*R(I,3) 
      W=SQRT(DOT(R,R,3)) 
C     NORMALIZED X DIRECTION R(I,1) 
      DO 40 I=1,3 
   40 R(I,1)=R(I,1)/W 
C     NORMALIZED LEFT-HANDED Y DIRECTION R(I,2) 
      R(1,2)=R(2,1)*R(3,3)-R(3,1)*R(2,3) 
      R(2,2)=R(3,1)*R(1,3)-R(1,1)*R(3,3) 
      R(3,2)=R(1,1)*R(2,3)-R(2,1)*R(1,3) 
      RETURN 
      END 
CCCCCCCCCCC   MATPAK:  MATHEMATICAL PACKAGE     CCCCCCCCCCCCCCCCCCCCCCC 
CCCCCCC    THESE ROUTINE ARE FULLY VECTORIZED ON CRAY-1          CCCCCC 
CCCCCCC    THEY ARE ROUGHLY RESPONSIBLE OF 90% OF THE CPU TIME   CCCCCC 
CCCCCCC    USE $SCILIB, $EIGPACK, $LINPACK LIBRARIES             CCCCCC 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
      FUNCTION DOT(X,Y,N) 
      IMPLICIT REAL(A-H,O-Z) 
      DIMENSION X(*), Y(*) 
C     DOT =    DOT PRODUCT OF X AND Y, LENGHT N. 
C     CRAY VERSION 
      DOT=SDOT(N,X,1,Y,1) 
      RETURN 
      END 
      SUBROUTINE MXMT (A,NAR,B,NBR,C,NCC) 
      IMPLICIT REAL(A-H,O-Z) 
C     MATRIX PRODUCT C(NAR,NCC) = A(NAR,NBR) * (B(NCC,NBR))' 
C     ALL MATRICES RECTANGULAR , PACKED. 
C NOTE ... OPTIMUM VERSION ON CRAY-1. 
      DIMENSION A(NAR,NBR),B(NCC,NBR),C(NAR,NCC) 
      DO 10 I=1,NCC*NAR 
   10 C(I,1)=0.D0 
      DO 20 K=1,NBR 
      DO 20 J=1,NCC 
      DO 20 I=1,NAR 
   20 C(I,J)=C(I,J)+A(I,K)*B(J,K) 
      RETURN 
      END 
      SUBROUTINE MTXM (A,NAR,B,NBR,C,NCC) 
      IMPLICIT REAL(A-H,O-Z) 
C     MATRIX PRODUCT C(NAR,NCC) = (A(NBR,NAR))' * B(NBR,NCC) 
C     ALL MATRICES RECTANGULAR , PACKED. 
C  NOTE ... BEST VERSION ON CRAY-1: 1.4 HAS BEEN EMPIRICALLY ADJUSTED. 
      DIMENSION A(NBR,NAR),B(NBR,NCC),C(NAR,NCC) 
      DO 10 I=1,NCC*NAR 
   10 C(I,1)=0.D0 
      IF (FLOAT(NBR).LT.1.4D0*FLOAT(NAR+NCC)) THEN 
         DO 20 K=1,NBR 
         DO 20 J=1,NCC 
         DO 20 I=1,NAR 
   20    C(I,J)=C(I,J)+A(K,I)*B(K,J) 
      ELSE 
         DO 30 I=1,NAR 
         DO 30 J=1,NCC 
         DO 30 K=1,NBR 
   30    C(I,J)=C(I,J)+A(K,I)*B(K,J) 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE MTXMC (A,NAR,B,NBR,C) 
      IMPLICIT REAL(A-H,O-Z) 
C     MATRIX PRODUCT C(NAR,NAR) = (A(NBR,NAR))' * B(NBR,NAR) 
C     A AND B RECTANGULAR , PACKED, 
C     C LOWER LEFT TRIANGLE ONLY, PACKED IN CANONICAL ORDER. 
      DIMENSION A(NBR,NAR),B(NBR,NAR),C(*) 
C  NOTE ... OPTIMUM VERSION ON CRAY-1. 
      L=1 
      DO 10 I=1,NAR 
      CALL MXM (A(1,I),1,B,NBR,C(L),I) 
   10 L=L+I 
      RETURN 
      END 
      SUBROUTINE SUPDOT(S,H,G,N,IG) 
      IMPLICIT REAL (A-H,O-Z) 
C     (S)=(H)*(G) WITH  H  IN PACKED FORM (CANONICAL ORDER). 
C     IG IS THE INCREMENT FOR THE VECTOR G. 
      DIMENSION S(*),H(*),G(*) 
C     CRAY-1 VERSION... BUT POORLY VECTORIZED. 
      K=1 
      L=1 
      DO 10 I=1,N 
      S(I)=SDOT(I,H(K),1,G,IG,I) 
      IF(I.GT.1) THEN 
         L=L+IG 
         CALL SAXPY(I-1,G(L),H(K),1,S,1) 
      ENDIF 
   10 K=K+I 
      RETURN 
      END 
      SUBROUTINE HQRII(A,N,M,E,V) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
************************************************************* 
* 
* HQRII IS A DIAGONALISATION ROUTINE OPTIMALLY WRITTEN FOR CRAY-1. 
* 
* ON INPUT    A       = MATRIX TO BE DIAGONALISED (PACKED CANONICAL) 
*             N       = SIZE OF MATRIX TO BE DIAGONALISED. 
*             M       = NUMBER OF EIGENVECTORS NEEDED. 
*             E       = ARRAY OF SIZE AT LEAST N 
*             V       = ARRAY OF SIZE AT LEAST NMAX*M 
* 
* ON OUTPUT   E       = EIGENVALUES 
*             V       = EIGENVECTORS IN ARRAY OF SIZE NMAX*M 
* 
************************************************************************ 
      COMMON /SCRACH/ FV1(MORB2),FV2(MORB2),B(MORB2) 
      DIMENSION A(*), E(*), V(N,M) 
C     USE EIGPACK LIBRARY: EITHER 'RS' OR 'RSP' ROUTINE. 
C     RS BEING SIGNIFICANTLY FASTER THAN RSP, FIRST EXPAND A (CANONICAL) 
C     IN B (BIDIM.) AND THEN CALL RS. 
      SAVE
      K=0 
      DO 10 I=1,N 
      IJ=I 
CDIR$ IVDEP 
      DO 10 JI=N*(I-1)+1,N*(I-1)+I 
      K=K+1 
      B(IJ)=A(K) 
      B(JI)=A(K) 
   10 IJ=IJ+N 
      CALL RS (N,N,B,E,1,V,FV1,FV2,IERR) 
      IF (IERR.NE.0) THEN 
         WRITE (6,100) IERR 
  100    FORMAT(' WARNING : ERROR CODE',I4,'  RETURNED FROM RS CALLED ', 
     .          'BY HQRII') 
      ENDIF 
      RETURN 
      END 
      SUBROUTINE DIAGIV(A,N,MM,VALU,EPS1) 
      IMPLICIT REAL (A-H,O-Z) 
       INCLUDE "SIZES"
      COMMON /SCRACH/ FV1(MAXPAR**2),FV2(MAXPAR**2),Z(MAXPAR**2) 
      DIMENSION A(N,N),VALU(1),KPVT(1),INERT(3),DET(2) 
      EQUIVALENCE (FV2(1),KPVT(1)),(FV2(MAXPAR+1),INERT(1)) 
     .           ,(FV2(MAXPAR+4),DET(1)) 
      SAVE
C     CRAY-ONE VERSION NOVEMBER 1983 - LABO CHIMIE STRUCTURALE PAU. 
C     USE VARIOUS ROUTINES OF LINPACK AND EIGPACK LIBRARIES. 
C 
C     DIAGONALISATION PROCEDURE   GIVENS HOUSEHOLDER METHOD 
C      ---------------------------------------------------- 
C      SYMMETRIC REAL MATRIX A IS DESTROYED AND GIVES EIGENVECTORS 
C     (IN COLUMN) 
C     VALU    EIGENVALUES IN ASCENDING ORDER 
C     N       ORDER OF MATRIX A 
C     MM      NUMBER OF EIGENVALUES TO BE EVALUATED 
C     EPS1    ABSOLUTE ERROR OF ALL CALCULATED EIGENVALUES 
      IROUTE=3 
      M=MM 
      GO TO 2000 
C 
C 
C 
      ENTRY VALUE (A,N,MM,VALU,EPS1) 
C 
C     EIGENVALUES AND EIGENVECTORS LOCAL ANALYSIS 
C     ----------------------------------------------------- 
C      SYMMETRIC REAL MATRIX A IS DESTROYED AND GIVES EIGENVECTORS 
C     (IN COLUMN) 
C     VALU    EIGENVALUES IN ASCENDING ORDER 
C     N       ORDER OF MATRIX A 
C     MM      POSITION OF THE FIRST STRICTLY POSITIVE EIGENVALUE 
C             AND NUMBER OF EVALUATED EIGENVALUES 
C     EPS1    ABSOLUTE ERROR OF ALL CALCULATED EIGENVALUES 
      M=N 
      IROUTE=2 
      GO TO 2000 
C 
C 
C 
      ENTRY INVRT0(A,N,MM,VALU,EPS1) 
C 
C     INVERSION PROCEDURE DIAGONALIZATION METHOD 
C     ----------------------------------------------------- 
C     SYMMETRIC REAL MATRIX A IS INVERTED IN AREA A 
C     VALU    EIGENVALUES IN ASCENDING ORDER 
C     N       ORDER OF MATRIX A 
C     EPS1    ABSOLUTE ERROR OF ALL CALCULATED EIGENVALUES 
C 
      IROUTE=1 
      M=N 
      GO TO 2000 
C 
C 
C 
      ENTRY INVERT(A,N,MM,VALU,EPS1) 
C 
C     INVERSION PROCEDURE TRIANGULARIZATION METHOD 
C     -------------------------------------------- 
C     SYMMETRIC REAL MATRIX A IS INVERTED IN AREA A 
C     VALU PIVOT VECTOR 
C     N    ORDER OF MATRIX A 
C     MM   NUMBER OF NEGATIVE EIGENVALUES (INDEX) 
C     EPS1 NOT USED 
C 
      IROUTE=4 
      M=N 
 2000 CONTINUE 
C     RELATIVE THRESHOLD OF CONVERGENCE 
      E1=1.D-12 
      IF(M.GT.N) M=N 
      IF(N.NE.1) GO TO 4 
      GO TO (1,2,3),IROUTE 
    1 VALU(1)=A(1,1) 
      EPS1=0.D0 
      MM=0 
      IF(VALU(1).LT.0.D0) MM=1 
      IF(VALU(1).EQ.0.D0) A(1,1)=E1 
      A(1,1)=1.D0/A(1,1) 
      RETURN 
    2 MM=1 
      IF(A(1,1).LE.0.D0) MM=2 
    3 VALU(1)=A(1,1) 
      EPS1=0.D0 
      A(1,1)=1.D0 
      RETURN 
    4 IF(IROUTE.EQ.4) GO TO 700 
    5 CALL RS (N,N,A,VALU,M,Z,FV1,FV2,IERR) 
      IF (IERR.NE.0) WRITE (6,100) IERR 
  100 FORMAT(' WARNING : COMPLETION CODE FROM RS IN DIAGIV =',I5) 
      EPS1=E1*MAX(ABS(VALU(1)),ABS(VALU(N))) 
 1000 GO TO (601,625,630),IROUTE 
C     INVERT MATRIX A IN THE SAME AREA A 
C     ------------------------------------- 
      ENTRY INVRT1 (A,N,VALU,EPS1) 
  601 DO 602 I=1,N 
  602 VALU(I)=SIGN(MAX(EPS1,ABS(VALU(I))),VALU(I)) 
      K=1 
      N1=N*(N-1) 
      DO 10 I=1,N 
      L=I+N1 
      DO 10 J=I,L,N 
      FV1(J)=Z(K)/VALU(I) 
   10 K=K+1 
      CALL MXM (Z,N,FV1,N,A,N) 
      RETURN 
  625 MM=1+ILSUM(N,VALU,1) 
      M=MIN0(N,MM) 
  630 M=M*N 
      DO 20 I=1,M 
   20 A(I,1)=Z(I) 
      RETURN 
C     DIRECT INVERSION SECTION 
  700 J=1 
      DO 701 I=1,N 
      VALU(I)=A(J,1) 
  701 J=J+N+1 
      CALL SSIFA(A,N,N,KPVT,I) 
      IF(I.EQ.0) GO TO 703 
      J=1 
      DO 702 I=1,N 
      A(J,1)=VALU(I) 
  702 J=J+N+1 
      IROUTE=1 
      GO TO 5 
  703 CALL SSIDI(A,N,N,KPVT,DET,INERT,Z,101) 
      MM=INERT(2) 
      DO 704 I=2,N 
      M=I-1 
CDIR$ IVDEP 
      DO 704 J=1,M 
  704 A(I,J)=A(J,I) 
      RETURN 
      END 
      SUBROUTINE OSINV (A,N,D) 
      IMPLICIT REAL (A-H,O-Z) 
C     INVERT THE SYMMETRIC MATRIX SQUARE MATRIX A 
C   INPUT 
C     A : THE MATRIX TO BE INVERTED , PACKED 
C     N : THE DIMENSION 
C   OUTPUT 
C     A : THE INVERSE OF THE ORIGINAL A MATRIX 
C     N : NOT MODIFIED 
C     D = 0 IF ONE PIVOT IS LOWER THAN DLIMIT ; 1. OTHERWISE 
C 
C     CRAY-1 VERSION USING LINPACK LIBRARY 
C 
      DIMENSION A(N,N),B(60),C(60),LZ(60) 
      DATA DLIMIT /1.D-15/ 
      SAVE
      IF (N.GT.60) THEN 
         WRITE(IPRT,'('' A CALL TO OSINV WITH N='',I3, 
     .                '' OVERFLOWS ACTUAL DIMENSION 60 ... STOP'')')N 
         STOP 
      ENDIF 
      CALL SSIFA (A,N,N,LZ,INFO) 
      IF (INFO.NE.0) THEN 
         D=0.D0 
      ELSE 
         D=1.D0 
         CALL SSIDI (A,N,N,LZ,B,INERT,C,001) 
         DO 10 I=2,N 
CDIR$ IVDEP 
         DO 10 J=1,I-1 
   10    A(I,J)=A(J,I) 
      ENDIF 
      RETURN 
      END 

