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/' =',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 > 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 - < DMAX**2 C - .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 (2-CENTERS A.O) C PQKL(MPQKL) : WORK ARRAY FOR d (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'')') 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 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 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-) ) 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 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 . 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 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 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 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) : 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 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) = * 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)=*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 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 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) : 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) : 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 = + + + 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 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(/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,'',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(/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,'',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 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,'',8X,'ENERGY',4X,'!',5X,'ENERGY' 6 ,9X,'',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 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) 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 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=',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,'=',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 * * ! ... -1.0! * ! ... -1.0! * ! ... -1.0! * ! ... -1.0! * ! . . ... . ! * ! -1.0 -1.0 ... 0. ! * * WHERE 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