1 SUBROUTINE WRITMO(TIME0,FUNCT) 2 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3 INCLUDE 'SIZES' 4 CHARACTER KEYWRD*241 5 DOUBLE PRECISION MECI 6 COMPLEX SEC, VEC 7 COMMON /KEYWRD/ KEYWRD 8 COMMON /ELEMTS/ ELEMNT(107) 9 COMMON /GEOM / GEO(3,NUMATM), XCOORD(3,NUMATM) 10 COMMON /GEOKST/ NATOMS,LABELS(NUMATM), 11 1 NA(NUMATM),NB(NUMATM),NC(NUMATM) 12 COMMON /HMATRX/ H(MPACK) 13 COMMON /FOKMAT/ F(MPACK), FB(MPACK) 14 COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) 15 COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 16 COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR), 17 1 LOCDEP(MAXPAR) 18 COMMON / EULER/ TVEC(3,3), ID 19 COMMON /RJKS / RJKAB(NMECI,NMECI), RJKAA(NMECI,NMECI) 20 COMMON /ERRFN / ERRFN(MAXPAR), AICORR(MAXPAR) 21 COMMON /WORK1 / FMAT2D(NPULAY*4), SEC(NPULAY*2), VEC(NPULAY*2), 22 1 ALBAND(NPULAY*13) 23 COMMON /PATH / LATOM,LPARAM,REACT(200) 24 COMMON /NUMCAL/ NUMCAL 25 COMMON /NUMSCF/ NSCF 26 COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC) 27 COMMON /ATHEAT/ ATHEAT 28 PARAMETER (MXDIM=MAXPAR+NUMATM) 29 COMMON /SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDX(MXDIM),ISTA(2) 30 COMMON /CORE / CORE(107) 31 COMMON /LAST / LAST 32 COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MAXPAR**2-MPACK) 33 COMMON /CIMATS/ ENGYCI(3),VECTCI(9),ECI(6) 34 COMMON /MESAGE/ IFLEPO,IITER 35 COMMON /ATMASS/ ATMASS(NUMATM) 36 COMMON /ENUCLR/ ENUCLR 37 COMMON /ELECT / ELECT 38 COMMON /XYZGRA/ DXYZ(9*NUMATM) 39 COMMON /GRADNT/ GRAD(MAXPAR), GNORM 40 COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 41 1 NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 42 2 NCLOSE,NOPEN,NDUMY,FRACT 43 COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR) 44C COSMO change 45 LOGICAL ISEPS, USEPS, UPDA 46 COMMON /ISEPS/ ISEPS, USEPS, UPDA 47C end of COSMO change 48************************************************************************ 49* 50* WRITE PRINTS OUT MOST OF THE RESULTS. 51* IT SHOULD NOT ALTER ANY PARAMETERS, SO THAT IT CAN BE CALLED 52* AT ANY CONVENIENT TIME. 53* 54************************************************************************ 55 DIMENSION Q(MAXORB), Q2(MAXORB), COORD(3,NUMATM) 56 1,IEL1(107), NELEMT(107), IEL2(107) 57 DIMENSION W(N2ELEC), DUMY(3) 58 DIMENSION GCOORD(1) 59 LOGICAL UHF, CI, SINGLT, TRIPLT, EXCITD, PRTGRA, STILL 60 CHARACTER TYPE(3)*11, IDATE*24, CALCN(2)*5, GTYPE*13, GRTYPE*14, 61 1 FLEPO(16)*58, ITER(2)*58, NUMBRS(11)*1, GETNAM*80 62 CHARACTER*2 ELEMNT, IELEMT(20), CALTYP*7, NAMFIL*80, NAME*4 63 CHARACTER NAMO*4, ISTA*4 64 SAVE ICALCN, NUMBRS, CALCN, TYPE, FLEPO, ITER 65 EQUIVALENCE (W,WJ) 66 DOUBLE PRECISION WJ, WK 67 DATA ICALCN/0/ 68 DATA TYPE/'BOND ','ANGLE ','DIHEDRAL '/ 69 DATA CALCN /' ','ALPHA'/ 70 DATA NUMBRS /'0','1','2','3','4','5','6','7','8','9',' '/ 71 DATA FLEPO(1),FLEPO(2),FLEPO(3)/ 72 1' 1SCF WAS SPECIFIED, SO BFGS WAS NOT USED ', 73 2' GRADIENTS WERE INITIALLY ACCEPTABLY SMALL ', 74 3' HERBERTS TEST WAS SATISFIED IN BFGS '/ 75 DATA FLEPO(4),FLEPO(5),FLEPO(6)/ 76 1' THE LINE MINIMIZATION FAILED TWICE IN A ROW. TAKE CARE!', 77 2' BFGS FAILED DUE TO COUNTS EXCEEDED. TAKE CARE! ', 78 3' PETERS TEST WAS SATISFIED IN BFGS OPTIMIZATION '/ 79 DATA FLEPO(7),FLEPO(8),FLEPO(9)/ 80 1' THIS MESSAGE SHOULD NEVER APPEAR, CONSULT A PROGRAMMER!! ', 81 2' GRADIENT TEST NOT PASSED, BUT FURTHER WORK NOT JUSTIFIED ', 82 3' A FAILURE HAS OCCURRED, TREAT RESULTS WITH CAUTION!! '/ 83 DATA FLEPO(10),FLEPO(11),FLEPO(12)/ 84 1' GEOMETRY OPTIMIZED USING NLLSQ. GRADIENT NORM MINIMIZED ', 85 2' GEOMETRY OPTIMIZED USING POWSQ. GRADIENT NORM MINIMIZED ', 86 3' CYCLES EXCEEDED, GRADIENT NOT FULLY MINIMIZED IN NLLSQ '/ 87 DATA FLEPO(13),FLEPO(14),FLEPO(15)/ 88 1' 1SCF RUN AFTER RESTART. GEOMETRY MIGHT NOT BE OPTIMIZED ', 89 2' HEAT OF FORMATION MINIMIZED IN ONE LINE SEARCH ', 90 3' GEOMETRY OPTIMISED USING EIGENVECTOR FOLLOWING (EF). '/ 91 DATA FLEPO(16)/ 92 1' EF-OPTIMIZED GEOMETRY. NUMBER OF -VE ROOTS INCORRECT '/ 93 DATA ITER/ 94 1' SCF FIELD WAS ACHIEVED ', 95 2' ++++----**** FAILED TO ACHIEVE SCF. ****----++++ '/ 96C 97C SUMMARY OF RESULTS (NOTE: THIS IS IN A SUBROUTINE SO IT 98C CAN BE USED BY THE PATH OPTION) 99 IF(ICALCN.EQ.0)NAMFIL='**NULL**' 100 IDATE=' ' 101 IF(IFLEPO.EQ.0) IFLEPO=7 102 IUHF=MIN(INDEX(KEYWRD,' UHF'),1)+1 103 PRTGRA=(INDEX(KEYWRD,' GRAD').NE.0.AND.NVAR.GT.0) 104 LINEAR=(NORBS*(NORBS+1))/2 105 SINGLT=(INDEX(KEYWRD,' SING') .NE. 0) 106 TRIPLT=(INDEX(KEYWRD,' TRIP') .NE. 0) 107 EXCITD=(INDEX(KEYWRD,' EXCI') .NE. 0) 108 CI=(INDEX(KEYWRD,' C.I.') .NE. 0) 109 IF(INDEX(KEYWRD,' MINDO') .NE. 0) THEN 110 CALTYP='MINDO/3' 111 ELSEIF(INDEX(KEYWRD,' AM1') .NE. 0) THEN 112 CALTYP=' AM1 ' 113 ELSEIF(INDEX(KEYWRD,' PM3') .NE. 0) THEN 114 CALTYP=' PM3 ' 115 ELSE 116 CALTYP=' MNDO ' 117 ENDIF 118 UHF=(IUHF.EQ.2) 119 CALL fdate(IDATE) 120 DEGREE=57.29577951D0 121 IF(NA(1).EQ.99)THEN 122 DEGREE=1.D0 123 TYPE(1)='CARTESIAN X' 124 TYPE(2)='CARTESIAN Y' 125 TYPE(3)='CARTESIAN Z' 126 ENDIF 127 GNORM=0.D0 128 IF(NVAR.NE.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR)) 129 WRITE(6,'(/,'' ----'',15(''-----''))') 130 CALL WRTTXT(6) 131 WRITE(6,'(//4X,A58)')FLEPO(IFLEPO) 132 IITER=MAX(1,IITER) 133 WRITE(6,'(4X,A58)')ITER(IITER) 134 WRITE(6,'(//30X,A7,'' CALCULATION'')')CALTYP 135 WRITE(6,'(55X,''VERSION '',F5.2)')VERSON 136 WRITE(6,'(55X,A24)')IDATE 137 IF(IITER.EQ.2)THEN 138C 139C RESULTS ARE MEANINGLESS. DON'T PRINT ANYTHING! 140C 141 WRITE(6,'(//,'' FOR SOME REASON THE SCF CALCULATION FAILED.'',/ 142 1,'' THE RESULTS WOULD BE MEANINGLESS, SO WILL NOT BE PRINTED.'')') 143 WRITE(6,'('' TRY TO FIND THE REASON FOR THE FAILURE BY USING '' 144 1,''"PL".'',/, 145 2'' CHECK YOUR GEOMETRY AND ALSO TRY USING SHIFT OR PULAY. '')') 146 CALL GEOUT(1) 147 STOP 148 ENDIF 149 WRITE(6,'(////10X,''FINAL HEAT OF FORMATION ='',F17.5,'' KCAL'' 150 1)')FUNCT 151 IF(LATOM.EQ.0) WRITE(6,'(/)') 152 WRITE(6,'( 10X,''TOTAL ENERGY ='',F17.5,'' EV'' 153 1)')ELECT+ENUCLR 154 WRITE(6,'( 10X,''ELECTRONIC ENERGY ='',F17.5,'' EV'' 155 1)')ELECT 156 WRITE(6,'( 10X,''CORE-CORE REPULSION ='',F17.5,'' EV'' 157 1)')ENUCLR 158C COSMO change 159 IF (ISEPS) THEN 160 CALL DIELEN(EDIE) 161 IW = 6 162 WRITE(IW,'( 10X,''DIELECTRIC ENERGY ='',F17.5,'' EV'' 163 1 )')EDIE 164 ENDIF 165C end of COSMO change 166 IF(LATOM.EQ.0) WRITE(6,'(1X)') 167 PRTGRA=(PRTGRA .OR. GNORM .GT. 2.D0) 168 IF(PRTGRA) 169 1WRITE(6,'( 10X,''GRADIENT NORM ='',F17.5)')GNORM 170 STILL=.TRUE. 171 IF(LATOM.EQ.0) THEN 172 IF(INDEX(KEYWRD,' AIDER').NE.0) GOTO 45 173 IF(INDEX(KEYWRD,'1SCF').NE.0.AND.INDEX(KEYWRD,'GRAD').EQ.0)GOTO 45 174C 175C CHECK THAT THE CARTESIAN COORDINATE GRADIENT IS ALSO SMALL 176C 177 IF(DOT(DXYZ,DXYZ,3*NUMAT).GT.MAX(16.D0,4*GNORM**2) 178 1.AND.GNORM.LT.2.D0.AND.NCLOSE.EQ.NOPEN.AND.ID.EQ.0) THEN 179 WRITE(6,'(A)')' WARNING -- GEOMETRY IS NOT AT A STATIONAR 180 1Y POINT' 181 STILL=.FALSE. 182 ENDIF 183 45 CONTINUE 184 ELSE 185C 186C WE NEED TO CALCULATE THE REACTION COORDINATE GRADIENT. 187C 188 MVAR=NVAR 189 LOC11=LOC(1,1) 190 LOC21=LOC(2,1) 191 NVAR=1 192 LOC(1,1)=LATOM 193 LOC(2,1)=LPARAM 194 XREACT=GEO(LPARAM,LATOM) 195 CALL DERIV(GEO,GCOORD) 196 NVAR=MVAR 197 LOC(1,1)=LOC11 198 LOC(2,1)=LOC21 199 GRTYPE=' KCAL/ANGSTROM' 200 IF(LPARAM.EQ.1)THEN 201 WRITE(6,'( 10X,''FOR REACTION COORDINATE ='',F17.5 202 1 ,'' ANGSTROMS'')')XREACT 203 ELSE 204 IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN ' 205 WRITE(6,'( 10X,''FOR REACTION COORDINATE ='',F17.5 206 1 ,'' DEGREES'')')XREACT*DEGREE 207 ENDIF 208 WRITE(6,'( 10X,''REACTION GRADIENT ='',F17.5,A14 209 1 )')GCOORD(1),GRTYPE 210 ENDIF 211 IF(NALPHA.GT.0)THEN 212 EIONIS=-MAX(EIGS(NALPHA), EIGB(NBETA)) 213 ELSEIF(NELECS.EQ.1)THEN 214 EIONIS=-EIGS(1) 215 ELSEIF(NELECS.GT.1) THEN 216 EIONIS=-MAX(EIGS(NCLOSE), EIGS(NOPEN)) 217 ELSE 218 EIONIS=0.D0 219 ENDIF 220 NOPN=NOPEN-NCLOSE 221C CORRECTION TO I.P. OF DOUBLETS 222 IF(NOPN.EQ.1)THEN 223 I=NCLOSE*NORBS+1 224 EIONIS=EIONIS+0.5D0*RJKAB(1,1) 225 ENDIF 226 IF(ABS(EIONIS).GT.1.D-5) 227 1WRITE(6,'( 10X,''IONIZATION POTENTIAL ='',F17.5)')EIONIS 228 IF( UHF ) THEN 229 WRITE(6,'( 10X,''NO. OF ALPHA ELECTRONS ='',I11)')NALPHA 230 WRITE(6,'( 10X,''NO. OF BETA ELECTRONS ='',I11)')NBETA 231 ELSE 232 WRITE(6,'( 10X,''NO. OF FILLED LEVELS ='',I11)')NCLOSE 233 IF(NOPN.NE.0) THEN 234 WRITE(6,'( 10X,''AND NO. OF OPEN LEVELS ='',I11)')NOPN 235 ENDIF 236 ENDIF 237 SUMW=0 238 DO 10 I=1,NUMAT 239 10 SUMW=SUMW+ATMASS(I) 240 IF(SUMW.GT.0.1D0) 241 1WRITE(6,'( 10X,''MOLECULAR WEIGHT ='',F11.3)')SUMW 242 IF(LATOM.EQ.0) WRITE(6,'(/)') 243 WRITE(6,'(10X,''SCF CALCULATIONS = '',I14 )') NSCF 244 TIM=SECOND()-TIME0 245 I=TIM*0.000001D0 246 TIM=TIM-I*1000000 247 CALL TIMOUT(6,TIM) 248 IF( NDEP .NE. 0 )CALL SYMTRY 249 DO 20 I=1,NVAR 250 20 XPARAM(I)=GEO(LOC(2,I),LOC(1,I)) 251 CALL GMETRY(GEO,COORD) 252 IF(PRTGRA)THEN 253 WRITE(6,'(///7X,''FINAL POINT AND DERIVATIVES'',/)') 254 WRITE(6,'('' PARAMETER ATOM TYPE '' 255 1 ,'' VALUE GRADIENT'')') 256 ENDIF 257 SUM=0.5D0 258 DO 30 I=1,NUMAT 259 30 SUM=SUM+CORE(NAT(I)) 260 I=SUM 261 KCHRGE=I-NCLOSE-NOPEN-NALPHA-NBETA 262C 263C WRITE OUT THE GEOMETRIC VARIABLES 264C 265 IF(PRTGRA) THEN 266 DO 40 I=1,NVAR 267 J=LOC(2,I) 268 K=LOC(1,I) 269 L=LABELS(K) 270 XI=XPARAM(I) 271 IF(J.NE.1) XI=XI*DEGREE 272 IF(J.EQ.1.OR.NA(1).EQ.99)THEN 273 GTYPE='KCAL/ANGSTROM' 274 ELSE 275 GTYPE='KCAL/RADIAN ' 276 ENDIF 277 40 WRITE(6,'(I7,I11,1X,A2,4X,A11,F13.6,F13.6,2X,A13)') 278 1I,K,ELEMNT(L),TYPE(J),XI,GRAD(I),GTYPE 279 ENDIF 280C 281C WRITE OUT THE GEOMETRY 282C 283 WRITE(6,'(///)') 284 CALL GEOUT(1) 285 IF (INDEX(KEYWRD,' NOINTER') .EQ. 0) THEN 286C 287C WRITE OUT THE INTERATOMIC DISTANCES 288C 289 L=0 290 DO 50 I=1,NUMAT 291 DO 50 J=1,I 292 L=L+1 293 50 RXYZ(L)=SQRT((COORD(1,I)-COORD(1,J))**2+ 294 1 (COORD(2,I)-COORD(2,J))**2+ 295 2 (COORD(3,I)-COORD(3,J))**2) 296 WRITE(6,'(//10X,'' INTERATOMIC DISTANCES'')') 297 CALL VECPRT(RXYZ,NUMAT) 298 ENDIF 299 DO 60 I=1,NORBS 300 60 IF(EIGS(I).LT.-999.D0.OR.EIGS(I).GT.1000.D0)EIGS(I)=0.D0 301 DO 70 I=1,NORBS 302 70 IF(EIGB(I).LT.-999.D0.OR.EIGB(I).GT.1000.D0)EIGS(I)=0.D0 303 IF(ISYBYL.EQ.1) THEN 304C 305C THE FOLLOWING OPEN STATEMENTS ARE NON-STANDARD. IF THIS CAUSES 306C DIFFICULTY REPLACE THEM WITH 307 OPEN(UNIT=16,FILE=GETNAM('FOR016'),STATUS='NEW',ERR=31) 308 GOTO 32 309 31 OPEN(UNIT=16,FILE=GETNAM('FOR016'),STATUS='OLD') 310 WRITE(6,'(A)') 'Error opening SYBYL MOPAC output' 311 32 CONTINUE 312C# OPEN(UNIT=16,FILE=GETNAM('FOR016'),CARRIAGECONTROL='LIST', 313C# +STATUS='NEW',ERR=31) 314C# GOTO 32 315C# 31 OPEN(UNIT=16,FILE=GETNAM('FOR016'),CARRIAGECONTROL='LIST', 316C# +STATUS='OLD') 317C# WRITE(6,'(A)') 'Error opening SYBYL MOPAC output' 318C# 32 CONTINUE 319 ENDIF 320 IF(NORBS.GT.0)THEN 321 CALL SYMTRZ(COORD,C,NORBS,NORBS,.FALSE.,.TRUE.) 322 WRITE(6,'(//'' MOLECULAR POINT GROUP : '',A4)')NAME 323 IF (INDEX(KEYWRD,'VECT') .NE. 0) THEN 324 WRITE(6,'(//10X,A5,'' EIGENVECTORS '')')CALCN(IUHF) 325 CALL MATOU1 (C,EIGS,NORBS,NORBS,MAXORB,2) 326 IF(UHF) THEN 327 WRITE(6,'(//10X,'' BETA EIGENVECTORS '')') 328 CALL MATOU1 (CBETA,EIGB,NORBS,NORBS,MAXORB,2) 329 ENDIF 330 ELSE 331 WRITE(6,'(//10X,A5,'' EIGENVALUES'',/)')CALCN(IUHF) 332 WRITE(6,'(8F10.5)')(EIGS(I),I=1,NORBS) 333 IF(UHF) THEN 334 WRITE(6,'(//10X,'' BETA EIGENVALUES '')') 335 WRITE(6,'(8F10.5)')(EIGB(I),I=1,NORBS) 336 ENDIF 337 ENDIF 338 ENDIF 339 WRITE(6,'(//13X,'' NET ATOMIC CHARGES AND DIPOLE '', 340 1''CONTRIBUTIONS'',/)') 341 WRITE(6,'(8X,'' ATOM NO. TYPE CHARGE ATOM'' 342 1,'' ELECTRON DENSITY'')') 343 CALL CHRGE(P,Q) 344 DO 80 I=1,NUMAT 345 L=NAT(I) 346 Q2(I)=CORE(L) - Q(I) 347 80 WRITE(6,'(I12,9X,A2,4X,F13.4,F16.4)') 348 1I,ELEMNT(L),Q2(I),Q(I) 349 DIP= DIPOLE(P,Q2,COORD,DUMY,1) 350 IF (INDEX(KEYWRD,' NOXYZ') .EQ. 0) THEN 351 WRITE(6,'(//10X,''CARTESIAN COORDINATES '',/)') 352 WRITE(6,'(4X,''NO.'',7X,''ATOM'',15X,''X'', 353 1 9X,''Y'',9X,''Z'',/)') 354 WRITE(6,'(I6,8X,A2,14X,3F10.4)') 355 1 (I,ELEMNT(NAT(I)),(COORD(J,I),J=1,3),I=1,NUMAT) 356 ENDIF 357 IF(NORBS.GT.0) THEN 358 IF (INDEX(KEYWRD,' K=') .NE. 0)THEN 359C 360C GO INTO BRILLOUIN ZONE MODE 361C 362 I=INDEX(KEYWRD,' K=') 363 STEP=READA(KEYWRD,I) 364 MONO3=NLAST(NINT(READA(KEYWRD(I:),INDEX(KEYWRD(I:),',')))) 365 IF(UHF)WRITE(6,'(A)')' ALPHA BANDS' 366 CALL BRLZON(F, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2) 367 IF(UHF)THEN 368 WRITE(6,'(A)')' BETA BANDS' 369 CALL BRLZON(FB, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2) 370 ENDIF 371 ENDIF 372 IF(ISYBYL.EQ.1)THEN 373 NFILLD=MAX(NCLOSE,NALPHA,NBETA) 374 CALL MPCSYB(NUMAT,COORD,Q2,1,EIGS,NFILLD,FUNCT,EIONIS 375 1 ,KCHRGE,DIP) 376 ENDIF 377 IF (INDEX(KEYWRD,' FOCK') .NE. 0) THEN 378 WRITE(6,'('' FOCK MATRIX IS '')') 379 CALL VECPRT(F,NORBS) 380 ENDIF 381 IF (INDEX(KEYWRD,' DENS') .NE. 0) THEN 382 WRITE(6,'(//,20X,'' DENSITY MATRIX IS '')') 383 CALL VECPRT(P,NORBS) 384 ELSE 385 WRITE(6,'(//10X,''ATOMIC ORBITAL ELECTRON POPULATIONS'',/)') 386 WRITE(6,'(8F10.5)')(P((I*(I+1))/2),I=1,NORBS) 387 ENDIF 388 IF(INDEX(KEYWRD,' PI') .NE. 0) THEN 389 WRITE(6,'(//10X,''SIGMA-PI BOND-ORDER MATRIX'')') 390 CALL DENROT 391 ENDIF 392 IF(UHF) THEN 393 SZ=ABS(NALPHA-NBETA)*0.5D0 394 SS2=SZ*SZ 395 L=0 396 DO 100 I=1,NORBS 397 DO 90 J=1,I 398 L=L+1 399 PA(L)=PA(L)-PB(L) 400 90 SS2=SS2+PA(L)**2 401 100 SS2=SS2-0.5D0*PA(L)**2 402 WRITE(6,'(//20X,''(SZ) ='',F10.6)')SZ 403 WRITE(6,'( 20X,''(S**2) ='',F10.6)')SS2 404 IF(INDEX(KEYWRD,' SPIN') .NE. 0) THEN 405 WRITE(6,'(//10X,''SPIN DENSITY MATRIX'')') 406 CALL VECPRT(PA,NORBS) 407 ELSE 408 WRITE(6,'(//10X,''ATOMIC ORBITAL SPIN POPULATIONS'',/)') 409 WRITE(6,'(8F10.5)')(PA((I*(I+1))/2),I=1,NORBS) 410 ENDIF 411 IF(INDEX(KEYWRD,' HYPERFINE') .NE. 0) THEN 412C 413C WORK OUT THE HYPERFINE COUPLING CONSTANTS. 414C 415 WRITE(6,'(//10X,'' HYPERFINE COUPLING COEFFICIENTS'',/ 416 1)') 417 J=(NALPHA-1)*NORBS 418 DO 110 K=1,NUMAT 419 I=NFIRST(K) 420C# WRITE(6,'('' PA:'',F13.6,'' C('',I2,''+'',I3,''):'', 421C# +F13.5)')PA((I*(I+1))/2),I,J,C(I+J) 422 110 Q(K)=PA((I*(I+1))/2)*0.3333333D0+C(I+J)**2*0.66666666D0 423 WRITE(6,'(5(2X,A2,I2,F9.5,1X))') 424 1 (ELEMNT(NAT(I)),I,Q(I),I=1,NUMAT) 425 ENDIF 426 DO 120 I=1,LINEAR 427 120 PA(I)=P(I)-PB(I) 428 ENDIF 429 IF (INDEX(KEYWRD,' BONDS') .NE. 0) THEN 430 IF(NBETA.EQ.0)THEN 431 WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH M.O.'',/)') 432 CALL MOLVAL(C,P,NORBS,2.D0) 433 ELSE 434 WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH ALPHA M.O.' 435 1',/)') 436 CALL MOLVAL(C,P,NORBS,1.D0) 437 WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH BETA M.O.' 438 1',/)') 439 CALL MOLVAL(C,P,NORBS,1.D0) 440 ENDIF 441 CALL BONDS(P) 442 ENDIF 443 I=NCLOSE+NALPHA 444 IF (INDEX(KEYWRD,' LOCAL') .NE. 0) THEN 445 CALL LOCAL(C,NORBS,I,EIGS) 446 IF(NBETA.NE.0)THEN 447 WRITE(6,'(//10X,'' LOCALIZED BETA MOLECULAR ORBITALS'')') 448 CALL LOCAL(CBETA,NORBS,NBETA,EIGB) 449 ENDIF 450 ENDIF 451 IF (INDEX(KEYWRD,' 1ELE') .NE. 0) THEN 452 WRITE(6,'('' FINAL ONE-ELECTRON MATRIX '')') 453 CALL VECPRT(H,NORBS) 454 ENDIF 455 IF(INDEX(KEYWRD,' ENPART') .NE. 0) 456 1CALL ENPART(UHF,H,PA,PB,P,Q,COORD) 457 ENDIF 458 DO 130 I=1,107 459 130 NELEMT(I)=0 460 DO 140 I=1,NUMAT 461 IGO=NAT(I) 462 IF (IGO.GT.107) GO TO 140 463 NELEMT(IGO)=NELEMT(IGO)+1 464 140 CONTINUE 465 ICHFOR=0 466 IF (NELEMT(6).EQ.0) GO TO 150 467 ICHFOR=1 468 IELEMT(1)=ELEMNT(6) 469 NZS=NELEMT(6) 470 IF (NZS.LT.10) THEN 471 IF (NZS.EQ.1) THEN 472 IEL1(1)=11 473 ELSE 474 IEL1(1)=NZS+1 475 ENDIF 476 IEL2(1)=11 477 ELSE 478 KFRST=NZS/10 479 KSEC=NZS-(10*KFRST) 480 IEL1(1)=KFRST+1 481 IEL2(1)=KSEC+1 482 ENDIF 483 150 NELEMT(6)=0 484 DO 160 I=1,107 485 IF (NELEMT(I).EQ.0) GO TO 160 486 ICHFOR=ICHFOR+1 487 IELEMT(ICHFOR)=ELEMNT(I) 488 NZS=NELEMT(I) 489 IF (NZS.LT.10) THEN 490 IF (NZS.EQ.1) THEN 491 IEL1(ICHFOR)=11 492 ELSE 493 IEL1(ICHFOR)=NZS+1 494 ENDIF 495 IEL2(ICHFOR)=11 496 ELSE 497 KFRST=NZS/10 498 KSEC=NZS-(10*KFRST) 499 IEL1(ICHFOR)=KFRST+1 500 IEL2(ICHFOR)=KSEC+1 501 ENDIF 502 160 CONTINUE 503 IF(INDEX(KEYWRD,' DENOUT') .NE. 0) THEN 504 OPEN(UNIT=10,FILE=GETNAM('FOR010'), 505 +STATUS='UNKNOWN',FORM='UNFORMATTED') 506 REWIND 10 507 WRITE(10)(PA(I),I=1,LINEAR) 508 IF(UHF)WRITE(10)(PB(I),I=1,LINEAR) 509 CLOSE (10) 510 ENDIF 511 IF((CI.OR.NOPEN.NE.NCLOSE.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0 512 1 .OR.INDEX(KEYWRD,' SIZE').NE.0) 513 2 .AND. INDEX(KEYWRD,' MECI')+INDEX(KEYWRD,' ESR').NE.0)THEN 514 WRITE(6,'(//10X, 515 1''MULTI-ELECTRON CONFIGURATION INTERACTION CALCULATION'',//)') 516 LAST=3 517 X=MECI(EIGS,C) 518 ENDIF 519 IF (INDEX(KEYWRD,' MULLIK') +INDEX(KEYWRD,' GRAPH') .NE. 0) THEN 520 IF (INDEX(KEYWRD,' MULLIK') .NE. 0) 521 1 WRITE(6,'(/10X,'' MULLIKEN POPULATION ANALYSIS'')') 522 DO 172 I=1,NORBS 523 172 Q(I) = P((I*(I+1))/2) 524 CALL MULLIK(C,H,F,NORBS,P,RXYZ) 525 DO 174 I=1,NORBS 526 174 P((I*(I+1))/2) = Q(I) 527 IF (INDEX(KEYWRD,' GRAPH') .NE. 0) 528 1 WRITE(6,'(/10X,'' DATA FOR GRAPH WRITTEN TO DISK'')') 529 ENDIF 530C 531C NOTE THAT THE DENSITY, H AND F MATRICES ARE CORRUPTED BY A 532C CALL TO MULLIK. 533 IF(ISYBYL.EQ.1) THEN 534 IF (INDEX(KEYWRD,'MULLIK').EQ.0) THEN 535 CALL MPCPOP(C,0) 536 ELSE 537 CALL MPCPOP(C,1) 538 ENDIF 539 CLOSE(16) 540 ENDIF 541 IF(ICALCN.NE.NUMCAL)THEN 542 IF(NAMFIL.EQ.'**NULL**') THEN 543 NAMFIL=GETNAM('FOR012') 544 INAM=ICHAR('a') 545 JNAM=INAM 546 JEND=INDEX(NAMFIL,' ') 547 IEND=JEND+1 548 ENDIF 549 162 CLOSE (12) 550 OPEN(UNIT=12,FILE=NAMFIL,STATUS='NEW',ERR=163) 551 GOTO 164 552 163 NAMFIL(IEND:IEND)=CHAR(INAM) 553 NAMFIL(JEND:JEND)=CHAR(JNAM) 554 IF(INAM.EQ.ICHAR('z'))THEN 555 INAM=INAM-26 556 JNAM=JNAM+1 557 ENDIF 558 INAM=INAM+1 559 GOTO 162 560 164 REWIND 12 561 ICALCN=NUMCAL 562 ENDIF 563 IF(INDEX(KEYWRD,'GREENF') .NE. 0) CALL GREENF 564 IWRITE=12 565 170 WRITE(IWRITE,'(//20X,'' SUMMARY OF '',A7, 566 1'' CALCULATION'',/)')CALTYP 567 WRITE(IWRITE,'(60X,''VERSION '',F5.2)')VERSON 568 WRITE (IWRITE,180) (IELEMT(I),NUMBRS(IEL1(I)),NUMBRS(IEL2(I)) 569 1,I=1,ICHFOR) 570 180 FORMAT (//,1X,17(A2,A1,A1)) 571 WRITE(IWRITE,'(55X,A24)')IDATE 572 CALL WRTTXT(IWRITE) 573 WRITE(IWRITE,'(//4X,A58)')FLEPO(IFLEPO) 574 WRITE(IWRITE,'(4X,A58)')ITER(IITER) 575 WRITE(IWRITE,'(//10X,''HEAT OF FORMATION ='' 576 1,F17.6,'' KCAL'')')FUNCT 577 WRITE(IWRITE,'( 10X,''ELECTRONIC ENERGY ='' 578 1,F17.6,'' EV'')')ELECT 579 WRITE(IWRITE,'( 10X,''CORE-CORE REPULSION ='' 580 1,F17.6,'' EV'')')ENUCLR 581 IF(PRTGRA) 582 1WRITE(IWRITE,'( 10X,''GRADIENT NORM ='' 583 2,F17.6)')GNORM 584 IF(LATOM.EQ.0) THEN 585 IF(.NOT.STILL) WRITE(IWRITE,'(A)') 586 1' WARNING -- GEOMETRY IS NOT AT A STATIONARY POINT' 587 ELSE 588 GRTYPE=' KCAL/ANGSTROM' 589 IF(LPARAM.EQ.1)THEN 590 WRITE(IWRITE,'( 10X,''FOR REACTION COORDINATE ='',F17.4 591 1 ,'' ANGSTROMS'')')XREACT 592 ELSE 593 IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN ' 594 WRITE(IWRITE,'( 10X,''FOR REACTION COORDINATE ='',F17.4 595 1 ,'' DEGREES'')')XREACT*DEGREE 596 ENDIF 597 WRITE(IWRITE,'( 10X,''REACTION GRADIENT ='',F17.6,A14 598 1 )')GCOORD(1),GRTYPE 599 ENDIF 600 WRITE(IWRITE,'( 10X,''DIPOLE ='' 601 1,F16.5, '' DEBYE'')')DIP 602 IF(UHF) THEN 603 WRITE(IWRITE,'( 10X,''(SZ) ='',F17.6)')SZ 604 WRITE(IWRITE,'( 10X,''(S**2) ='',F17.6)')SS2 605 WRITE(IWRITE,'( 10X,''NO. OF ALPHA ELECTRONS ='',I10)')NALPHA 606 WRITE(IWRITE,'( 10X,''NO. OF BETA ELECTRONS ='',I10)')NBETA 607 ELSE 608 WRITE(IWRITE,'( 10X,''NO. OF FILLED LEVELS ='',I10)')NCLOSE 609 NOPN=NOPEN-NCLOSE 610 IF(NOPN.NE.0) 611 1WRITE(IWRITE,'( 10X,''AND NO. OF OPEN LEVELS ='',I10)')NOPN 612 ENDIF 613 IF(CI) 614 1WRITE(IWRITE,'( 10X,''CONFIGURATION INTERACTION WAS USED'')') 615 IF(KCHRGE.NE.0) 616 1WRITE(IWRITE,'( 10X,''CHARGE ON SYSTEM ='',I10)')KCHRGE 617 WRITE(IWRITE,'( 10X,''IONIZATION POTENTIAL ='' 618 1,F17.6,'' EV'')')EIONIS 619 WRITE(IWRITE,'( 10X,''MOLECULAR WEIGHT ='',F14.3)')SUMW 620 WRITE(IWRITE,'( 10X,''SCF CALCULATIONS ='' 621 1,I10)') NSCF 622 TIM=SECOND()-TIME0 623 CALL TIMOUT(IWRITE,TIM) 624 WRITE(IWRITE,'(//10X,''FINAL GEOMETRY OBTAINED'',36X,''CHARGE'')') 625 CALL GEOUT(IWRITE) 626 IF(INDEX(KEYWRD,' AIGOUT').NE.0)THEN 627 WRITE(IWRITE,'(//,A)')' GEOMETRY IN GAUSSIAN Z-MATRIX STYLE' 628 CALL WRTTXT(IWRITE) 629 CALL GEOUTG(IWRITE) 630 ENDIF 631 IF(IWRITE.NE.11.AND.INDEX(KEYWRD,' NOLOG').EQ.0)THEN 632 IWRITE=11 633 GOTO 170 634 ENDIF 635 NSCF=0 636 RETURN 637 END 638