SUBROUTINE MOLDAT(MODE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INCLUDE 'SIZES' COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 1 NA(NUMATM),NB(NUMATM),NC(NUMATM) COMMON /MOLMEC/ HTYPE(4),NHCO(4,20),NNHCO,ITYPE COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 1 NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 2 NCLOSE,NOPEN,NDUMY,FRACT 3 /KEYWRD/ KEYWRD 4 /NATORB/ NATORB(107) COMMON /CORE / CORE(107) 1 /BETAS / BETAS(107),BETAP(107),BETAD(107) 2 /MOLORB/ USPD(MAXORB),PSPD(MAXORB) 3 /VSIPS / VS(107),VP(107),VD(107) 4 /ONELEC/ USS(107),UPP(107),UDD(107) COMMON /ATHEAT/ ATHEAT 1 /POLVOL/ POLVOL(107) 2 /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107) 3 /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107) 4 ,GSD(107),GPD(107),GDD(107) 5 /IDEAA / GUESA1(107,10),GUESA2(107,10),GUESA3(107,10) 6 /IDEAS / GUESS1(107,10),GUESS2(107,10),GUESS3(107,10) 7 /IDEAP / GUESP1(107,10),GUESP2(107,10),GUESP3(107,10) COMMON /ALPHA / ALP(107) 1 /REFS/ ALLREF(107,4) 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 /PM3 / USSPM3(107), UPPPM3(107), UDDPM3(107), ZSPM3(107), 1ZPPM3(107), ZDPM3(107), BETASP(107), BETAPP(107), BETADP(107), 2ALPPM3(107), EISOLP(107), DDPM3(107), QQPM3(107), AMPM3(107), 3ADPM3(107), AQPM3(107) ,GSSPM3(107), GSPPM3(107), GPPPM3(107), 4GP2PM3(107), HSPPM3(107),POLVOP(107) COMMON /AM1BLO/USSAM1(107), UPPAM1(107), UDDAM1(107), ZSAM1(107), 1ZPAM1(107), ZDAM1(107), BETASA(107), BETAPA(107), BETADA(107), 2ALPAM1(107), EISOLA(107), DDAM1(107), QQAM1(107), AMAM1(107), 3ADAM1(107), AQAM1(107) ,GSSAM1(107), GSPAM1(107), GPPAM1(107), 4GP2AM1(107), HSPAM1(107),POLVOA(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), ISWAP(2,20), ESTORE(107) CHARACTER*241 KEYWRD, OLDE(20)*6, ALLREF*80 LOGICAL DEBUG, UHF,EXCI, TRIP, MINDO3, BIRAD, AM1, OPEN, LPM3, 1LMNDO, HALFE, SLOW DATA ESTORE(1)/0.D0/ IF(ESTORE(1).EQ.0.D0)THEN DO 9 I=1,107 9 ESTORE(I)=EHEAT(I) ENDIF DO 8 I=1,107 8 EHEAT(I)=ESTORE(I) DEBUG = (INDEX(KEYWRD,'MOLDAT').NE.0) LPM3 = (INDEX(KEYWRD,'PM3').NE.0) MINDO3= (INDEX(KEYWRD,'MINDO').NE.0) UHF=(INDEX(KEYWRD,'UHF') .NE. 0) AM1= (INDEX(KEYWRD,'AM1').NE.0) LMNDO=(.NOT.AM1.AND..NOT.LPM3) KHARGE=0 I=INDEX(KEYWRD,'CHARGE') IF(I.NE.0) KHARGE=READA(KEYWRD,I) ELECS=-KHARGE NDORBS=0 ATHEAT=0.D0 EAT=0.D0 NUMAT=0 IF(MODE.EQ.1) GOTO 80 IF ( LMNDO ) THEN * * SWITCH IN MNDO PARAMETERS * C C ZERO OUT GAUSSIAN 1 FOR CARBON. THIS WILL BE USED IN C ROTATE TO DECIDE WHETHER OR NOT TO USE AM1-TYPE GAUSSIANS C GUESS1(6,1)=0.D0 DO 10 I=1,107 IF(.NOT.MINDO3) POLVOL(I)=POLVOM(I) 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 ELSEIF( LPM3 ) THEN * * SWITCH IN MNDO-PM3 PARAMETERS * DO 30 I=1,107 DO 20 J=1,10 GUESS1(I,J)=GUESP1(I,J) GUESS2(I,J)=GUESP2(I,J) 20 GUESS3(I,J)=GUESP3(I,J) POLVOL(I)=POLVOP(I) ZS(I)=ZSPM3(I) ZP(I)=ZPPM3(I) ZD(I)=ZDPM3(I) USS(I)=USSPM3(I) UPP(I)=UPPPM3(I) UDD(I)=UDDPM3(I) BETAS(I)=BETASP(I) BETAP(I)=BETAPP(I) BETAD(I)=BETADP(I) ALP(I)=ALPPM3(I) EISOL(I)=EISOLP(I) DD(I)=DDPM3(I) QQ(I)=QQPM3(I) AM(I)=AMPM3(I) AD(I)=ADPM3(I) AQ(I)=AQPM3(I) GSS(I)=GSSPM3(I) GPP(I)=GPPPM3(I) GSP(I)=GSPPM3(I) GP2(I)=GP2PM3(I) HSP(I)=HSPPM3(I) 30 CONTINUE ELSE * * SWITCH IN AM1 PARAMETERS * DO 50 I=1,107 DO 40 J=1,10 GUESS1(I,J)=GUESA1(I,J) GUESS2(I,J)=GUESA2(I,J) 40 GUESS3(I,J)=GUESA3(I,J) POLVOL(I)=POLVOA(I) ZS(I)=ZSAM1(I) ZP(I)=ZPAM1(I) ZD(I)=ZDAM1(I) USS(I)=USSAM1(I) UPP(I)=UPPAM1(I) UDD(I)=UDDAM1(I) BETAS(I)=BETASA(I) BETAP(I)=BETAPA(I) BETAD(I)=BETADA(I) ALP(I)=ALPAM1(I) EISOL(I)=EISOLA(I) DD(I)=DDAM1(I) QQ(I)=QQAM1(I) AM(I)=AMAM1(I) AD(I)=ADAM1(I) AQ(I)=AQAM1(I) GSS(I)=GSSAM1(I) GPP(I)=GPPAM1(I) GSP(I)=GSPAM1(I) GP2(I)=GP2AM1(I) HSP(I)=HSPAM1(I) 50 CONTINUE ENDIF C C SWAP IN OLD PARAMETERS FOR ELEMENTS. OLDE CONTAINS THE C CHARACTER NAME OF THE ELEMENT, AND ISWAP(1,1:NEWELE) CONTAINS C THE ATOMIC NUMBER OF THE ELEMENT. ISWAP(2,1:NEWELE) CONTAINS C THE STORAGE ADDRESS OF THE OLD SET OF PARAMETERS. C NEWELE=2 OLDE(1)=' S1978' ISWAP(1,1)=16 ISWAP(2,1)=91 OLDE(2)='SI1978' ISWAP(1,2)=14 ISWAP(2,2)=90 C$DOIT ASIS DO 60 K=1,NEWELE IF(INDEX(KEYWRD,OLDE(K)).NE.0)THEN I=ISWAP(1,K) J=ISWAP(2,K) ALLREF(I,3)=ALLREF(J,1) ALLREF(I,1)=ALLREF(J,1) ZS(I)=ZS(J) ZP(I)=ZP(J) ZD(I)=ZD(J) USS(I)=USS(J) UPP(I)=UPP(J) UDD(I)=UDD(J) BETAS(I)=BETAS(J) BETAP(I)=BETAP(J) BETAD(I)=BETAD(J) ALP(I)=ALP(J) EISOL(I)=EISOL(J) DD(I)=DD(J) QQ(I)=QQ(J) AM(I)=AM(J) AD(I)=AD(J) AQ(I)=AQ(J) IF(GSS(J).NE.0)GSS(I)=GSS(J) IF(GPP(J).NE.0)GPP(I)=GPP(J) IF(GSP(J).NE.0)GSP(I)=GSP(J) IF(GP2(J).NE.0)GP2(I)=GP2(J) IF(HSP(J).NE.0)HSP(I)=HSP(J) ENDIF 60 CONTINUE IF( MINDO3 ) THEN DO 70 I=1,17 IF(I.NE.2.AND.I.NE.10)THEN USS(I)=USS3(I) UPP(I)=UPP3(I) EISOL(I)=EISOL3(I) EHEAT(I)=EHEAT3(I) ZS(I)=ZS3(I) ZP(I)=ZP3(I) GSS(I)=GSSM(I) GPP(I)=GPPM(I) GSP(I)=GSPM(I) GP2(I)=GP2M(I) HSP(I)=HSPM(I) ENDIF 70 CONTINUE ENDIF 80 CONTINUE 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 130 II=1,NATOMS IF(LABELS(II).EQ.99.OR.LABELS(II).EQ.107) GOTO 130 NUMAT=NUMAT+1 NAT(NUMAT)=LABELS(II) NFIRST(NUMAT)=IA NI=NAT(NUMAT) ATHEAT=ATHEAT+EHEAT(NI) EAT =EAT +EISOL(NI) ELECS=ELECS+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 IF(IA.GT.MAXORB) GOTO 270 USPD(IA)=USS(NI) IF(IA.EQ.IB) GOTO 120 K=IA+1 K1=IA+3 C$DOIT ASIS DO 90 J=K,K1 IF(J.GT.MAXORB) GOTO 270 USPD(J)=UPP(NI) 90 CONTINUE NHEAVY=NHEAVY+1 100 IF(K1.EQ.IB)GOTO 120 K=K1+1 C$DOIT ASIS DO 110 J=K,IB 110 USPD(J)=UDD(NI) 120 CONTINUE 130 IA=IB+1 IF(NUMAT.EQ.1)THEN IF(INDEX(KEYWRD,'FORCE').NE.0)THEN WRITE(6,'(///,A)')' A SINGLE ATOM HAS NO VIBRATIONAL MO 1DES' STOP ENDIF ENDIF IF(MODE.NE.1)CALL REFER 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(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,'TRIP').NE.0) EXCI=(INDEX(KEYWRD,'EXCI').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 C C PROTECT DUMB USERS FROM DUMB ERRORS! C NELECS=MAX(ELECS+0.5D0,0.D0) NELECS=MIN(2*NORBS,NELECS) 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 IF(MODE.NE.1) 1WRITE(6,'(//'' TRIPLET STATE CALCULATION'')') NBETA=NBETA-1 ENDIF ENDIF IF(INDEX(KEYWRD,'QUAR').NE.0) THEN IF(NBETA*2 .EQ. NELECS) THEN WRITE(6,'(//10X,''QUARTET SPECIFIED WITH EVEN NUMBER'', 1 '' OF ELECTRONS, CORRECT FAULT '')') STOP ELSE IF(MODE.NE.1) 1WRITE(6,'(//'' QUARTET STATE CALCULATION'')') NBETA=NBETA-1 ENDIF ENDIF IF(INDEX(KEYWRD,'QUIN').NE.0) THEN IF(NBETA*2 .NE. NELECS) THEN WRITE(6,'(//10X,''QUINTET SPECIFIED WITH ODD NUMBER'', 1 '' OF ELECTRONS, CORRECT FAULT '')') STOP ELSE IF(MODE.NE.1) 1WRITE(6,'(//'' QUINTET STATE CALCULATION'')') NBETA=NBETA-2 ENDIF ENDIF IF(INDEX(KEYWRD,'SEXT').NE.0) THEN IF(NBETA*2 .EQ. NELECS) THEN WRITE(6,'(//10X,''SEXTET SPECIFIED WITH EVEN NUMBER'', 1 '' OF ELECTRONS, CORRECT FAULT '')') STOP ELSE IF(MODE.NE.1)WRITE(6,'(//'' SEXTET STATE CALCULATION'')') NBETA=NBETA-2 ENDIF ENDIF NALPHA=NELECS-NBETA IF(MODE.NE.1) 1WRITE(6,'(//10X,''UHF CALCULATION, NO. OF ALPHA ELECTRONS ='',I 23,/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(MODE.NE.1) THEN IF(BIRAD)WRITE(6,'(//'' SYSTEM IS A BIRADICAL'')') IF(TRIP )WRITE(6,'(//'' TRIPLET STATE CALCULATION'')') IF(EXCI )WRITE(6,'(//'' EXCITED STATE CALCULATION'')') ENDIF IELEC=2 ILEVEL=2 ELSEIF((NELECS/2)*2.NE.NELECS) THEN IELEC=1 ILEVEL=1 ENDIF IF(INDEX(KEYWRD,'QUAR').NE.0) THEN IF(MODE.NE.1)WRITE(6,'(//'' QUARTET STATE CALCULATION'')') IELEC=3 ILEVEL=3 ENDIF IF(INDEX(KEYWRD,'QUIN').NE.0) THEN IF(MODE.NE.1)WRITE(6,'(//'' QUINTET STATE CALCULATION'')') IELEC=4 ILEVEL=4 ENDIF IF(INDEX(KEYWRD,'SEXT').NE.0) THEN IF(MODE.NE.1)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 IF(NCLOSE+NOPEN.GT.NORBS)THEN WRITE(6,'(A)')' NUMBER OF DOUBLY FILLED PLUS PARTLY FILLE 1D LEVELS' WRITE(6,'(A)')' GREATER THAN TOTAL NUMBER OF ORBITALS.' STOP ENDIF FRACT=IELEC*1.D0/ILEVEL IF(MODE.NE.1) 1WRITE(6,'('' THERE ARE'',I3,'' DOUBLY FILLED LEVELS'')')NCLOSE ENDIF IF(MODE.NE.1)WRITE(6,'(//10X,''RHF CALCULATION, NO. OF '', 1''DOUBLY OCCUPIED LEVELS ='',I3)')NCLOSE IF(MODE.NE.1 .AND. NOPEN.NE.0.AND.ABS(FRACT-1.D0).LT.1.D-4) 1WRITE(6,'(/27X,''NO. OF SINGLY OCCUPIED LEVELS ='',I3)')NOPEN IF(MODE.NE.1 .AND. NOPEN.NE.0.AND.ABS(FRACT-1.D0).GT.1.D-4) 1WRITE(6,'(/27X,''NO. OF LEVELS WITH OCCUPANCY'',F6.3,'' ='',I3)') 2FRACT,NOPEN IF(INDEX(KEYWRD,'C.I.=(').NE.0) THEN I=READA(KEYWRD,INDEX(KEYWRD,'C.I.=(')+5)- 1 READA(KEYWRD,INDEX(KEYWRD,'C.I.=(')+7) IF(NOPEN.GT.I)THEN WRITE(6,'(//,'' NUMBER OF OPEN-SHELLS ALLOWED IN C.I. IS 1LESS '' /'' THAN THAT SPECIFIED BY OTHER KEYWORDS'') 2') STOP ENDIF ENDIF IF(INDEX(KEYWRD,'C.I.').NE.0.AND.NOPEN.EQ.0)THEN NOPEN=1 NCLOSE=NCLOSE-1 FRACT=2.D0 ENDIF NOPEN=NOPEN+NCLOSE ENDIF C C WORK OUT IF DEFINED SPIN-STATE ALLOWED C MSDEL=INDEX(KEYWRD,' MS') IF(MSDEL.NE.0)THEN MSDEL=1.0001D0*READA(KEYWRD,INDEX(KEYWRD,' MS')) ELSE IF(INDEX(KEYWRD,'TRIP')+INDEX(KEYWRD,'QUAR').GT.0)MSDEL=1 IF(INDEX(KEYWRD,'QUIN')+INDEX(KEYWRD,'SEXT').GT.0)MSDEL=2 ENDIF IF(MSDEL.NE.0.AND..NOT.UHF)THEN C C MSDEL = NUMBER OF ALPHA ELECTRONS - NUMBER OF BETA ELECTRONS C NDOUBL=99 IF(INDEX(KEYWRD,'C.I.=(').NE.0)THEN NDOUBL=READA(KEYWRD,INDEX(KEYWRD,'C.I.=(')+7) NMOS=READA(KEYWRD,INDEX(KEYWRD,'C.I.=(')+5) ELSEIF (INDEX(KEYWRD,'C.I.=').NE.0)THEN NMOS=READA(KEYWRD,INDEX(KEYWRD,'C.I.=')+5) ELSE NMOS=NOPEN-NCLOSE ENDIF IF(NDOUBL.EQ.99)THEN J=MAX(MIN((NCLOSE+NOPEN+1)/2-(NMOS-1)/2,NORBS-NMOS+1),1) ELSE J=NCLOSE-NDOUBL+1 ENDIF NE=MAX(0.D0,(NCLOSE-J+1.D0))*2.D0+ 1 MAX(0.D0,(NOPEN-NCLOSE)*FRACT) + 0.5D0 NUPP=(NE+1)/2+MSDEL NDOWN=NE-NUPP C C NUPP = NUMBER OF ALPHA ELECTRONS IN ACTIVE SPACE C NDOWN = NUMBER OF BETA ELECTRONS IN ACTIVE SPACE C IF(NUPP*NDOWN.LT.0.OR.NUPP.GT.NMOS.OR.NDOWN.GT.NMOS)THEN WRITE(6,'(A)') 1' SPECIFIED SPIN COMPONENT NOT SPANNED BY ACTIVE SPACE' STOP ENDIF ENDIF C# WRITE(6,'('' NOPEN,NCLOSE,NALPHA,NBETA,FRACT'',4I4,F12.5)') C# 1 NOPEN, NCLOSE, NLAPHA, NBETA, FRACT C C MAKE SURE ANALYT IS NOT USED WITH ANALYTICAL C.I. DERIVATIVES C HALFE = (NOPEN.GT.NCLOSE.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0 1 .OR. INDEX(KEYWRD,'C.I.').NE.0) SLOW=(INDEX(KEYWRD,'EXCI').NE.0.OR. 1INDEX(KEYWRD,'ROOT').NE.0.AND.INDEX(KEYWRD,'ROOT=1').EQ.0) IF(HALFE)HALFE=(.NOT.SLOW) IF(INDEX(KEYWRD,'NOANCI').EQ.0.AND. 1INDEX(KEYWRD,'ANALYT').NE.0.AND.HALFE)THEN WRITE(6,*) WRITE(6,'(A)')' KEYWORD ''ANALYT'' CANNOT BE USED HERE: ', 1' ANALYICAL C.I. DERIVATIVES MUST USE FINITE DIFFERENCES', 2' TO CORRECT, REMOVE KEYWORD ''ANALYT'' OR ADD ''NOANCI''' STOP ENDIF YY=FLOAT(KHARGE)/(NORBS+1.D-10) L=0 DO 160 I=1,NUMAT NI=NAT(I) XX=1.D0/(NLAST(I)-NFIRST(I)+1+1.D-10) W=CORE(NI)*XX-YY IA=NFIRST(I) IC=NMIDLE(I) IB=NLAST(I) C$DOIT ASIS DO 140 J=IA,IC L=L+1 140 PSPD(L)=W C$DOIT ASIS DO 150 J=IC+1,IB L=L+1 150 PSPD(L)=0.D0 160 CONTINUE C C WRITE OUT THE INTERATOMIC DISTANCES C CALL GMETRY(GEO,COORD) RMIN=100.D0 L=0 DO 170 I=1,NUMAT DO 170 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 170 CONTINUE NNHCO=0 C C SET UP MOLECULAR-MECHANICS CORRECTION TO -(C=O)-(NH)- LINKAGE C THIS WILL BE USED IF MMOK HAS BEEN SPECIFIED. C ITYPE=1 IF(INDEX(KEYWRD,'AM1').NE.0)ITYPE=2 IF(INDEX(KEYWRD,'PM3').NE.0)ITYPE=3 IF(INDEX(KEYWRD,'MINDO').NE.0)ITYPE=4 C C IDENTIFY O=C-N-H SYSTEMS VIA THE INTERATOMIC DISTANCES MATRIX DO 220 I=1,NUMAT IF(NAT(I).NE.8) GOTO 220 DO 210 J=1,NUMAT IF(NAT(J).NE.6) GOTO 210 IJ=MAX(I,J) JI=I+J-IJ IF(RXYZ((IJ*(IJ-1))/2+JI).GT.1.3)GOTO 210 DO 200 K=1,NUMAT IF(NAT(K).NE.7) GOTO 200 JK=MAX(J,K) KJ=J+K-JK IF(RXYZ((JK*(JK-1))/2+KJ).GT.1.6)GOTO 200 DO 190 L=1,NUMAT IF(NAT(L).NE.1) GOTO 190 KL=MAX(K,L) LK=K+L-KL IF(RXYZ((KL*(KL-1))/2+LK).GT.1.3)GOTO 190 C C WE HAVE A H-N-C=O SYSTEM. THE ATOM NUMBERS ARE L-K-J-I C NOW SEARCH OUT ATOM ATTACHED TO NITROGEN, THIS SPECIFIES C THE SYSTEM X-N-C=O C DO 180 M=1,NUMAT IF(M.EQ.K.OR.M.EQ.L.OR.M.EQ.J) GOTO 180 MK=MAX(M,K) KM=M+K-MK IF(RXYZ((MK*(MK-1))/2+KM).GT.1.7)GOTO 180 NNHCO=NNHCO+1 NHCO(1,NNHCO)=I NHCO(2,NNHCO)=J NHCO(3,NNHCO)=K NHCO(4,NNHCO)=M NNHCO=NNHCO+1 NHCO(1,NNHCO)=I NHCO(2,NNHCO)=J NHCO(3,NNHCO)=K NHCO(4,NNHCO)=L GOTO 190 180 CONTINUE 190 CONTINUE 200 CONTINUE 210 CONTINUE 220 CONTINUE IF(MODE.NE.1.AND.NNHCO.NE.0)THEN IF(INDEX(KEYWRD,'MMOK').NE.0) THEN WRITE(6,'(A)')' MOLECULAR MECHANICS CORRECTION APPLIED TO PE 1PTIDELINKAGE' ELSEIF(INDEX(KEYWRD,'NOMM').NE.0)THEN WRITE(6,'(A,I2,2A)')' THERE ARE ',NNHCO/2,' PEPTIDE LINKAGES 1',' IDENTIFIED IN THIS SYSTEM' WRITE(6,'(A)')' IF YOU WANT MM CORRECTION TO THE CONH BARRIE 1R, ADD THE KEY-WORD "MMOK"' NNHCO=0 ELSE WRITE(6,'(A)')' THIS SYSTEM CONTAINS -HNCO- GROUPS.' WRITE(6,'(A)')' YOU MUST SPECIFY "NOMM" OR "MMOK" REGARDING 1MOLECULAR MECHANICS CORRECTION' STOP ENDIF ENDIF IF(MODE.NE.1.AND.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,230)IMINR,JMINR,RMIN 230 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,240)NUMAT,NORBS,NDORBS,NATOMS 240 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,250)(USPD(I),I=1,NORBS) 250 FORMAT(' ONE-ELECTRON DIAGONAL TERMS',/,10(/,10F8.3)) WRITE(6,260)(PSPD(I),I=1,NORBS) 260 FORMAT(' INITIAL P FOR ALL ATOMIC ORBITALS',/,10(/,10F8.3)) RETURN 270 WRITE(6,'(//10X,'' MAXIMUM NUMBER OF ATOMIC ORBITALS EXCEEDED'')') WRITE(6,'( 10X,'' MAXIMUM ALLOWED ='',I4)')MAXORB STOP END