ABFVCAMM. CUMULATIVE ATOMIC MULTIPOLE MOMENTS AND POINT CHARGE MODELS ABFV0000 1 DESCRIBING MOLECULAR CHARGE DISTRIBUTION. A. SAWARYN, ABFV0000 2 W.A. SOKALSKI. ABFV0000 REF. IN COMP. PHYS. COMMUN. 52 (1989) 397 ABFV0000 C************** NOTE FROM CPC PROGRAM LIBRARY *********************ABFV0001 C* *ABFV0002 C* The test run for this program uses as input, data created by the *ABFV0003 C* ab initio quantum chemistry programs GAUSSIAN-82 or GAUSSIAN-86 *ABFV0004 C* which have been developed by Professor J. Pople and his coworkers *ABFV0005 C* at Carnegie-Mellon University, Pittsburgh, Penns, U.S.A. *ABFV0006 C* If one of these programs is not already available at your computer *ABFV0007 C* installation it can be obtained directly from Professor Pople. *ABFV0008 C* *ABFV0009 C***********************************************************************ABFV0010 PROGRAM CAMM ABFV0011 C This program calculates cumulative atomic multipole moments ABFV0012 C according to the algorithm described by W.A. Sokalski and ABFV0013 C R.A. Poirier, Chem.Phys.Letters 98,86,(1983). ABFV0014 C It is developed as extension of GAUSSIAN-82/GAUSSIAN-86 ABFV0015 C programms. The required input is read from RWFile which has ABFV0016 C to be created in a previous run of GAUSSIAN-82/GAUSSIAN-86. ABFV0017 C A. Sawaryn - Medical University Luebeck, 27-AUG-1987 ABFV0018 C ABFV0019 C This is version compatible with GAUSSIAN-86; it can process ABFV0020 C internally max. 50 atoms and 128 basis functions. ABFV0021 C ABFV0022 IMPLICIT REAL*8(A-H,O-Z) ABFV0023 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0024 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0025 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0026 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0027 C ADIM limits number of atoms; NBAS limits number of basis functionsABFV0028 C GDIM is compatibility parameter and should be set 80/400 ABFV0029 C for G-82/G-86 respectively. ABFV0030 C ABFV0031 CHARACTER RWFNAME*20,DDD*9,TTT*8,TXT(2)*3 ABFV0032 INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON ABFV0033 COMMON /IO/ IN,IOUT,IPUNCH ABFV0034 COMMON /IOP/ IOP(7) ABFV0035 COMMON /LABEL/ LABEL(200),IEL(200),ITITLE(100) ABFV0036 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS, ABFV0037 $ IAN(DIM2),ATMCHG(DIM1),C(3,DIM1) ABFV0038 COMMON /B/ EXX(DIM3),C1(DIM3),C2(DIM3),C3(DIM3), ABFV0039 $ X(GDIM),Y(GDIM),Z(GDIM),JAN(GDIM),SHELLA(GDIM),SHELLN(GDIM), ABFV0040 $ SHELLT(GDIM),SHELLC(GDIM),AOS(GDIM),AON(GDIM),NSHELL,MAXTYP ABFV0041 COMMON/IPURE/ IPURD,IPURF ABFV0042 COMMON/INT/ ZERO,XINT(12) ABFV0043 COMMON/IND/INDJX(35),INDJY(35),INDJZ(35),INDIX(20),INDIY(20), ABFV0044 $ INDIZ(20) ABFV0045 COMMON/CFACT/PT5,R3OV2,ROOT3,ROOT5,ROOT15,R1,R2,R4,Z1,Z2,Z3 ABFV0046 DIMENSION MAXOPR(6),D(35),PT(PDIM),HLP(PDIM) ABFV0047 DIMENSION INDJD(35,3) ABFV0048 DATA MAXOPR/35,20,10,4,1,0/ ABFV0049 DATA INDJD/1,2,1,1,3,1,1,2,2,1,4,1,1,2,3,3,2,1,1,2, ABFV0050 $ 5,1,1,4,4,2,1,2,1,3,3,1,3,2,2, ABFV0051 $ 1,1,2,1,1,3,1,2,1,2,1,4,1,3,2,1,1,2,3,2, ABFV0052 $ 1,5,1,2,1,4,4,1,2,3,1,3,2,3,2, ABFV0053 $ 1,1,1,2,1,1,3,1,2,2,1,1,4,1,1,2,3,3,2,2, ABFV0054 $ 1,1,5,1,2,1,2,4,4,1,3,3,2,2,3/ ABFV0055 DATA TXT/'SCF','CI '/, IN/5/, IOUT/6/, IPUNCH/9/ ABFV0056 CALL DATE(DDD) ABFV0057 CALL TIME(TTT) ABFV0058 C ABFV0059 C Read the RW file name and control parameters. Open RWF. ABFV0060 READ (IN,99) RWFNAME ABFV0061 99 format(A) ABFV0062 READ (IN,98) IOP ABFV0063 98 FORMAT(10I2) ABFV0064 CALL FOPEN(1,2,RWFNAME,0) ABFV0065 CALL FILEIO(24,1,1,0,0) ABFV0066 WRITE(IOUT,999) DDD,TTT(1:5),RWFNAME ABFV0067 999 FORMAT(1H1,20X,'CUMULATIVE ATOMIC MULTIPOLE MOMENTS'/ ABFV0068 & 21X,35(1H*)/30X,A9,3X,A5// ABFV0069 & 11X,'DATA READ FROM: ',A20) ABFV0070 CALL FILEIO(2,-502,250,LABEL,0) ABFV0071 WRITE(IOUT,998) (ITITLE(I),I=1,20) ABFV0072 998 FORMAT(11X,20A4) ABFV0073 WRITE(IOUT,997) TXT(IOP(2)+1) ABFV0074 997 FORMAT(11X,A3,' DENSITY MATRIX USED IN CALCULATIONS') ABFV0075 C ABFV0076 C Read in the required RWF buckets. ABFV0077 LR2=4*DIM1+DIM1/2+4 ABFV0078 CALL FILEIO(2,-997,LR2,NATOMS,0) ABFV0079 LRWB=15*GDIM+(7*GDIM)/2+1 ABFV0080 CALL FILEIO(2,-506,LRWB,EXX,0) ABFV0081 IF(NATOMS.GT.ADIM) THEN ABFV0082 WRITE(IOUT,91) ABFV0083 91 FORMAT(5X,'TOO MANY ATOMS FOR THIS VERSION OF PROGRAM') ABFV0084 STOP 'ADIM' ABFV0085 END IF ABFV0086 IF(NBASIS.GT.NBAS) THEN ABFV0087 WRITE(IOUT,92) ABFV0088 92 FORMAT(5X,'DENSITY MATRIX TOO BIG FOR THIS VERSION OF PROGRAM') ABFV0089 STOP 'NBAS' ABFV0090 END IF ABFV0091 NTT=NBASIS*(NBASIS+1)/2 ABFV0092 IF(IOP(2).EQ.0) THEN ABFV0093 Call FileIO(2,-532,NTT,PT,0) ABFV0094 ELSE ABFV0095 C Get post-SCF density matrices if requested. ABFV0096 CALL FILEIO(2,-203,NTT,PT,0) ABFV0097 CALL FILEIO(11,204,LOPCI,0,0) ABFV0098 IF(LOPCI.GT.0) THEN ABFV0099 CALL FILEIO(2,-204,NTT,HLP,0) ABFV0100 DO 22 I=1,NTT ABFV0101 22 PT(I)=PT(I)+HLP(I) ABFV0102 END IF ABFV0103 END IF ABFV0104 C ABFV0105 C Initialize some variables and arrays. ABFV0106 IDEBUG=IOP(6) ABFV0107 IDUMP=IOP(7) ABFV0108 NMULT=IOP(4) ABFV0109 IF(NMULT.EQ.0) NMULT=1 ABFV0110 MAXOP=MAXOPR(NMULT) ABFV0111 CALL ILSW(4,998,0) ABFV0112 CALL ILSW(2,2,IPURD) ABFV0113 CALL ILSW(2,16,IPURF) ABFV0114 C Initialize /INT/ ABFV0115 ZERO=0.0D0 ABFV0116 DO 10 I=1,12 ABFV0117 10 XINT(I)=FLOAT(I) ABFV0118 C Initialize /IND/ ABFV0119 Call IMove(35,IndJD(1,1),IndJX) ABFV0120 Call IMove(35,IndJD(1,2),IndJY) ABFV0121 Call IMove(35,IndJD(1,3),IndJZ) ABFV0122 DO 30 I=1,20 ABFV0123 INDIX(I)=4*(INDJX(I)-1) ABFV0124 INDIY(I)=4*(INDJY(I)-1) ABFV0125 30 INDIZ(I)=4*(INDJZ(I)-1) ABFV0126 C Initialize /CFACT/. ABFV0127 Pt5 = XInt(1) / XInt(2) ABFV0128 ROOT3=SQRT(XINT(3)) ABFV0129 R3OV2=Pt5*ROOT3 ABFV0130 ROOT5=SQRT(XINT(5)) ABFV0131 ROOT15=SQRT(XINT(10)+XINT(5)) ABFV0132 R1=PT5*SQRT(XINT(5)/XINT(2)) ABFV0133 R2=XINT(3)/(XINT(2)*ROOT5) ABFV0134 R4=PT5*SQRT(XINT(3)/XINT(2)) ABFV0135 Z1=XINT(4)/ROOT5 ABFV0136 Z2=XINT(1)/ROOT5 ABFV0137 Z3=XINT(3)/ROOT5 ABFV0138 CALL SETORD ABFV0139 C ABFV0140 C Go on with calculations ABFV0141 IF(IOP(1).EQ.1) THEN ABFV0142 CALL SUMMUL(NTT,PT,HLP,IDEBUG) ABFV0143 ELSE ABFV0144 CALL CALMUL(IDEBUG,NMULT,MAXOP,IDUMP,PT) ABFV0145 END IF ABFV0146 C ABFV0147 C Calculate nuclear contribution to the multipole moments. ABFV0148 CALL NUCLR(NATOMS,ATMCHG,C,MAXOP) ABFV0149 C ABFV0150 C Output the results ABFV0151 CALL MULOUT(NMULT) ABFV0152 C Calculate point charge representation of the molecule. ABFV0153 IF(IOP(3).EQ.1) CALL POINT(IDUMP) ABFV0154 STOP ABFV0155 END ABFV0156 SUBROUTINE CALMUL(IDEBUG,NMULT,MAXOP,IDUMP,PTOT) ABFV0157 C ABFV0158 C This routine handles the computation of properties at one ABFV0159 C center. Sleazy determines whether loose cutoffs, appropriate ABFV0160 C to mapping the electric potential to 5 or 6 digit accuracy, ABFV0161 C or very tight cutoffs are used. ABFV0162 C ABFV0163 IMPLICIT REAL*8(A-H,O-Z) ABFV0164 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0165 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0166 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0167 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0168 LOGICAL DUMP ABFV0169 DIMENSION PTOT(1) ABFV0170 INTEGER SCONA, SCONB, UBOUND, ULPURE ABFV0171 COMMON/IO/ IN,IOUT,IPUNCH ABFV0172 COMMON/ORDER/NORDR(20),N6ORD(10),N5ORD(9),N10ORD(10),N7ORD(7), ABFV0173 $ LBOUND(4,3),UBOUND(4),ULPURE(4) ABFV0174 INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON ABFV0175 COMMON /B/ EXX(DIM3),C1(DIM3),C2(DIM3),C3(DIM3), ABFV0176 $ X(GDIM),Y(GDIM),Z(GDIM),JAN(GDIM),SHELLA(GDIM),SHELLN(GDIM), ABFV0177 $ SHELLT(GDIM),SHELLC(GDIM),AOS(GDIM),AON(GDIM),NSHELL,MAXTYP ABFV0178 DIMENSION C4(GDIM),SHLADF(GDIM) ABFV0179 EQUIVALENCE(C4(1),C3(DIM1)),(SHLADF(1),C3(DIM4)) ABFV0180 COMMON/MAX/LAMAX,LBMAX,LPMAX ABFV0181 COMMON/LIMIT/IMJ,ISTART,JSTART,IEND,JEND,IRANGE,JRANGE,LENTQ ABFV0182 COMMON/TYPE/ITYPE,JTYPE ABFV0183 COMMON/CFACT/PT5,R3OV2,ROOT3,ROOT5,ROOT15,R1,R2,R4,Z1,Z2,Z3 ABFV0184 COMMON/CONTR/CA(20),CB(20) ABFV0185 COMMON/NEW/INEW,JNEW ABFV0186 COMMON/BLOCK/DD(ADIM,35) ABFV0187 COMMON/IND/INDJX(35),INDJY(35),INDJZ(35),INDIX(20),INDIY(20), ABFV0188 $ INDIZ(20) ABFV0189 COMMON/S/SX(32),SY(32),SZ(32),XS(28),YS(28),ZS(28),XX(24),YY(24), ABFV0190 $ ZZ(24),XXX(20),YYY(20),ZZZ(20),XXXX(16),YYYY(16),ZZZZ(16) ABFV0191 COMMON/INT/Zero,XINT(12) ABFV0192 COMMON/ATMTP/ AC(35,ADIM),ISHELL,JSHELL ABFV0193 DIMENSION S1C(10),CCX(192),CCY(192),CCZ(192) ABFV0194 DATA ARGCUT/600.0D0/, INC/4/ ABFV0195 IF(IDEBUG.EQ.1) RETURN ABFV0196 DUMP=IDUMP.GE.2 ABFV0197 PI=XINT(4)*ATAN(XINT(1)) ABFV0198 TWOPI=PI+PI ABFV0199 ROOTPI=SQRT(PI) ABFV0200 INCMAX=INC ABFV0201 C ABFV0202 C LOOP OVER SHELL PAIRS. ABFV0203 C ABFV0204 ISHST=1 ABFV0205 IF(IDEBUG.LT.0) ISHST=IABS(IDEBUG) ABFV0206 ISHEND=NSHELL ABFV0207 IF(IDEBUG.LT.0) ISHEND=IABS(IDEBUG) ABFV0208 DO 1000 ISHELL = ISHST, ISHEND ABFV0209 INEW = ISHELL ABFV0210 XA = X(ISHELL) ABFV0211 YA = Y(ISHELL) ABFV0212 ZA = Z(ISHELL) ABFV0213 IGBEGN = SHELLA(ISHELL) ABFV0214 IGEND = IGBEGN + SHELLN(ISHELL) - 1 ABFV0215 ITYPE = SHELLT(ISHELL) ABFV0216 LAMAX = ITYPE + 1 ABFV0217 SCONA = SHELLC(ISHELL) ABFV0218 IEND = UBOUND(LAMAX) ABFV0219 ISTART = LBOUND(LAMAX,SCONA+1) ABFV0220 IRANGE = IEND - ISTART + 1 ABFV0221 IGDF = SHLADF(INEW) ABFV0222 DO 1000 JSHELL = ISHST,ISHELL ABFV0223 JNEW = JSHELL ABFV0224 XB = X(JSHELL) ABFV0225 YB = Y(JSHELL) ABFV0226 ZB = Z(JSHELL) ABFV0227 JGBEGN = SHELLA(JSHELL) ABFV0228 JGEND = JGBEGN + SHELLN(JSHELL) - 1 ABFV0229 JTYPE = SHELLT(JSHELL) ABFV0230 LBMAX = JTYPE + 1 ABFV0231 SCONB = SHELLC(JSHELL) ABFV0232 IEND = UBOUND(LAMAX) ABFV0233 ISTART = LBOUND(LAMAX,SCONA+1) ABFV0234 IRANGE = IEND - ISTART + 1 ABFV0235 JSTART = LBOUND(LBMAX,SCONB+1) ABFV0236 JEND = UBOUND(LBMAX) ABFV0237 JRANGE = JEND - JSTART + 1 ABFV0238 JGDF = SHLADF(JNEW) ABFV0239 LPMAX = LAMAX + LBMAX - 1 ABFV0240 LENTQ = IRANGE * JRANGE ABFV0241 LIM1DS = (LPMAX + INC + 1) / 2 ABFV0242 IMJ = IABS(ISHELL - JSHELL) ABFV0243 ABX = XB - XA ABFV0244 ABY = YB - YA ABFV0245 ABZ = ZB - ZA ABFV0246 RABSQ = ABX * ABX + ABY * ABY + ABZ * ABZ ABFV0247 DO 100 I=1,ADIM ABFV0248 DO 100 J=1,35 ABFV0249 100 DD(I,J)=ZERO ABFV0250 C ABFV0251 C LOOP OVER PRIMITIVE GAUSSIANS. ABFV0252 C ABFV0253 DO 900 IGAUSS = IGBEGN, IGEND ABFV0254 AS = EXX(IGAUSS) ABFV0255 ASXA = AS * XA ABFV0256 ASYA = AS * YA ABFV0257 ASZA = AS * ZA ABFV0258 ARABSQ = AS * RABSQ ABFV0259 CALL FILLC(ITYPE,IGBEGN,IGAUSS,IGDF,CA) ABFV0260 DO 900 JGAUSS = JGBEGN,JGEND ABFV0261 BS = EXX(JGAUSS) ABFV0262 CALL FILLC(JTYPE,JGBEGN,JGAUSS,JGDF,CB) ABFV0263 EP = AS + BS ABFV0264 EPI = XInt(1) / EP ABFV0265 EPIO2 = EPI * Pt5 ABFV0266 TWOP = EP + EP ABFV0267 EXPARG = BS * ARABSQ * EPI ABFV0268 IF(EXPARG.GE.ARGCUT) GOTO 900 ABFV0269 PEXP = EXP(-EXPARG) ABFV0270 ZT = TWOPI * EPI * PEXP ABFV0271 C IF(IDUMP.GE.2) WRITE(IOUT,9000) IGAUSS, JGAUSS ABFV0272 PX = (ASXA + BS * XB) * EPI ABFV0273 PY = (ASYA + BS * YB) * EPI ABFV0274 PZ = (ASZA + BS * ZB) * EPI ABFV0275 XAP = PX - XA ABFV0276 XBP = PX - XB ABFV0277 YAP = PY - YA ABFV0278 YBP = PY - YB ABFV0279 ZAP = PZ - ZA ABFV0280 ZBP = PZ - ZB ABFV0281 CALL GETCC1(CCX,XAP,XBP,INCMAX) ABFV0282 CALL GETCC1(CCY,YAP,YBP,INCMAX) ABFV0283 CALL GETCC1(CCZ,ZAP,ZBP,INCMAX) ABFV0284 C ABFV0285 C GET THE ONE-DIMENSIONAL OVERLAP INTEGRALS. ABFV0286 STERM = ROOTPI * SQRT(EPI) ABFV0287 CALL GET1CS(S1C,STERM,EPIO2,INC) ABFV0288 CALL GET2CS(SX,S1C,CCX,INC) ABFV0289 CALL GET2CS(SY,S1C,CCY,INC) ABFV0290 DO 200 I1C = 1, LIM1DS ABFV0291 200 S1C(I1C) = S1C(I1C) * PEXP ABFV0292 CALL GET2CS(SZ,S1C,CCZ,INC) ABFV0293 CALL GET1DS(NMULT,LAMAX,LBMAX,SX,XS,XX,XXX,XXXX,XA) ABFV0294 C If(Dump) CALL DMP1DS(IOUT,NMULT,LAMAX,LBMAX, ABFV0295 C $ SX,XS,XX,XXX,XXXX,XA) ABFV0296 CALL GET1DS(NMULT,LAMAX,LBMAX,SY,YS,YY,YYY,YYYY,YA) ABFV0297 C If(Dump) CALL DMP1DS(IOUT,NMULT,LAMAX,LBMAX, ABFV0298 C $ SY,YS,YY,YYY,YYYY,YA) ABFV0299 CALL GET1DS(NMULT,LAMAX,LBMAX,SZ,ZS,ZZ,ZZZ,ZZZZ,ZA) ABFV0300 C If(Dump) CALL DMP1DS(IOUT,NMULT,LAMAX,LBMAX, ABFV0301 C $ SZ,ZS,ZZ,ZZZ,ZZZZ,ZA) ABFV0302 CALL GET3DS(NMULT) ABFV0303 900 CONTINUE ABFV0304 C ABFV0305 C CONVERT INTEGRALS IN COMMON/BLOCK/ FROM SECOND AND THIRD ORDER ABFV0306 C GAUSSIANS INTO THE PURE D AND F FUNCTIONS. ABFV0307 C ABFV0308 IND=IEND ABFV0309 JND=JEND ABFV0310 IR=IRANGE ABFV0311 JR=JRANGE ABFV0312 DO 300 I=1,MAXOP ABFV0313 IEND=IND ABFV0314 JEND=JND ABFV0315 IRANGE=IR ABFV0316 JRANGE=JR ABFV0317 CALL PURDF1(DD(1,I)) ABFV0318 300 CONTINUE ABFV0319 C ABFV0320 CALL PCONTR(IDUMP,NMULT,MAXOP,PTOT) ABFV0321 1000 CONTINUE ABFV0322 RETURN ABFV0323 END ABFV0324 SUBROUTINE GET3DS(NMULT) ABFV0325 IMPLICIT REAL*8(A-H,O-Z) ABFV0326 C ABFV0327 C THIS SUBROUTINE CALCULATES THE THREE DIMENSIONAL MULTIPOLE ABFV0328 C INTEGRALS AND STORES THESE IN COMMON/BLOCK/. THESE ABFV0329 C INTEGRALS ARE GIVEN AS PRODUCTS OF APPROPRIATE ELEMENTS ABFV0330 C OF COMMON /S/. ABFV0331 C ABFV0332 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0333 COMMON/LIMIT/IMJ,ISTART,JSTART,IEND,JEND,IRANGE,JRANGE,LENTQ ABFV0334 COMMON/BLOCK/DS(ADIM),DX(ADIM),DY(ADIM),DZ(ADIM), ABFV0335 $ DXX(ADIM),DYY(ADIM),DZZ(ADIM),DXY(ADIM),DXZ(ADIM),DYZ(ADIM), ABFV0336 $ DXXX(ADIM),DYYY(ADIM),DZZZ(ADIM),DXYY(ADIM),DXXY(ADIM), ABFV0337 $ DXXZ(ADIM),DXZZ(ADIM),DYZZ(ADIM),DYYZ(ADIM),DXYZ(ADIM), ABFV0338 $ DXXXX(ADIM),DYYYY(ADIM),DZZZZ(ADIM),DXXXY(ADIM),DXXXZ(ADIM), ABFV0339 $ DYYYX(ADIM),DYYYZ(ADIM),DZZZX(ADIM),DZZZY(ADIM),DXXYY(ADIM), ABFV0340 $ DXXZZ(ADIM),DYYZZ(ADIM),DXXYZ(ADIM),DYYXZ(ADIM),DZZXY(ADIM) ABFV0341 COMMON/CONTR/CA(20),CB(20) ABFV0342 COMMON/S/SX(32),SY(32),SZ(32),X(28),Y(28),Z(28),XX(24),YY(24), ABFV0343 $ ZZ(24),XXX(20),YYY(20),ZZZ(20),XXXX(16),YYYY(16),ZZZZ(16) ABFV0344 COMMON/IND/INDJX(35),INDJY(35),INDJZ(35),INDIX(20),INDIY(20), ABFV0345 $ INDIZ(20) ABFV0346 C ABFV0347 INC=0 ABFV0348 DO 220 I=ISTART,IEND ABFV0349 IX=INDIX(I) ABFV0350 IY=INDIY(I) ABFV0351 IZ=INDIZ(I) ABFV0352 DO 220 J=JSTART,JEND ABFV0353 JX=INDJX(J)+IX ABFV0354 JY=INDJY(J)+IY ABFV0355 JZ=INDJZ(J)+IZ ABFV0356 C ABFV0357 COEF=CA(I)*CB(J) ABFV0358 INC=INC+1 ABFV0359 GOTO (170,180,190,200,210,230), NMULT ABFV0360 C ABFV0361 170 DZZXY(INC)=DZZXY(INC)+COEF*X(JX)*Y(JY)*ZZ(JZ) ABFV0362 DYYXZ(INC)=DYYXZ(INC)+COEF*X(JX)*YY(JY)*Z(JZ) ABFV0363 DXXYZ(INC)=DXXYZ(INC)+COEF*XX(JX)*Y(JY)*Z(JZ) ABFV0364 DYYZZ(INC)=DYYZZ(INC)+COEF*SX(JX)*YY(JY)*ZZ(JZ) ABFV0365 DXXZZ(INC)=DXXZZ(INC)+COEF*XX(JX)*SY(JY)*ZZ(JZ) ABFV0366 DXXYY(INC)=DXXYY(INC)+COEF*XX(JX)*YY(JY)*SZ(JZ) ABFV0367 DZZZY(INC)=DZZZY(INC)+COEF*SX(JX)*Y(JY)*ZZZ(JZ) ABFV0368 DZZZX(INC)=DZZZX(INC)+COEF*X(JX)*SY(JY)*ZZZ(JZ) ABFV0369 DYYYZ(INC)=DYYYZ(INC)+COEF*SX(JX)*YYY(JY)*Z(JZ) ABFV0370 DYYYX(INC)=DYYYX(INC)+COEF*X(JX)*YYY(JY)*SZ(JZ) ABFV0371 DXXXZ(INC)=DXXXZ(INC)+COEF*XXX(JX)*SY(JY)*Z(JZ) ABFV0372 DXXXY(INC)=DXXXY(INC)+COEF*XXX(JX)*Y(JY)*SZ(JZ) ABFV0373 DZZZZ(INC)=DZZZZ(INC)+COEF*SX(JX)*SY(JY)*ZZZZ(JZ) ABFV0374 DYYYY(INC)=DYYYY(INC)+COEF*SX(JX)*YYYY(JY)*SZ(JZ) ABFV0375 DXXXX(INC)=DXXXX(INC)+COEF*XXXX(JX)*SY(JY)*SZ(JZ) ABFV0376 C ABFV0377 180 DXYZ(INC)=DXYZ(INC)+COEF*X(JX)*Y(JY)*Z(JZ) ABFV0378 DYYZ(INC)=DYYZ(INC)+COEF*SX(JX)*YY(JY)*Z(JZ) ABFV0379 DYZZ(INC)=DYZZ(INC)+COEF*SX(JX)*Y(JY)*ZZ(JZ) ABFV0380 DXZZ(INC)=DXZZ(INC)+COEF*X(JX)*SY(JY)*ZZ(JZ) ABFV0381 DXXZ(INC)=DXXZ(INC)+COEF*XX(JX)*SY(JY)*Z(JZ) ABFV0382 DXXY(INC)=DXXY(INC)+COEF*XX(JX)*Y(JY)*SZ(JZ) ABFV0383 DXYY(INC)=DXYY(INC)+COEF*X(JX)*YY(JY)*SZ(JZ) ABFV0384 DZZZ(INC)=DZZZ(INC)+COEF*SX(JX)*SY(JY)*ZZZ(JZ) ABFV0385 DYYY(INC)=DYYY(INC)+COEF*SX(JX)*YYY(JY)*SZ(JZ) ABFV0386 DXXX(INC)=DXXX(INC)+COEF*XXX(JX)*SY(JY)*SZ(JZ) ABFV0387 C ABFV0388 190 DYZ(INC)=DYZ(INC)+COEF*SX(JX)*Y(JY)*Z(JZ) ABFV0389 DXZ(INC)=DXZ(INC)+COEF*X(JX)*SY(JY)*Z(JZ) ABFV0390 DXY(INC)=DXY(INC)+COEF*X(JX)*Y(JY)*SZ(JZ) ABFV0391 DZZ(INC)=DZZ(INC)+COEF*SX(JX)*SY(JY)*ZZ(JZ) ABFV0392 DYY(INC)=DYY(INC)+COEF*SX(JX)*YY(JY)*SZ(JZ) ABFV0393 DXX(INC)=DXX(INC)+COEF*XX(JX)*SY(JY)*SZ(JZ) ABFV0394 C ABFV0395 200 DZ(INC)=DZ(INC)+COEF*SX(JX)*SY(JY)*Z(JZ) ABFV0396 DY(INC)=DY(INC)+COEF*SX(JX)*Y(JY)*SZ(JZ) ABFV0397 DX(INC)=DX(INC)+COEF*X(JX)*SY(JY)*SZ(JZ) ABFV0398 C ABFV0399 210 DS(INC)=DS(INC)+COEF*SX(JX)*SY(JY)*SZ(JZ) ABFV0400 C ABFV0401 220 CONTINUE ABFV0402 230 RETURN ABFV0403 END ABFV0404 SUBROUTINE SETORD ABFV0405 IMPLICIT REAL*8(A-H,O-Z) ABFV0406 C ABFV0407 C ROUTINE TO FILL /ORDER/ SO AS TO ASSIGN THE BASIS FUNCTION ABFV0408 C ORDER. THE ARRANGEMENT OF THE BASIS FUNCTIONS CAN ABFV0409 C BE EASILY ALTERED BY RE-ASSIGNING THE NUMBERS IN THE ARRAYS ABFV0410 C N6ORD, N10ORD, ETC. ABFV0411 C ABFV0412 INTEGER UBOUND,ULPURE ABFV0413 COMMON/IPURE/IPURD,IPURF ABFV0414 COMMON/ORDER/NORDR(20),N6ORD(10),N5ORD(9),N10ORD(10),N7ORD(7), ABFV0415 $ LBOUND(4,3),UBOUND(4),ULPURE(4) ABFV0416 Dimension InUB(4), InUL(4), InLB(12), In6(10), In5(9), In10(10), ABFV0417 $ In7(7) ABFV0418 Data InUB/1,4,10,20/, InUL/1,4,9,17/,InLB/5*1,2,5,11,1,1,5,11/, ABFV0419 $ In6/1,2,3,4,5,6,7,8,9,10/,In5/1,2,3,4,5,6,7,8,9/ ABFV0420 $ In10/11,12,13,14,15,16,17,18,19,20/,In7/11,12,13,14,15,16,17/ABFV0421 C ABFV0422 Call IMove(4,InUB,UBound) ABFV0423 Call IMove(4,InUL,ULPure) ABFV0424 Call IMove(12,InLB,LBound) ABFV0425 Call IMove(10,In6,N6Ord) ABFV0426 Call IMove(9,In5,N5Ord) ABFV0427 Call IMove(10,In10,N10Ord) ABFV0428 Call IMove(7,In7,N7Ord) ABFV0429 C ABFV0430 C INITIALIZE THE ORDERING VARIABLES USED BY FILMAT. ABFV0431 C THIS PIECE OF CODE MAY LOOK REDUNDANT, BUT HANG ON TO IT. ABFV0432 C ONE CAN USE THIS LOGIC TO ALTER THE ORDER OF THE BASIS FUNCTIONS. ABFV0433 C (IE. CHANGE THE ORDER OF THE SIX D-FUNCTIONES, ETC.) ABFV0434 IF(IPURD)75,70,75 ABFV0435 70 DO 71 I=1,9 ABFV0436 71 NORDR(I)=N5ORD(I) ABFV0437 GO TO 77 ABFV0438 75 DO 76 I=1,10 ABFV0439 76 NORDR(I)=N6ORD(I) ABFV0440 77 IF(IPURF)85,81,85 ABFV0441 81 DO 82 I=1,7 ABFV0442 82 NORDR(I+10)=N7ORD(I) ABFV0443 GO TO 87 ABFV0444 85 DO 86 I=1,10 ABFV0445 86 NORDR(I+10)=N10ORD(I) ABFV0446 87 CONTINUE ABFV0447 RETURN ABFV0448 END ABFV0449 SUBROUTINE NUCLR(NATOMS,ATMCHG,C,MAXOP) ABFV0450 IMPLICIT REAL*8(A-H,O-Z) ABFV0451 C ABFV0452 C THIS SUBROUTINE CALCULATES THE NUCLEAR CONTRIBUTION TO ABFV0453 C THE MULTIPOLE MOMENTS, AND ADDS THESE TO THE APPROPRIATE ABFV0454 C VALUES IN D. ABFV0455 C ABFV0456 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0457 DIMENSION ATMCHG(1), C(3,1) ABFV0458 COMMON/MLTPOL/ D(35) ABFV0459 COMMON/IND/INDJX(35),INDJY(35),INDJZ(35), ABFV0460 $ INDIX(20),INDIY(20),INDIZ(20) ABFV0461 COMMON/ATMTP/ AC(35,ADIM),ISHELL,JSHELL ABFV0462 DIMENSION AXPWR(5),AYPWR(5),AZPWR(5) ABFV0463 DATA ONE/1.0D0/ ABFV0464 C ABFV0465 DO 10 I=1,MAXOP ABFV0466 10 D(I)=-D(I) ABFV0467 DO 400 IATOM=1,NATOMS ABFV0468 AX=C(1,IATOM) ABFV0469 AY=C(2,IATOM) ABFV0470 AZ=C(3,IATOM) ABFV0471 AXPWR(1)=ONE ABFV0472 AYPWR(1)=ONE ABFV0473 AZPWR(1)=ONE ABFV0474 DO 200 I=2,5 ABFV0475 AXPWR(I)=AXPWR(I-1)*AX ABFV0476 AYPWR(I)=AYPWR(I-1)*AY ABFV0477 200 AZPWR(I)=AZPWR(I-1)*AZ ABFV0478 DO 300 I=1,MAXOP ABFV0479 IX=INDJX(I) ABFV0480 IY=INDJY(I) ABFV0481 IZ=INDJZ(I) ABFV0482 ACX=AXPWR(IX)*AYPWR(IY)*AZPWR(IZ)*ATMCHG(IATOM) ABFV0483 AC(I,IATOM)=ACX-AC(I,IATOM) ABFV0484 300 D(I)=D(I)+ACX ABFV0485 400 CONTINUE ABFV0486 RETURN ABFV0487 END ABFV0488 SUBROUTINE PCONTR(IDUMP,NMULT,MAXOP,P) ABFV0489 C ABFV0490 C THIS SUBROUTINE MULTIPLIES THE INTEGRALS IN COMMON/BLOCK/ ABFV0491 C BY THE APPROPRIATE ELEMENTS OF THE DENSITY MATRIX AND SUMS THE ABFV0492 C RESULTS INTO THE PROPER PLACES IN COMMON/MLTPOL/. ABFV0493 C ABFV0494 IMPLICIT REAL*8(A-H,O-Z) ABFV0495 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0496 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0497 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0498 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0499 INTEGER SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON ABFV0500 COMMON /B/ EXX(DIM3),C1(DIM3),C2(DIM3),C3(DIM3), ABFV0501 $ X(GDIM),Y(GDIM),Z(GDIM),JAN(GDIM),SHELLA(GDIM),SHELLN(GDIM), ABFV0502 $ SHELLT(GDIM),SHELLC(GDIM),AOS(GDIM),AON(GDIM),NSHELL,MAXTYP ABFV0503 COMMON/NEW/INEW,JNEW ABFV0504 COMMON/ORDER/NORDR(20) ABFV0505 COMMON/MLTPOL/D(35) ABFV0506 COMMON/BLOCK/DD(ADIM,35) ABFV0507 COMMON/LIMIT/IMJ,ISTART,JSTART,IEND,JEND,IRANGE,JRANGE,LENTQ ABFV0508 COMMON/ATMTP/ AC(35,ADIM),ISHELL,JSHELL ABFV0509 DIMENSION P(1) ABFV0510 DATA ONE/1.0D0/, TWO/2.0D0/ ABFV0511 LIND(I,J)=(I*(I-1))/2+J ABFV0512 C ABFV0513 C IF(IDUMP.NE.0) CALL DMPBLK(MAXOP,0,1) ABFV0514 IA=JAN(ISHELL) ABFV0515 IB=JAN(JSHELL) ABFV0516 INC=0 ABFV0517 IND=AOS(INEW)-1 ABFV0518 JND=AOS(JNEW)-1 ABFV0519 DO 800 II=ISTART,IEND ABFV0520 I=NORDR(II) ABFV0521 INDI=LIND(IND+I,JND) ABFV0522 DO 800 JJ=JSTART,JEND ABFV0523 J=NORDR(JJ) ABFV0524 INC=INC+1 ABFV0525 IF(IMJ)300,100,300 ABFV0526 100 A=ONE ABFV0527 IF(I-J)200,350,350 ABFV0528 200 INDP=LIND(JND+J,I+IND) ABFV0529 GO TO 400 ABFV0530 300 A=TWO ABFV0531 350 INDP=INDI+J ABFV0532 C ABFV0533 400 IF(ABS(P(INDP)).LE.1.D-10) GO TO 800 ABFV0534 P1=P(INDP)*A ABFV0535 IF(NMULT.EQ.6) GO TO 800 ABFV0536 DO 500 MOMNT=1,MAXOP ABFV0537 C ABFV0538 D(MOMNT)=D(MOMNT)+P1*DD(INC,MOMNT) ABFV0539 PP1=P1*DD(INC,MOMNT) ABFV0540 IF(IA.NE.IB) PP1=PP1/TWO ABFV0541 AC(MOMNT,IA)=AC(MOMNT,IA)+PP1 ABFV0542 IF(IA.NE.IB) AC(MOMNT,IB) = AC(MOMNT,IB) + PP1 ABFV0543 500 CONTINUE ABFV0544 800 CONTINUE ABFV0545 RETURN ABFV0546 END ABFV0547 SUBROUTINE SUMMUL(NTT,P,RMI,IDUMP) ABFV0548 C ABFV0549 C THIS SUBROUTINE MULTIPLIES THE MULTIPOLE INTEGRALS BY ABFV0550 C THE APPROPRIATE ELEMENTS OF THE DENSITY MATRIX AND SUMS ABFV0551 C THE RESULTS INTO THE PROPER PLACES IN COMMON/MLTPOL/ AND ABFV0552 C COMMON/ATMTP/. ABFV0553 C Andrzej Sawaryn - MU Luebeck, 7-SEP-1987. ABFV0554 C ABFV0555 IMPLICIT REAL*8(A-H,O-Z) ABFV0556 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0557 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0558 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0559 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0560 INTEGER SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON ABFV0561 LOGICAL DUMP ABFV0562 COMMON/IO/ IN,IOUT,IPUNCH ABFV0563 COMMON /B/ EXX(DIM3),C1(DIM3),C2(DIM3),C3(DIM3), ABFV0564 $ X(GDIM),Y(GDIM),Z(GDIM),JAN(GDIM),SHELLA(GDIM),SHELLN(GDIM), ABFV0565 $ SHELLT(GDIM),SHELLC(GDIM),AOS(GDIM),AON(GDIM),NSHELL,MAXTYP ABFV0566 COMMON/IPURE/IPURD,IPURF ABFV0567 COMMON/MLTPOL/D(35) ABFV0568 COMMON/ATMTP/ AC(35,ADIM),ISHELL,JSHELL ABFV0569 DIMENSION RMI(1),P(1),IBTAB(NBAS),NF(3,4) ABFV0570 DATA ONE/1.0d0/ ,TWO/2.0d0/ ABFV0571 DATA NF/1,0,1,4,3,4,10,0,6,0,0,10/ ABFV0572 C Conversion table: function number into atom number ABFV0573 NF(1,3)=9+IPURD ABFV0574 NF(3,3)=5+IPURD ABFV0575 NF(3,4)=7+3*IPURF ABFV0576 IBX=0 ABFV0577 DO 50 I=1,NSHELL ABFV0578 NFX=NF(SHELLC(I)+1,SHELLT(I)+1) ABFV0579 DO 50 J=1,NFX ABFV0580 IBX=IBX+1 ABFV0581 50 IBTAB(IBX)=JAN(I) ABFV0582 IF(IDUMP.NE.0) WRITE(IOUT,97) (IBTAB(I),I=1,IBX) ABFV0583 97 FORMAT(' IBTAB ',50I2) ABFV0584 C Main loop over multipole moments ABFV0585 DO 100 M=1,35 ABFV0586 DUMP=.FALSE. ABFV0587 IF(M.EQ.IDUMP) DUMP=.TRUE. ABFV0588 IF(M.EQ.1) THEN ABFV0589 CALL FILEIO(2,514,NTT,RMI,0) ABFV0590 ELSE ABFV0591 CALL FILEIO(2,518,NTT,RMI,0) ABFV0592 END IF ABFV0593 ID=1 ABFV0594 IDI=2 ABFV0595 IBF=1 ABFV0596 JBF=0 ABFV0597 IF(DUMP) WRITE(IOUT,98) ABFV0598 DO 200 I=1,NTT ABFV0599 IA=IBTAB(IBF) ABFV0600 JBF=JBF+1 ABFV0601 IB=IBTAB(JBF) ABFV0602 FC=TWO ABFV0603 IF(DUMP) WRITE(IOUT,99) I,IBF,JBF,ISHELL,JSHELL,IA,IB,P(I),RMI(I) ABFV0604 IF(I.EQ.ID) THEN ABFV0605 ID=ID+IDI ABFV0606 IDI=IDI+1 ABFV0607 IBF=IBF+1 ABFV0608 JBF=0 ABFV0609 FC=ONE ABFV0610 END IF ABFV0611 PD=FC*P(I)*RMI(I) ABFV0612 D(M)=D(M)+PD ABFV0613 IF(IA.NE.IB) PD=PD/TWO ABFV0614 AC(M,IA)=AC(M,IA)+PD ABFV0615 IF(IA.NE.IB) AC(M,IB)=AC(M,IB)+PD ABFV0616 200 CONTINUE ABFV0617 100 CONTINUE ABFV0618 99 FORMAT(5X,7I5,3E20.10) ABFV0619 98 FORMAT(9X,'I',2X,'IBF',2X,'JBF ISHL JSHL', ABFV0620 & 3X,'IA',3X,'IB',10X,'P',19X,'MI') ABFV0621 RETURN ABFV0622 END ABFV0623 SUBROUTINE MULOUT(NMULT) ABFV0624 C ABFV0625 C WRITE OUT THE MULTIPOLE EXPECTATIONS HELD IN D. ABFV0626 C ABFV0627 IMPLICIT REAL*8(A-H,O-Z) ABFV0628 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0629 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0630 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0631 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0632 CHARACTER*6 ASYMB,SYMB(ADIM) ABFV0633 COMMON/IOP/ IOP(7) ABFV0634 COMMON/IO/ IN,IOUT,IPUNCH ABFV0635 COMMON/MOL/NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS, ABFV0636 & IAN(DIM2),ATMCHG(DIM1),C(3,DIM1) ABFV0637 COMMON/ATMTP/ A(35,ADIM),ISHELL,JSHELL ABFV0638 COMMON/MLTPOL/ D(35) ABFV0639 DIMENSION TL(35),LABELS(35),TLS(16,ADIM) ABFV0640 DATA ZERO,HALF,ONE,TWO,THREE,FOUR,TEN ABFV0641 & /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,4.0D0,10.0D0/ ABFV0642 DATA SIX/6.0D0/,ONEHALF/1.5D0/,TWOHALF/2.5D0/,SMALL/1.0D-10/ ABFV0643 DATA CP1,CP3,CP6,CP7,C18,C33,C37/0.125D0,0.375D0,0.625D0, ABFV0644 & 0.75D0,1.875D0,3.375D0,3.75D0/ ABFV0645 DATA LABELS/4h ,4hX ,4hY ,4hZ , ABFV0646 1 4hXX ,4hYY ,4hZZ ,4hXY ,4hXZ ,4hYZ , ABFV0647 2 4hXXX ,4hYYY ,4hZZZ ,4hXYY ,4hXXY ,4hXXZ , ABFV0648 3 4hXZZ ,4hYZZ ,4hYYZ ,4hXYZ , ABFV0649 4 4hXXXX,4hYYYY,4hZZZZ,4hXXXY,4hXXXZ,4hYYYX,4hYYYZ,4hZZZX, ABFV0650 5 4hZZZY,4hXXYY,4hXXZZ,4hYYZZ,4hXXYZ,4hYYXZ,4hZZXY/ ABFV0651 C ABFV0652 1000 FORMAT(' MOLECULAR CHARGE') ABFV0653 1005 FORMAT(' MOLECULAR DIPOLE MOMENT') ABFV0654 1010 FORMAT(' MOLECULAR SECOND MOMENT') ABFV0655 1015 FORMAT(' TRACELESS MOLECULAR QUADRUPOLES') ABFV0656 1020 FORMAT(' MOLECULAR THIRD MOMENT') ABFV0657 1025 FORMAT(' TRACELESS MOLECULAR OCTUPOLES') ABFV0658 1030 FORMAT(' MOLECULAR FOURTH MOMENT') ABFV0659 1035 FORMAT(' TRACELESS MOLECULAR HEXADECAPOLES') ABFV0660 1040 FORMAT(' ATOMIC CHARGES') ABFV0661 1050 FORMAT(' ATOMIC DIPOLES') ABFV0662 1060 FORMAT(' ATOMIC SECOND MOMENTS') ABFV0663 1070 FORMAT(' ATOMIC THIRD MOMENTS') ABFV0664 1080 FORMAT(' ATOMIC FOURTH MOMENTS') ABFV0665 1090 FORMAT(' TRACELESS ATOMIC QUADRUPOLES') ABFV0666 1100 FORMAT(' TRACELESS ATOMIC OCTUPOLES') ABFV0667 1110 FORMAT(' TRACELESS ATOMIC HEXADECAPOLES') ABFV0668 2000 FORMAT(10X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8) ABFV0669 2001 FORMAT(2X,A6,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8) ABFV0670 2002 FORMAT(2X,A6,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8, ABFV0671 & /,(10X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8,2X,A4,2H= ,F15.8)) ABFV0672 C ABFV0673 C CLEAR SMALL VALUES OF MULTIPOLES. ABFV0674 DO 5 M=1,35 ABFV0675 IF(ABS(D(M)).LT.SMALL) D(M)=ZERO ABFV0676 DO 5 N=1,NATOMS ABFV0677 IF(ABS(A(M,N)).LT.SMALL) A(M,N)=ZERO ABFV0678 5 CONTINUE ABFV0679 C ABFV0680 C MOLECULAR CHARGE. ABFV0681 WRITE(IOUT,1000) ABFV0682 WRITE(IOUT,2000) LABELS(1), D(1) ABFV0683 C ABFV0684 C ATOMIC MONOPOLES (MULLIKEN CHARGES). ABFV0685 WRITE(IOUT,1040) ABFV0686 DO 10 I=1,NATOMS ABFV0687 SYMB(I)=ASYMB(IAN(I),I) ABFV0688 10 WRITE(IOUT,2001) SYMB(I),LABELS(1),A(1,I) ABFV0689 IF(NMULT.EQ.5) RETURN ABFV0690 C ABFV0691 C MOLECULAR DIPOLE MOMENT. ABFV0692 WRITE(IOUT,1005) ABFV0693 WRITE(IOUT,2000) (LABELS(I),D(I),I=2,4) ABFV0694 C ABFV0695 C ATOMIC DIPOLES. ABFV0696 WRITE(IOUT,1050) ABFV0697 DO 40 I=1,NATOMS ABFV0698 DO 30 J=1,3 ABFV0699 30 A(J+1,I)=A(J+1,I)-A(1,I)*C(J,I) ABFV0700 40 WRITE(IOUT,2001) SYMB(I),(LABELS(J),A(J,I),J=2,4) ABFV0701 IF(NMULT.EQ.4) RETURN ABFV0702 C ABFV0703 C MOLECULAR SECOND MOMENT. ABFV0704 WRITE(IOUT,1010) ABFV0705 WRITE(IOUT,2000)(LABELS(I),D(I),I=5,10) ABFV0706 C ABFV0707 C TRACELESS MOLECULAR QUADRUPOLES. ABFV0708 WRITE(IOUT,1015) ABFV0709 TL(5)=D(5)-HALF*(D(6)+D(7)) ABFV0710 TL(6)=D(6)-HALF*(D(5)+D(7)) ABFV0711 TL(7)=D(7)-HALF*(D(5)+D(6)) ABFV0712 TL(8)=ONEHALF*D(8) ABFV0713 TL(9)=ONEHALF*D(9) ABFV0714 TL(10)=ONEHALF*D(10) ABFV0715 WRITE(IOUT,2000)(LABELS(J),TL(J),J=5,10) ABFV0716 C ABFV0717 C ATOMIC SECOND MOMENTS. ABFV0718 WRITE(IOUT,1060) ABFV0719 DO 70 I=1,NATOMS ABFV0720 DO 60 J=1,3 ABFV0721 60 A(J+4,I)=A(J+4,I)-A(1,I)*C(J,I)**2-TWO*A(J+1,I)*C(J,I) ABFV0722 A(8,I)=A(8,I)-A(1,I)*C(1,I)*C(2,I)-A(2,I)*C(2,I)-A(3,I)*C(1,I) ABFV0723 A(9,I)=A(9,I)-A(1,I)*C(1,I)*C(3,I)-A(2,I)*C(3,I)-A(4,I)*C(1,I) ABFV0724 A(10,I)=A(10,I)-A(1,I)*C(2,I)*C(3,I)-A(3,I)*C(3,I)-A(4,I)*C(2,I) ABFV0725 70 WRITE(IOUT,2002) SYMB(I),(LABELS(J),A(J,I),J=5,10) ABFV0726 C ABFV0727 C TRACELESS ATOMIC QUADRUPOLE MOMENTS. ABFV0728 WRITE(IOUT,1090) ABFV0729 DO 75 I=1,NATOMS ABFV0730 TL(5)=A(5,I)-HALF*(A(6,I)+A(7,I)) ABFV0731 TL(6)=A(6,I)-HALF*(A(5,I)+A(7,I)) ABFV0732 TL(7)=A(7,I)-HALF*(A(5,I)+A(6,I)) ABFV0733 TL(8)=ONEHALF*A(8,I) ABFV0734 TL(9)=ONEHALF*A(9,I) ABFV0735 TL(10)=ONEHALF*A(10,I) ABFV0736 DO 76 J=1,6 ABFV0737 76 TLS(J,I)=TL(J+4) ABFV0738 75 WRITE(IOUT,2002) SYMB(I),(LABELS(J),TL(J),J=5,10) ABFV0739 IF(NMULT.EQ.3) RETURN ABFV0740 C ABFV0741 C MOLECULAR THIRD MOMENT. ABFV0742 WRITE(IOUT,1020) ABFV0743 WRITE(IOUT,2000)(LABELS(I),D(I),I=11,20) ABFV0744 C ABFV0745 C TRACELESS MOLECULAR OCTUPOLES. ABFV0746 WRITE(IOUT,1025) ABFV0747 TL(11)=D(11)-ONEHALF*(D(14)+D(17)) ABFV0748 TL(12)=D(12)-ONEHALF*(D(15)+D(18)) ABFV0749 TL(13)=D(13)-ONEHALF*(D(16)+D(19)) ABFV0750 TL(14)=TWO*D(14)-HALF*(D(11)+D(17)) ABFV0751 TL(15)=TWO*D(15)-HALF*(D(12)+D(18)) ABFV0752 TL(16)=TWO*D(16)-HALF*(D(13)+D(19)) ABFV0753 TL(17)=TWO*D(17)-HALF*(D(11)+D(14)) ABFV0754 TL(18)=TWO*D(18)-HALF*(D(12)+D(15)) ABFV0755 TL(19)=TWO*D(19)-HALF*(D(13)+D(16)) ABFV0756 TL(20)=TWOHALF*D(20) ABFV0757 WRITE(IOUT,2000) (LABELS(I),TL(I),I=11,20) ABFV0758 C ABFV0759 C ATOMIC THIRD MOMENTS. ABFV0760 WRITE(IOUT,1070) ABFV0761 DO 100 I=1,NATOMS ABFV0762 X=C(1,I) ABFV0763 Y=C(2,I) ABFV0764 Z=C(3,I) ABFV0765 DO 90 J=1,3 ABFV0766 90 A(J+10,I)=A(J+10,I)-A(1,I)*C(J,I)**3-THREE*A(J+1,I)*C(J,I)**2 ABFV0767 & -THREE*A(J+4,I)*C(J,I) ABFV0768 A(14,I)=A(14,I)-A(1,I)*X*Y*Y-TWO*A(3,I)*X*Y-A(2,I)*Y*Y ABFV0769 & -TWO*A(8,I)*Y-A(6,I)*X ABFV0770 A(15,I)=A(15,I)-A(1,I)*X*X*Y-TWO*A(2,I)*X*Y-A(3,I)*X*X ABFV0771 & -TWO*A(8,I)*X-A(5,I)*Y ABFV0772 A(16,I)=A(16,I)-A(1,I)*X*X*Z-TWO*A(2,I)*X*Z-A(4,I)*X*X ABFV0773 & -TWO*A(9,I)*X-A(5,I)*Z ABFV0774 A(17,I)=A(17,I)-A(1,I)*X*Z*Z-TWO*A(4,I)*X*Z-A(2,I)*Z*Z ABFV0775 & -TWO*A(9,I)*Z-A(7,I)*X ABFV0776 A(18,I)=A(18,I)-A(1,I)*Y*Z*Z-TWO*A(4,I)*Y*Z-A(3,I)*Z*Z ABFV0777 & -TWO*A(10,I)*Z-A(7,I)*Y ABFV0778 A(19,I)=A(19,I)-A(1,I)*Y*Y*Z-TWO*A(3,I)*Y*Z-A(4,I)*Y*Y ABFV0779 & -TWO*A(10,I)*Y-A(6,I)*Z ABFV0780 A(20,I)=A(20,I)-A(1,I)*X*Y*Z-A(2,I)*Y*Z-A(3,I)*X*Z-A(4,I)*X*Y ABFV0781 & -A(10,I)*X-A(9,I)*Y-A(8,I)*Z ABFV0782 100 WRITE(IOUT,2002) SYMB(I),(LABELS(J),A(J,I),J=11,20) ABFV0783 C ABFV0784 C TRACELESS ATOMIC OCTUPOLES. ABFV0785 WRITE(IOUT,1100) ABFV0786 DO 105 I=1,NATOMS ABFV0787 TL(11)=A(11,I)-ONEHALF*(A(14,I)+A(17,I)) ABFV0788 TL(12)=A(12,I)-ONEHALF*(A(15,I)+A(18,I)) ABFV0789 TL(13)=A(13,I)-ONEHALF*(A(16,I)+A(19,I)) ABFV0790 TL(14)=TWO*A(14,I)-HALF*(A(11,I)+A(17,I)) ABFV0791 TL(15)=TWO*A(15,I)-HALF*(A(12,I)+A(18,I)) ABFV0792 TL(16)=TWO*A(16,I)-HALF*(A(13,I)+A(19,I)) ABFV0793 TL(17)=TWO*A(17,I)-HALF*(A(11,I)+A(14,I)) ABFV0794 TL(18)=TWO*A(18,I)-HALF*(A(12,I)+A(15,I)) ABFV0795 TL(19)=TWO*A(19,I)-HALF*(A(13,I)+A(16,I)) ABFV0796 TL(20)=TWOHALF*A(20,I) ABFV0797 DO 106 J=7,16 ABFV0798 106 TLS(J,I)=TL(J+4) ABFV0799 105 WRITE(IOUT,2002) SYMB(I),(LABELS(J),TL(J),J=11,20) ABFV0800 IF(NMULT.EQ.2) RETURN ABFV0801 C ABFV0802 C MOLECULAR FOURTH MOMENT. ABFV0803 WRITE(IOUT,1030) ABFV0804 WRITE(IOUT,2000) (LABELS(I),D(I),I=21,35) ABFV0805 C ABFV0806 C TRACELESS MOLECULAR HEXADECAPOLES. ABFV0807 WRITE(IOUT,1035) ABFV0808 TL(21)=D(21)-3.0*(D(30)+D(31))+.375*(D(22)+D(23))+.75*D(32) ABFV0809 TL(22)=D(22)-3.0*(D(30)+D(32))+.375*(D(21)+D(23))+.75*D(31) ABFV0810 TL(23)=D(23)-3.0*(D(31)+D(32))+.375*(D(21)+D(22))+.75*D(30) ABFV0811 TL(24)=2.5*D(24)-1.875*(D(26)+D(35)) ABFV0812 TL(25)=2.5*D(25)-1.875*(D(33)+D(29)) ABFV0813 TL(26)=2.5*D(26)-1.875*(D(24)+D(35)) ABFV0814 TL(27)=2.5*D(27)-1.875*(D(33)+D(29)) ABFV0815 TL(28)=2.5*D(28)-1.875*(D(25)+D(34)) ABFV0816 TL(29)=2.5*D(29)-1.875*(D(33)+D(27)) ABFV0817 TL(30)=3.375*D(30)-.5*(D(21)+D(22))-.375*(D(32)+D(31))+.125*D(23) ABFV0818 TL(31)=3.375*D(31)-.5*(D(21)+D(23))-.375*(D(30)+D(32))+.125*D(22) ABFV0819 TL(32)=3.375*D(32)-.5*(D(22)+D(23))-.375*(D(30)+D(31))+.125*D(21) ABFV0820 WRITE(IOUT,2000)(LABELS(J),D(J),J=21,32) ABFV0821 C ABFV0822 C ATOMIC FOURTH MOMENTS. ABFV0823 WRITE(IOUT,1080) ABFV0824 DO 130 I=1,NATOMS ABFV0825 X=C(1,I) ABFV0826 Y=C(2,I) ABFV0827 Z=C(3,I) ABFV0828 A1=A(1,I) ABFV0829 DO 120 J=1,3 ABFV0830 120 A(J+20,I)=A(J+20,I)-A1*C(J,I)**4-FOUR*A(J+1,I)*C(J,I)**3 ABFV0831 & -SIX*A(J+4,I)*C(J,I)**2-FOUR*A(J+10,I)*C(J,I) ABFV0832 A(24,I)=A(24,I)-A1*X*X*X*Y-THREE*A(2,I)*X*X*Y-A(3,I)*X*X*X ABFV0833 & -THREE*A(8,I)*X*X-THREE*A(5,I)*X*Y-THREE*A(15,I)*X-A(11,I)*Y ABFV0834 A(25,I)=A(25,I)-A1*X*X*X*Z-THREE*A(2,I)*X*X*Z-A(4,I)*X*X*X ABFV0835 & -THREE*A(9,I)*X*X-THREE*A(5,I)*X*Z-THREE*A(16,I)*X-A(11,I)*Z ABFV0836 A(26,I)=A(26,I)-A1*Y*Y*Y*X-THREE*A(3,I)*Y*Y*X-A(2,I)*Y*Y*Y ABFV0837 & -THREE*A(8,I)*Y*Y-THREE*A(6,I)*X*Y-THREE*A(14,I)*Y-A(12,I)*X ABFV0838 A(27,I)=A(27,I)-A1*Y*Y*Y*Z-THREE*A(3,I)*Y*Y*Z-A(4,I)*Y*Y*Y ABFV0839 & -THREE*A(10,I)*Y*Y-THREE*A(6,I)*Y*Z-THREE*A(19,I)*Y-A(12,I)*Z ABFV0840 A(28,I)=A(28,I)-A1*Z*Z*Z*X-THREE*A(4,I)*Z*Z*X-A(2,I)*Z*Z*Z ABFV0841 & -THREE*A(9,I)*Z*Z-THREE*A(7,I)*X*Z-THREE*A(17,I)*Z-A(13,I)*X ABFV0842 A(29,I)=A(29,I)-A1*Z*Z*Z*Y-THREE*A(4,I)*Z*Z*Y-A(3,I)*Z*Z*Z ABFV0843 & -THREE*A(10,I)*Z*Z-THREE*A(7,I)*Y*Z-THREE*A(18,I)*Z-A(13,I)*Y ABFV0844 A(30,I)=A(30,I)-A1*X*X*Y*Y-TWO*A(2,I)*X*Y*Y-TWO*A(3,I)*X*X*Y ABFV0845 & -A(5,I)*Y*Y-A(6,I)*X*X-FOUR*A(8,I)*X*Y-TWO*A(14,I)*X ABFV0846 & -TWO*A(15,I)*Y ABFV0847 A(31,I)=A(31,I)-A1*X*X*Z*Z-TWO*A(2,I)*X*Z*Z-TWO*A(4,I)*X*X*Z ABFV0848 & -A(5,I)*Z*Z-A(7,I)*X*X-FOUR*A(9,I)*X*Z-TWO*A(17,I)*X ABFV0849 & -TWO*A(16,I)*Z ABFV0850 A(32,I)=A(32,I)-A1*Y*Y*Z*Z-TWO*A(3,I)*Y*Z*Z-TWO*A(4,I)*Y*Y*Z ABFV0851 & -A(6,I)*Z*Z-A(7,I)*Y*Y-FOUR*A(10,I)*Y*Z-TWO*A(18,I)*Y ABFV0852 & -TWO*A(19,I)*Z ABFV0853 A(33,I)=A(33,I)-A1*X*X*Y*Z-TWO*A(2,I)*X*Y*Z-A(3,I)*X*X*Z ABFV0854 & -A(4,I)*X*X*Y-A(5,I)*Y*Z-TWO*A(8,I)*X*Z-TWO*A(9,I)*X*Y ABFV0855 & -A(10,I)*X*X-A(15,I)*Z-A(16,I)*Y-TWO*A(20,I)*X ABFV0856 A(34,I)=A(34,I)-A1*Y*Y*X*Z-TWO*A(3,I)*X*Y*Z-A(2,I)*Y*Y*Z ABFV0857 & -A(4,I)*Y*Y*X-A(6,I)*X*Z-TWO*A(8,I)*Y*Z-TWO*A(10,I)*X*Y ABFV0858 & -A(9,I)*Y*Y-A(19,I)*X-A(14,I)*Z-TWO*A(20,I)*Y ABFV0859 A(35,I)=A(35,I)-A1*Z*Z*X*Y-TWO*A(4,I)*X*Y*Z-A(2,I)*Z*Z*Y ABFV0860 & -A(3,I)*Z*Z*X-A(7,I)*X*Y-TWO*A(9,I)*Z*Y-TWO*A(10,I)*Z*X ABFV0861 & -A(8,I)*Z*Z-A(17,I)*Y-A(18,I)*X-TWO*A(20,I)*Z ABFV0862 130 WRITE(IOUT,2002) SYMB(I),(LABELS(J),A(J,I),J=21,35) ABFV0863 C ABFV0864 C TRACELESS ATOMIC HEXADECAPOLES. ABFV0865 WRITE(IOUT,1110) ABFV0866 DO 135 I=1,NATOMS ABFV0867 TL(21)=A(21,I)-THREE*(A(30,I)+A(31,I))+CP3*(A(22,I)+A(23,I)) ABFV0868 & +CP7*A(32,I) ABFV0869 TL(22)=A(22,I)-THREE*(A(30,I)+A(32,I))+CP3*(A(21,I)+A(23,I)) ABFV0870 & +CP7*A(31,I) ABFV0871 TL(23)=A(23,I)-THREE*(A(31,I)+A(32,I))+CP3*(A(21,I)+A(22,I)) ABFV0872 & +CP7*A(30,I) ABFV0873 TL(24)=TWOHALF*A(24,I)-C18*(A(26,I)+A(35,I)) ABFV0874 TL(25)=TWOHALF*A(25,I)-C18*(A(28,I)+A(34,I)) ABFV0875 TL(26)=TWOHALF*A(26,I)-C18*(A(24,I)+A(35,I)) ABFV0876 TL(27)=TWOHALF*A(27,I)-C18*(A(33,I)+A(29,I)) ABFV0877 TL(28)=TWOHALF*A(28,I)-C18*(A(25,I)+A(34,I)) ABFV0878 TL(29)=TWOHALF*A(29,I)-C18*(A(33,I)+A(27,I)) ABFV0879 TL(30)=C33*A(30,I)-HALF*(A(21,I)+A(22,I))-CP3*(A(32,I)+A(31,I)) ABFV0880 & +CP1*A(23,I) ABFV0881 TL(31)=C33*A(31,I)-HALF*(A(21,I)+A(23,I))-CP3*(A(30,I)+A(32,I)) ABFV0882 & +CP1*A(22,I) ABFV0883 TL(32)=C33*A(32,I)-HALF*(A(22,I)+A(23,I))-CP3*(A(30,I)+A(31,I)) ABFV0884 & +CP1*A(21,I) ABFV0885 TL(33)=C37*A(33,I)-CP6*(A(29,I)+A(27,I)) ABFV0886 TL(34)=C37*A(34,I)-CP6*(A(25,I)+A(28,I)) ABFV0887 TL(35)=C37*A(35,I)-CP6*(A(24,I)+A(26,I)) ABFV0888 IF(IOP(5).EQ.1) THEN ABFV0889 WRITE(IPUNCH,3000) IAN(I),(C(J,I),J=1,3) ABFV0890 WRITE(IPUNCH,3001) (A(J,I),J=1,35) ABFV0891 WRITE(IPUNCH,3001) (TLS(J,I),J=1,16),(TL(K),K=21,35) ABFV0892 END IF ABFV0893 3000 FORMAT(I4,3F10.6) ABFV0894 3001 FORMAT(8E15.6) ABFV0895 135 WRITE(IOUT,2002) SYMB(I),(LABELS(J),TL(J),J=21,35) ABFV0896 RETURN ABFV0897 END ABFV0898 SUBROUTINE POINT(IDUMP) ABFV0899 IMPLICIT REAL*8(A-H,O-Z) ABFV0900 INTEGER ADIM,GDIM,PDIM,DIM1,DIM2,DIM3,DIM4 ABFV0901 PARAMETER (ADIM=50,NBAS=128,GDIM=400) ABFV0902 PARAMETER (PDIM=NBAS*(NBAS+1)/2,DIM1=MAX(GDIM,100)) ABFV0903 PARAMETER (DIM2=DIM1+1,DIM3=3*GDIM,DIM4=2*GDIM+1) ABFV0904 CHARACTER*6 SYMB,ASYMB ABFV0905 COMMON/IOP/ IOP(7) ABFV0906 COMMON/IO/ IN,IOUT,IPUNCH ABFV0907 COMMON/MOL/ NATOMS,ICHARGE,MULTIP,NAE,NBE,NE,NBASIS, ABFV0908 & IAN(DIM2),ATMCHG(DIM1),C(3,DIM1) ABFV0909 COMMON/ATMTP/ AC(35,ADIM),ISHELL,JSHELL ABFV0910 DIMENSION A(3,3),EIG(3),W(3),XYZ(8,3) ABFV0911 DATA TWO/2.0D0/ ,ANTOAU/0.529177/, N/3/,SMALL/1.0D-10/ ABFV0912 DATA ZERO/0.0D0/ ABFV0913 WRITE(IOUT,97) ABFV0914 97 FORMAT(//28X,'POINT CHARGE REPRESENTATION'// ABFV0915 & 4X,'ATOM',11X,'X(AU)',12X,'Y(AU)',12X,'Z(AU)',10X,'CHARGE(AU)'/) ABFV0916 DO 100 I=1,NATOMS ABFV0917 II=I+NATOMS ABFV0918 IA=IAN(I) ABFV0919 SYMB=ASYMB(IA,I) ABFV0920 A(1,1)=AC(5,I) ABFV0921 A(2,2)=AC(6,I) ABFV0922 A(3,3)=AC(7,I) ABFV0923 A(2,1)=AC(8,I) ABFV0924 A(3,1)=AC(9,I) ABFV0925 A(3,2)=AC(10,I) ABFV0926 A(1,2)=AC(8,I) ABFV0927 A(1,3)=AC(9,I) ABFV0928 A(2,3)=AC(10,I) ABFV0929 CALL TRED2(A,N,N,EIG,W) ABFV0930 CALL TQLI(EIG,W,N,N,A) ABFV0931 X=SQRT(AC(2,I)**2+AC(3,I)**2+AC(4,I)**2) ABFV0932 Q=EIG(1)+EIG(2)+EIG(3) ABFV0933 RLI=SQRT(-Q/(IA-AC(1,I))) ABFV0934 IF(IDUMP.NE.0) WRITE(IOUT,96) I,EIG(1),EIG(2),EIG(3),RLI ABFV0935 96 FORMAT(5X,I4,' EIG: ',3F15.8,' RL: ',F15.8) ABFV0936 IF(X.LT.SMALL) THEN ABFV0937 QD1=ZERO ABFV0938 QD2=ZERO ABFV0939 DO 210 K=1,3 ABFV0940 XYZ(1,K)=ZERO ABFV0941 210 XYZ(2,K)=ZERO ABFV0942 ELSE ABFV0943 QD1=-0.5*X/RLI ABFV0944 QD2=-QD1 ABFV0945 DO 200 K=1,3 ABFV0946 K1=K+1 ABFV0947 XYZ(1,K)=C(K,I)-AC(K1,I)*RLI/X ABFV0948 200 XYZ(2,K)=C(K,I)+AC(K1,I)*RLI/X ABFV0949 END IF ABFV0950 RL2=TWO*RLI*RLI ABFV0951 QQ1=EIG(1)/RL2 ABFV0952 QQ2=EIG(2)/RL2 ABFV0953 QQ3=EIG(3)/RL2 ABFV0954 R1=SQRT(ABS(EIG(1)/(TWO*QQ1))) ABFV0955 R2=SQRT(ABS(EIG(2)/(TWO*QQ2))) ABFV0956 R3=SQRT(ABS(EIG(3)/(TWO*QQ3))) ABFV0957 DO 300 K=1,3 ABFV0958 XYZ(3,K)=C(K,I)-A(K,1)*R1 ABFV0959 XYZ(4,K)=C(K,I)+A(K,1)*R1 ABFV0960 XYZ(5,K)=C(K,I)-A(K,2)*R2 ABFV0961 XYZ(6,K)=C(K,I)+A(K,2)*R2 ABFV0962 XYZ(7,K)=C(K,I)-A(K,3)*R3 ABFV0963 XYZ(8,K)=C(K,I)+A(K,3)*R3 ABFV0964 300 CONTINUE ABFV0965 QC=FLOAT(IA) ABFV0966 WRITE(IOUT,99) SYMB,(C(K,I),K=1,3),QC ABFV0967 WRITE(IOUT,99) SYMB,(XYZ(1,K),K=1,3),QD1 ABFV0968 WRITE(IOUT,99) SYMB,(XYZ(2,K),K=1,3),QD2 ABFV0969 WRITE(IOUT,99) SYMB,(XYZ(3,K),K=1,3),QQ1 ABFV0970 WRITE(IOUT,99) SYMB,(XYZ(4,K),K=1,3),QQ1 ABFV0971 WRITE(IOUT,99) SYMB,(XYZ(5,K),K=1,3),QQ2 ABFV0972 WRITE(IOUT,99) SYMB,(XYZ(6,K),K=1,3),QQ2 ABFV0973 WRITE(IOUT,99) SYMB,(XYZ(7,K),K=1,3),QQ3 ABFV0974 WRITE(IOUT,99) SYMB,(XYZ(8,K),K=1,3),QQ3 ABFV0975 IF(IOP(5).EQ.1) THEN ABFV0976 WRITE(IPUNCH,98) IA,(C(K,I),K=1,3),QC ABFV0977 WRITE(IPUNCH,98) IA,(XYZ(1,K),K=1,3),QD1 ABFV0978 WRITE(IPUNCH,98) IA,(XYZ(2,K),K=1,3),QD2 ABFV0979 WRITE(IPUNCH,98) IA,(XYZ(3,K),K=1,3),QQ1 ABFV0980 WRITE(IPUNCH,98) IA,(XYZ(4,K),K=1,3),QQ1 ABFV0981 WRITE(IPUNCH,98) IA,(XYZ(5,K),K=1,3),QQ2 ABFV0982 WRITE(IPUNCH,98) IA,(XYZ(6,K),K=1,3),QQ2 ABFV0983 WRITE(IPUNCH,98) IA,(XYZ(7,K),K=1,3),QQ3 ABFV0984 WRITE(IPUNCH,98) IA,(XYZ(8,K),K=1,3),QQ3 ABFV0985 END IF ABFV0986 100 CONTINUE ABFV0987 99 FORMAT(4X,A6,4F17.8) ABFV0988 98 FORMAT(I5,4E20.10) ABFV0989 RETURN ABFV0990 END ABFV0991 CHARACTER*6 FUNCTION ASYMB(IAN,NR) ABFV0992 INTEGER D2,D3 ABFV0993 CHARACTER*2 ELDAT(106) ABFV0994 DATA ELDAT/'X ','Bq','H ','He','Li','Be','B ','C ', ABFV0995 $'N ','O ','F ','Ne','Na','Mg','Al','Si','P ','S ','Cl','Ar','K ', ABFV0996 $'Ca','Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge', ABFV0997 $'As','Se','Br','Kr','Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh', ABFV0998 $'Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce', ABFV0999 $'Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu', ABFV1000 $'Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po', ABFV1001 $'At','Rn','Fr','Ra','Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk', ABFV1002 $'Cf','Es','Fm','Md','No','Lr','Ky'/ ABFV1003 C Convertion of number NR (max. 99) into character string. ABFV1004 D2=MOD(NR,100)/10 ABFV1005 D3=MOD(NR,10) ABFV1006 IF(D2.NE.0) THEN ABFV1007 ASYMB=ELDAT(IAN+2)//'('//CHAR(D2+48)//CHAR(D3+48)//')' ABFV1008 ELSE ABFV1009 ASYMB=ELDAT(IAN+2)//'('//CHAR(D3+48)//') ' ABFV1010 END IF ABFV1011 RETURN ABFV1012 END ABFV1013 SUBROUTINE TRED2(A,N,NP,D,E) ABFV1014 C Householder reduction of real, symmetric matrix. ABFV1015 C Adopted from 'NUMERICAL RECIPES' W.Press et al., Cambridge 1986 ABFV1016 IMPLICIT REAL*8 (A-H,O-Z) ABFV1017 DIMENSION A(NP,NP),D(NP),E(NP) ABFV1018 IF(N.GT.1)THEN ABFV1019 DO 18 I=N,2,-1 ABFV1020 L=I-1 ABFV1021 H=0. ABFV1022 SCALE=0. ABFV1023 IF(L.GT.1)THEN ABFV1024 DO 11 K=1,L ABFV1025 SCALE=SCALE+ABS(A(I,K)) ABFV1026 11 CONTINUE ABFV1027 IF(SCALE.EQ.0.)THEN ABFV1028 E(I)=A(I,L) ABFV1029 ELSE ABFV1030 DO 12 K=1,L ABFV1031 A(I,K)=A(I,K)/SCALE ABFV1032 H=H+A(I,K)**2 ABFV1033 12 CONTINUE ABFV1034 F=A(I,L) ABFV1035 G=-SIGN(SQRT(H),F) ABFV1036 E(I)=SCALE*G ABFV1037 H=H-F*G ABFV1038 A(I,L)=F-G ABFV1039 F=0. ABFV1040 DO 15 J=1,L ABFV1041 A(J,I)=A(I,J)/H ABFV1042 G=0. ABFV1043 DO 13 K=1,J ABFV1044 G=G+A(J,K)*A(I,K) ABFV1045 13 CONTINUE ABFV1046 IF(L.GT.J)THEN ABFV1047 DO 14 K=J+1,L ABFV1048 G=G+A(K,J)*A(I,K) ABFV1049 14 CONTINUE ABFV1050 ENDIF ABFV1051 E(J)=G/H ABFV1052 F=F+E(J)*A(I,J) ABFV1053 15 CONTINUE ABFV1054 HH=F/(H+H) ABFV1055 DO 17 J=1,L ABFV1056 F=A(I,J) ABFV1057 G=E(J)-HH*F ABFV1058 E(J)=G ABFV1059 DO 16 K=1,J ABFV1060 A(J,K)=A(J,K)-F*E(K)-G*A(I,K) ABFV1061 16 CONTINUE ABFV1062 17 CONTINUE ABFV1063 ENDIF ABFV1064 ELSE ABFV1065 E(I)=A(I,L) ABFV1066 ENDIF ABFV1067 D(I)=H ABFV1068 18 CONTINUE ABFV1069 ENDIF ABFV1070 D(1)=0. ABFV1071 E(1)=0. ABFV1072 DO 23 I=1,N ABFV1073 L=I-1 ABFV1074 IF(D(I).NE.0.)THEN ABFV1075 DO 21 J=1,L ABFV1076 G=0. ABFV1077 DO 19 K=1,L ABFV1078 G=G+A(I,K)*A(K,J) ABFV1079 19 CONTINUE ABFV1080 DO 20 K=1,L ABFV1081 A(K,J)=A(K,J)-G*A(K,I) ABFV1082 20 CONTINUE ABFV1083 21 CONTINUE ABFV1084 ENDIF ABFV1085 D(I)=A(I,I) ABFV1086 A(I,I)=1. ABFV1087 IF(L.GE.1)THEN ABFV1088 DO 22 J=1,L ABFV1089 A(I,J)=0. ABFV1090 A(J,I)=0. ABFV1091 22 CONTINUE ABFV1092 ENDIF ABFV1093 23 CONTINUE ABFV1094 RETURN ABFV1095 END ABFV1096 SUBROUTINE TQLI(D,E,N,NP,Z) ABFV1097 C Determines the eigenvalues and eigenvectors of a real, ABFV1098 C symmetric, tridiagonal matrix. ABFV1099 C Adopted from 'NUMERICAL RECIPES' W.Press et al., Cambridge 1986 ABFV1100 IMPLICIT REAL*8 (A-H,O-Z) ABFV1101 DIMENSION D(NP),E(NP),Z(NP,NP) ABFV1102 IF (N.GT.1) THEN ABFV1103 DO 11 I=2,N ABFV1104 E(I-1)=E(I) ABFV1105 11 CONTINUE ABFV1106 E(N)=0. ABFV1107 DO 15 L=1,N ABFV1108 ITER=0 ABFV1109 1 DO 12 M=L,N-1 ABFV1110 DD=ABS(D(M))+ABS(D(M+1)) ABFV1111 IF (ABS(E(M))+DD.EQ.DD) GO TO 2 ABFV1112 12 CONTINUE ABFV1113 M=N ABFV1114 2 IF(M.NE.L)THEN ABFV1115 IF(ITER.EQ.30)PAUSE 'too many iterations' ABFV1116 ITER=ITER+1 ABFV1117 G=(D(L+1)-D(L))/(2.*E(L)) ABFV1118 R=SQRT(G**2+1.) ABFV1119 G=D(M)-D(L)+E(L)/(G+SIGN(R,G)) ABFV1120 S=1. ABFV1121 C=1. ABFV1122 P=0. ABFV1123 DO 14 I=M-1,L,-1 ABFV1124 F=S*E(I) ABFV1125 B=C*E(I) ABFV1126 IF(ABS(F).GE.ABS(G))THEN ABFV1127 C=G/F ABFV1128 R=SQRT(C**2+1.) ABFV1129 E(I+1)=F*R ABFV1130 S=1./R ABFV1131 C=C*S ABFV1132 ELSE ABFV1133 S=F/G ABFV1134 R=SQRT(S**2+1.) ABFV1135 E(I+1)=G*R ABFV1136 C=1./R ABFV1137 S=S*C ABFV1138 ENDIF ABFV1139 G=D(I+1)-P ABFV1140 R=(D(I)-G)*S+2.*C*B ABFV1141 P=S*R ABFV1142 D(I+1)=G+P ABFV1143 G=C*R-B ABFV1144 DO 13 K=1,N ABFV1145 F=Z(K,I+1) ABFV1146 Z(K,I+1)=S*Z(K,I)+C*F ABFV1147 Z(K,I)=C*Z(K,I)-S*F ABFV1148 13 CONTINUE ABFV1149 14 CONTINUE ABFV1150 D(L)=D(L)-P ABFV1151 E(L)=G ABFV1152 E(M)=0. ABFV1153 GO TO 1 ABFV1154 ENDIF ABFV1155 15 CONTINUE ABFV1156 ENDIF ABFV1157 RETURN ABFV1158 END ABFV1159 $! Input data for test run 1 ABFV1160 $! Input data for the GAUSSIAN-86 job. ABFV1161 $! 6-311G** optimized geometry - J.Chem.Phys. 72,650(1980) ABFV1162 $RUNGAUSS ABFV1163 %RWF=HF_RWF ABFV1164 #P CISD/6-311G** IOP(9/26=1) ABFV1165 ABFV1166 HF CISD/6-311G** ABFV1167 ABFV1168 0 1 ABFV1169 H ABFV1170 F H 0.9168 ABFV1171 ABFV1172 $! Now start the CCAMM job. ABFV1173 $RUN CAMM ABFV1174 HF_RWF ABFV1175 1 1 1 0 0 0 0 ABFV1176 $! End of test ABFV1177 $! Input data for test run 2 ABFV1178 $! Input data for the GAUSSIAN-86 job. ABFV1179 $! 6-311G** optimized geometry - J.Chem.Phys. 72,650(1980) ABFV1180 $RUNGAUSS ABFV1181 %RWF=NH3_RWF ABFV1182 #P CISD/6-311G IOP(2/15=1,9/26=1) ABFV1183 ABFV1184 CAMM NH3 TEST; 6-311G ABFV1185 ABFV1186 0 1 ABFV1187 N ABFV1188 X 1 1.0 ABFV1189 H 1 1.012 2 67.88 ABFV1190 H 1 1.012 2 67.88 3 120.0 ABFV1191 H 1 1.012 2 67.88 3 -120.0 ABFV1192 ABFV1193 $! Now start the CCAMM job. ABFV1194 $RUN CAMM ABFV1195 NH3_RWF ABFV1196 1 0 1 0 0 0 0 ABFV1197 $! End of test ABFV1198 ABFV****