C CHELP-NET ATOMIC CHARGES FROM AB INITIO WAVE FUNCTIONS CHE00010 C Modified for Grid Operations by Curt Breneman, Yale University CHE00020 C Department of Chemistry, 3/88 (Currently of Rensselaer CHE00030 C Polytechnic Institute, Troy, NY 12180.) CHE00040 C CHE00050 C CHELPG CHE00060 C CHE00070 C (NET ATOMIC) CHARGES FIT TO ELECTROSTATIC POTENTIALS CHE00080 C CHE00090 C Original CHELP code by: CHE00100 C M.M. FRANCL CHE00110 C L.E. CHIRLIAN CHE00120 C CHE00130 C OCTOBER 1985 CHE00140 C PRINCETON CHEMISTRY DEPARTMENT VAX 11/780 CHE00150 C VMS 3.7 CHE00160 C CHE00170 C FEBRUARY 1988 CHE00180 C MODIFIED TO USE GAUSSIAN86 CHECKPOINT FILES CHE00190 C Modified to use G88/90 checkpoint files 1/89 CHE00200 C YALE UNIVERSITY DEPARTMENT OF CHEMISTRY CHE00210 C WIBERG GROUP VMS 4.5 CHE00220 C CURT BRENEMAN CHE00230 C CHE00240 IMPLICIT REAL*8 (A-H,O-Z) CHE00250 INTEGER*4 HANDLE1 CHE00260 HANDLE1=0 CHE00270 C*** TRACE-7 CHE00280 C ISTAT1=LIB$INIT_TIMER(HANDLE1) CHE00290 C*** CHE00300 C CHE00310 C READ IN DATA FROM CHECKPOINT FILE CHE00320 C CHE00330 CALL READIN CHE00340 C CHE00350 C CHE00360 C SELECT POINTS FOR FITTING, BEGIN WITH SHELL OF RADIUS 2A AND CHE00370 C INCREASING BY .5A SELECT POINTS FROM THE ROUGHLY RADIAL DISTRIBCHE00380 C WHICH ARE NOT ENCLOSED BY THE VAN DER WAALS ENVELOPE OF THE MOLCHE00390 C UNTIL A PREDETERMINED MAXIMUM NUMBER OF POINTS HAS BEEN REACHEDCHE00400 C CHE00410 CALL BALL CHE00420 C CHE00430 C CALCULATE THE ELECTROSTATIC POTENTIAL USING FIRST ORDER HARTREECHE00440 C PERTURBATION THEORY CHE00450 C CHE00460 CALL EP CHE00470 C CHE00480 C USING METHOD OF LAGRANGE MULTIPLIERS, FIT BY LEAST SQUARES THE CHE00490 C TO THE ELECTROSTATIC POTENTIAL, CONSTRAINING THE FIT TO REPRODUCHE00500 C TOTAL MOLECULAR CHARGE CHE00510 C CHE00520 CALL FIT CHE00530 C CHE00540 C PRINT OUT TABLE OF RESULTS CHE00550 C CHE00560 CALL OUTPUT CHE00570 C CHE00580 C*** TRACE-7 CHE00590 C ISTAT1=LIB$SHOW_TIMER(HANDLE1) CHE00600 C*** CHE00610 END CHE00620 C CHE00630 C CHE00640 SUBROUTINE BALL CHE00650 C CHE00660 C ROUTINE TO SELECT POINTS FOR FITTING TO THE ELECTROSTATIC POTENCHE00670 C CHE00680 C POINTS WHICH LIE WITHIN THE VAN DER WAALS ENVELOPE OF THE MOLECCHE00690 C ARE EXCLUDED. CHE00700 C CHE00710 C POINTS ARE INITIALLY SELECTED IN A CUBE AROUND THE MOLECULE WHICHE00720 C IS SCALED TO THE SIZE OF THE MOLECULE+RMAX. THIS IS PRESENTLY AN INPUCHE00730 C PARAMETER. POINTS ARE THEN EXCLUDED IF THEY FALL WITHIN THE INPUT CHE00740 C VDW RADIUS OF ANY OF THE ATOMS, OR, IF THEY FALL OUTSIDE CHE00750 C A DESIGNATED DISTANCE (RMAX) FROM ALL OF THE ATOMS. THE REMAINING CHE00760 C POINTS ARE PACKED IN A SET OF THREE (X,Y,Z) VECTORS, AND SENT TO THE CHE00770 C LAGRANGE LEAST-SQUARES FITTING ROUTINE. THE ORIGINAL CHELP INPUT CHE00780 C DECK IS AUGMENTED BY ADDING TWO FREE-FORMAT VARIABLES AT THE END. CHE00790 C THE TWO NEW INPUT VARIABLES ARE 'RMAX' AND 'DELR', WHERE RMAX CHE00800 C IS THE MAXIMUM DISTANCE A POINT CAN BE FROM ANY ATOM AND STILL CHE00810 C BE CONSIDERED IN THE FIT, AND DELR IS THE DISTANCE BETWEEN POINTS CHE00820 C IN THE GRID. BOTH RMAX AND DELR ARE IN ANGSTROMS. CHE00830 C CHE00840 C CURT BRENEMAN AND TERESA LEPAGE CHE00850 C YALE UNIVERSITY DEPARTMENT OF CHEMISTRY 3/88 CHE00860 C CHE00870 C ORIGINAL CODE BY: CHE00880 C CHE00890 C L.E. CHIRLIAN CHE00900 C M.M. FRANCL CHE00910 C APRIL 1985 CHE00920 C CHE00930 IMPLICIT REAL*8 (A-H,O-Z) CHE00940 C CHE00950 PARAMETER (NPOINTS = 50000) CHE00960 COMMON /IO/ IN,IOUT CHE00970 C+++ CHE00980 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS, CHE00990 $ IAN(401),ATMCHG(400),C(3,400) CHE01000 C+++ CHE01010 COMMON /IPO/ IPO(5) CHE01020 COMMON /SPHERE/ RADII(400),NTOTP CHE01030 COMMON /POINTS/ P(3,NPOINTS), MAXPNTS CHE01040 C CHE01050 DATA ANG2AU /1.889726878D0/ CHE01060 C CHE01070 C*** READ IN THE THE RMAX AND DELR VALUES IN ANGSTROMS. CHE01080 C CHE01090 read(IN,*) RMAX, DELR CHE01100 write(IOUT,*) ' RMAX = ',RMAX,' (ANGS), DELR = ',DELR,' (ANGS).' CHE01110 C*** CHE01120 C CHE01130 C CONVERT RADII TO AU CHE01140 C CHE01150 DELR = DELR * ANG2AU CHE01160 RMAX = RMAX * ANG2AU CHE01170 C CHE01180 C WHILE CONVERTING THE VDW RADII TO AU, FIND THE EXTREMA OF THE CHE01190 C MOLECULAR GEOMETRY. CHE01200 C CHE01210 XMAX=-50.0D0 CHE01220 XMIN=50.0D0 CHE01230 YMAX=-50.0D0 CHE01240 YMIN=50.0D0 CHE01250 ZMAX=-50.0D0 CHE01260 ZMIN=50.0D0 CHE01270 C CHE01280 WRITE(IOUT,*) ' THERE ARE ',NATOMS,' ATOMS TO CONSIDER.' CHE01290 DO 10 I=1,NATOMS CHE01300 RADII(I) = RADII(I) * ANG2AU CHE01310 C CHE01320 IF (C(1,I) .GT. XMAX) XMAX = C(1,I) CHE01330 IF (C(1,I) .LT. XMIN) XMIN = C(1,I) CHE01340 IF (C(2,I) .GT. YMAX) YMAX = C(2,I) CHE01350 IF (C(2,I) .LT. YMIN) YMIN = C(2,I) CHE01360 IF (C(3,I) .GT. ZMAX) ZMAX = C(3,I) CHE01370 IF (C(3,I) .LT. ZMIN) ZMIN = C(3,I) CHE01380 10 CONTINUE CHE01390 C CHE01400 WRITE(IOUT,*) ' XMAX = ',XMAX,' (AU), XMIN = ',XMIN,' (AU).' CHE01410 WRITE(IOUT,*) ' YMAX = ',YMAX,' (AU), YMIN = ',YMIN,' (AU).' CHE01420 WRITE(IOUT,*) ' ZMAX = ',ZMAX,' (AU), ZMIN = ',ZMIN,' (AU).' CHE01430 C CHE01440 C DETERMINE THE MINIMUM CUBE DIMENSIONS REQUIRED TO CONTAIN CHE01450 C THE MOLECULE, INCLUDING THE MAXIMUM SELECTION RADIUS (RMAX) CHE01460 C ON BOTH SIDES. CHE01470 C CHE01480 XRANGE = XMAX - XMIN + 2.0D0 * RMAX CHE01490 YRANGE = YMAX - YMIN + 2.0D0 * RMAX CHE01500 ZRANGE = ZMAX - ZMIN + 2.0D0 * RMAX CHE01510 C CHE01520 NXPTS = INT(XRANGE/DELR) CHE01530 NYPTS = INT(YRANGE/DELR) CHE01540 NZPTS = INT(ZRANGE/DELR) CHE01550 C CHE01560 WRITE(IOUT,*) ' NUMBER OF X POINTS REQUIRED = ',NXPTS CHE01570 WRITE(IOUT,*) ' NUMBER OF Y POINTS REQUIRED = ',NYPTS CHE01580 WRITE(IOUT,*) ' NUMBER OF Z POINTS REQUIRED = ',NZPTS CHE01590 MAXPOSS = NXPTS * NYPTS * NZPTS CHE01600 WRITE(IOUT,*) ' TOTAL NUMBER OF POINTS CONSIDERED = ',MAXPOSS CHE01610 C CHE01620 C CHE01630 C RESET POINT COUNTER FOR NUMBER OF SELECTED POINTS CHE01640 C CHE01650 IPOINT = 0 CHE01660 C CHE01670 C LOOP OVER POSSIBLE POINTS CHE01680 C CHE01690 DO 200 II = 1,NXPTS + 1 CHE01700 C CHE01710 P1 = XMIN - RMAX + DBLE(II-1) * DELR CHE01720 C CHE01730 DO 200 JJ = 1,NYPTS + 1 CHE01740 C CHE01750 P2 = YMIN - RMAX + DBLE(JJ-1) * DELR CHE01760 C CHE01770 DO 200 KK = 1,NZPTS + 1 CHE01780 C CHE01790 P3 = ZMIN - RMAX + DBLE(KK-1) * DELR CHE01800 C CHE01810 C CHE01820 C IS THIS POINT WITHIN A VAN DER WAALS SPHERE OR OUTSIDE THE CHE01830 C RMAX DISTANCE FROM ALL ATOMS? CHE01840 C CHE01850 RADMIN=50.0D0 CHE01860 DO 100 I=1,NATOMS CHE01870 VRAD = RADII(I) CHE01880 DIST = (P1 - C(1,I))**2 + (P2 - C(2,I))**2 + (P3 - C(3,I))**2 CHE01890 DIST = DSQRT(DIST) CHE01900 IF (DIST .LT. VRAD) GOTO 210 CHE01910 IF (DIST .LT. RADMIN) RADMIN = DIST CHE01920 100 CONTINUE CHE01930 IF (RADMIN .GT. RMAX) GOTO 210 CHE01940 C CHE01950 C STORE POINTS (IN ATOMIC UNITS) CHE01960 C CHE01970 IPOINT = IPOINT + 1 CHE01980 P(1,IPOINT) = P1 CHE01990 P(2,IPOINT) = P2 CHE02000 P(3,IPOINT) = P3 CHE02010 IF (IPO(2) .EQ. 1) CHE02020 $ WRITE(IOUT,*) 'POINT ',IPOINT,' X,Y,Z ',P1,P2,P3 CHE02030 210 CONTINUE CHE02040 200 CONTINUE CHE02050 C CHE02060 MAXPNTS = IPOINT CHE02070 WRITE(IOUT,*) ' NUMBER OF POINTS SELECTED FOR FITTING : ',MAXPNTS CHE02080 RETURN CHE02090 END CHE02100 C CHE02110 SUBROUTINE EP CHE02120 C CHE02130 C ROUTINE TO CALCULATE THE ELECTROSTATIC POTENTIAL FROM FIRST ORDCHE02140 C PERTURBATION THEORY CHE02150 C CHE02160 C M.M. FRANCL APRIL 1985 CHE02170 C MODIFIED VERSION OF A MEPHISTO ROUTINE CHE02180 C RESTRICTED TO CLOSED SHELL MOLECULES CHE02190 C CHE02200 IMPLICIT REAL*8 (A-H,O-Z) CHE02210 PARAMETER (NPOINTS = 50000) CHE02220 INTEGER*4 SHELLA,SHELLN,SHELLT,AOS,SHELLC,AON,HANDLE CHE02230 CHARACTER*40 CHKFIL CHE02240 C CHE02250 COMMON /IO/ IN,IOUT CHE02260 COMMON /IPO/ IPO(5) CHE02270 C+++ CHE02280 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS, CHE02290 $ IAN(401),ATMCHG(400),C(3,400) CHE02300 C CHE02310 C=== Gaussian88 Modification for enlarged common /b/. CHE02320 Common/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), CHE02330 $Z(2000),JAN(2000),ShellA(2000),ShellN(2000),ShellT(2000), CHE02340 $ShellC(2000),AOS(2000),AON(2000),NShell,MaxTyp CHE02350 C==== Old G86 Version of common /b/ CHE02360 c COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200), CHE02370 c $ X(400),Y(400),Z(400),JAN(400),SHELLA(400),SHELLN(400), CHE02380 c $ SHELLT(400),SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP CHE02390 C+++ CHE02400 C COMMON /B/ EXX(240),C1(240),C2(240),C3(240),X(80),Y(80),Z(80), CHE02410 C $ JAN(80),SHELLA(80),SHELLN(80),SHELLT(80),SHELLC(80) CHE02420 C $ ,AOS(80),AON(80),NSHELL,MAXTYP CHE02430 C COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS,IAN(101), CHE02440 C $ ATMCHG(100),C(3,100) CHE02450 COMMON /POINTS/ P(3,NPOINTS),MAXPNTS CHE02460 COMMON /ELP/ ELECP(NPOINTS) CHE02470 COMMON /CHARGE/ COEF_ALPHA(100000),COEF_BETA(100000),IUHF CHE02480 COMMON /OUT/ Q(400),RMS,PERCENT,NTITLE(20,3),I6TO5,NLIN,NEND(3), CHE02490 1 CHKFIL CHE02500 C CHE02510 DIMENSION HPERT(100000),INDEX(1280) CHE02520 C CHE02530 DATA IPTCHG/1.0/ CHE02540 DATA ZERO/0.0/, TWO/2.0/, VNUCMAX/30.0/ CHE02550 C DIVERT TO ROUTINE UEP IF WAVEFUNCTION IS UNRESTRICTED CHE02560 C HARTREE-FOCK WAVEFUNCTION CHE02570 C CHE02580 IF (IUHF .EQ. 1) THEN CHE02590 CALL UEP CHE02600 RETURN CHE02610 END IF CHE02620 C CHE02630 HANDLE = 0 CHE02640 C CHE02650 C SET UP THE INDEXING TABLE FOR HPERT CHE02660 C CHE02670 DO 100 I=1,NBASIS CHE02680 INDEX(I) = (I-1)*I/2 CHE02690 100 CONTINUE CHE02700 C CHE02710 C BEGIN LOOP TO CALCULATE ELECTROSTATIC POTENTIAL CHE02720 C CHE02730 NOCC = NEL / 2 CHE02740 MVIR = NOCC + 1 CHE02750 C CHE02760 C START OF LOOP CHE02770 C CHE02780 DO 200 NPNT=1,MAXPNTS CHE02790 X1 = P(1,NPNT) CHE02800 X2 = P(2,NPNT) CHE02810 X3 = P(3,NPNT) CHE02820 C CHE02830 C CALCULATE THE ONE-ELECTRON INTEGRALS CHE02840 C CHE02850 IF (IPO(5).EQ.1) THEN CHE02860 WRITE(IOUT,3010) CHE02870 3010 FORMAT(1X,'TIME FOR INTEGRALS') CHE02880 C*** CHE02890 C ISTAT = LIB$INIT_TIMER(HANDLE) CHE02900 C*** CHE02910 END IF CHE02920 C CHE02930 CALL INTGRL (HPERT,X1,X2,X3,IPTCHG,I6TO5) CHE02940 C CHE02950 C*** CHE02960 C IF (IPO(5).EQ.1) ISTAT = LIB$SHOW_TIMER(HANDLE) CHE02970 C*** CHE02980 C CHE02990 IF (IPO(4).EQ.1) CALL LINOUT (HPERT,NBASIS,0,0) CHE03000 C CHE03010 IF (IPO(5).EQ.1) THEN CHE03020 WRITE(IOUT,3000) CHE03030 3000 FORMAT(1X,'TIME FOR TRANSFORM') CHE03040 C*** CHE03050 C ISTAT = LIB$INIT_TIMER(HANDLE) CHE03060 C*** CHE03070 END IF CHE03080 C CHE03090 C FORM THE HPERT MATRIX ELEMENTS CHE03100 C CHE03110 E = ZERO CHE03120 ICOEFI = -NBASIS CHE03130 C CHE03140 C SUM OVER OCCUPIED MOS CHE03150 C CHE03160 DO 220 II=1,NOCC CHE03170 ICOEFI = ICOEFI + NBASIS CHE03180 C CHE03190 C CALCULATE ELECTROSTATIC POTENTIAL CHE03200 C CHE03210 DO 221 IP=1,NBASIS CHE03220 CPI = COEF_ALPHA(ICOEFI+IP) CHE03230 IPDEX = INDEX(IP) CHE03240 C CHE03250 DO 222 IQ=1,IP CHE03260 E = E + CPI * COEF_ALPHA(ICOEFI+IQ) * HPERT(IPDEX+IQ) CHE03270 222 CONTINUE CHE03280 DO 223 IQ=IP+1,NBASIS CHE03290 E = E + CPI * COEF_ALPHA(ICOEFI+IQ) * HPERT(IP+INDEX(IQ)) CHE03300 223 CONTINUE CHE03310 C CHE03320 221 CONTINUE CHE03330 220 CONTINUE CHE03340 C CHE03350 C*** CHE03360 C IF (IPO(5).EQ.1) ISTAT = LIB$SHOW_TIMER(HANDLE) CHE03370 C*** CHE03380 C CHE03390 C CALCULATE NUCLEAR PART OF ELECTROSTATIC POTENTIAL CHE03400 C CHE03410 VNUC = ZERO CHE03420 DO 300 IATOM=1,NATOMS CHE03430 DEL1 = C(1,IATOM) - X1 CHE03440 DEL2 = C(2,IATOM) - X2 CHE03450 DEL3 = C(3,IATOM) - X3 CHE03460 RA = DSQRT(DEL1*DEL1 + DEL2*DEL2 + DEL3*DEL3) CHE03470 IF (RA.EQ.ZERO) THEN CHE03480 VNUC=VNUCMAX CHE03490 GOTO 310 CHE03500 END IF CHE03510 VNUC = VNUC + IAN(IATOM) / RA CHE03520 300 CONTINUE CHE03530 310 CONTINUE CHE03540 C CHE03550 ELECP(NPNT) = (E * TWO + VNUC * IPTCHG) CHE03560 IF (IPO(5) .EQ. 1) WRITE(IOUT,*) 'E(',NPNT,') = ',E CHE03570 200 CONTINUE CHE03580 RETURN CHE03590 END CHE03600 SUBROUTINE FIT CHE03610 C CHE03620 C ROUTINE TO USE METHOD OF LAGRANGE MULTIPLIERS TO OBTAIN BEST CHE03630 C LEAST SQUARE FIT WITH CONSTRAINTS CHE03640 C CHE03650 C M.M. FRANCL CHE03660 C APRIL 1985 CHE03670 C CHE03680 IMPLICIT REAL*8 (A-H,O-Z) CHE03690 PARAMETER (NPOINTS = 50000) CHE03700 INTEGER*4 WHICH1 CHE03710 CHARACTER*40 CHKFIL CHE03720 C CHE03730 COMMON /IO/ IN,IOUT CHE03740 COMMON /IPO/ IPO(5) CHE03750 COMMON /ELP/ E(NPOINTS) CHE03760 COMMON /POINTS/ P(3,NPOINTS),MAXPNTS CHE03770 COMMON /OUT/ X(400),RMS,PERCENT,NTITLE(20,3),I6TO5,NLIN,NEND(3), CHE03780 1 CHKFIL CHE03790 C+++ CHE03800 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS, CHE03810 $ IAN(401),ATMCHG(400),C(3,400) CHE03820 C+++ CHE03830 C COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS,IAN(101), CHE03840 C $ ATMCHG(100),C(3,100) CHE03850 C CHE03860 DIMENSION A(400,400),Y(400),IS(2,400),IAD1(400),IAD2(400) CHE03870 DIMENSION D(400),WHICH1(3) CHE03880 C CHE03890 C DEBYE = CONVERSION FROM DEBYES TO AU CHE03900 C CHE03910 DATA ONE/1.0/, ZERO/0.0/, DEBYE/0.393427328/, MAXDIM/400/ CHE03920 DATA AU2CAL/627.51/, HALF/0.5/, HUNDRED/100.0/,NCONSTR/1/ CHE03930 C CHE03940 C SET UP MATRIX OF LINEAR COEFFICIENTS, A CHE03950 C CHE03960 C BEGIN LOOP OVER ROWS CHE03970 C CHE03980 DO 100 K=1,NATOMS CHE03990 C CHE04000 C BEGIN LOOP OVER COLUMNS CHE04010 C CHE04020 DO 200 MU=1,NATOMS CHE04030 C CHE04040 SUM = ZERO CHE04050 DO 400 I=1,MAXPNTS CHE04060 RIK = (P(1,I)-C(1,K))**2 + (P(2,I)-C(2,K))**2 + (P(3,I)-C(3,K))**2CHE04070 RIK = DSQRT(RIK) CHE04080 RIMU = (P(1,I)-C(1,MU))**2 + (P(2,I)-C(2,MU))**2 + CHE04090 $ (P(3,I)-C(3,MU))**2 CHE04100 RIMU = DSQRT(RIMU) CHE04110 SUM = SUM + ONE / (RIK * RIMU) CHE04120 400 CONTINUE CHE04130 C CHE04140 A(K,MU) = SUM CHE04150 200 CONTINUE CHE04160 C CHE04170 C FILL OUT COLUMNS CORRESPONDING TO LAGRANGE MULTIPLIERS CHE04180 C CHE04190 A(K,NATOMS+1) = HALF CHE04200 C CHE04210 C CHE04220 100 CONTINUE CHE04230 C CHE04240 C FILL OUT THE ROWS CORRESPONDING TO CONSTRAINTS CHE04250 C CHE04260 DO 500 MU=1,NATOMS CHE04270 A(NATOMS+1,MU) = ONE CHE04280 C CHE04290 500 CONTINUE CHE04300 C CHE04310 C FILL OUT THE BLOCK WHICH CONNECTS LAGRANGE MULTIPLIERS TO CHE04320 C CONSTRAINTS CHE04330 C CHE04340 DO 600 K=NATOMS+1,NATOMS+NCONSTR CHE04350 DO 600 MU=NATOMS+1,NATOMS+NCONSTR CHE04360 A(K,MU) = ZERO CHE04370 600 CONTINUE CHE04380 C CHE04390 C****DEBUG***** CHE04400 C CHE04410 IF (IPO(3) .EQ. 1) THEN CHE04420 WRITE(IOUT,*) 'A MATRIX' CHE04430 DO 699 K=1,NATOMS+NCONSTR CHE04440 WRITE(IOUT,1699) (A(K,MU),MU=1,NATOMS+NCONSTR) CHE04450 1699 FORMAT(1X,10F10.4) CHE04460 699 CONTINUE CHE04470 END IF CHE04480 C*************** CHE04490 C CHE04500 C CONSTRUCT COLUMN VECTOR, Y CHE04510 C CHE04520 DO 700 K=1,NATOMS CHE04530 SUM = ZERO CHE04540 DO 710 I=1,MAXPNTS CHE04550 RIK = (P(1,I)-C(1,K))**2 + (P(2,I)-C(2,K))**2 + CHE04560 $ (P(3,I)-C(3,K))**2 CHE04570 RIK = DSQRT(RIK) CHE04580 SUM = SUM + E(I) / RIK CHE04590 710 CONTINUE CHE04600 Y(K) = SUM CHE04610 IF (IPO(3) .EQ. 1) WRITE(IOUT,*) K,Y(K) CHE04620 700 CONTINUE CHE04630 C CHE04640 C CONSTRUCT THE PORTION OF Y CORRESPONDING TO LAGRANGE MULTIPLIERCHE04650 C CHE04660 C CHE04670 Y(NATOMS+1) = DFLOAT(ICHARG) CHE04680 C CHE04690 C CHE04700 IF (IPO(3) .EQ. 1) CHE04710 $ WRITE(IOUT,*) 'COL VECTR Y', (Y(KK),KK=1,NATOMS+NCONSTR) CHE04720 C CHE04730 C SOLVE MATRIX EQUATION AX = Y; CHE04740 C WHERE X = (Q1,Q2, ... QN,L1,L2, ... ,LN) CHE04750 C CHE04760 C X = A(INV)Y CHE04770 C CHE04780 C INVERT A CHE04790 C CHE04800 CALL INV(A,NATOMS+NCONSTR,IS,IAD1,IAD2,D,MAXDIM) CHE04810 C CHE04820 C****DEBUG***** CHE04830 C CHE04840 IF (IPO(3) .EQ. 1) THEN CHE04850 WRITE(IOUT,*) 'A INVERSE' CHE04860 DO 799 K=1,NATOMS+NCONSTR CHE04870 WRITE(IOUT,1699) (A(K,MU),MU=1,NATOMS+NCONSTR) CHE04880 799 CONTINUE CHE04890 END IF CHE04900 C************** CHE04910 C CHE04920 C PERFORM MATRIX MULTIPLICATION A(INV)Y CHE04930 C CHE04940 CALL MULTAY(A,Y,X,NATOMS+NCONSTR,MAXDIM) CHE04950 C CHE04960 IF (IPO(3) .EQ. 1) THEN CHE04970 WRITE(IOUT,*) 'CHARGES: ' CHE04980 DO 899 I=1,NATOMS CHE04990 WRITE(IOUT,*) IAN(I),X(I) CHE05000 899 CONTINUE CHE05010 END IF CHE05020 C CHE05030 C COMPUTE RMS DEVIATION AND MEAN ABSOLUTE % DEVIATION CHE05040 C CHE05050 RMS = ZERO CHE05060 PERCENT = ZERO CHE05070 DO 800 I=1,MAXPNTS CHE05080 EQ = ZERO CHE05090 DO 810 J=1,NATOMS CHE05100 DIST = (P(1,I)-C(1,J))**2 + (P(2,I)-C(2,J))**2 + CHE05110 $ (P(3,I)-C(3,J))**2 CHE05120 DIST = DSQRT(DIST) CHE05130 EQ = EQ + X(J) / DIST CHE05140 810 CONTINUE CHE05150 RMS = RMS + (E(I) - EQ)**2 CHE05160 PERCENT = PERCENT + DABS((E(I) - EQ) / E(I) * HUNDRED) CHE05170 IF (IPO(3) .EQ. 1) WRITE(IOUT,*) 'ACTUAL,CALC ',E(I),EQ CHE05180 800 CONTINUE CHE05190 IF (IPO(3) .EQ. 1) WRITE(IOUT,*) 'SUM OF SQUARES ',RMS CHE05200 RMS = DSQRT(RMS) * AU2CAL / MAXPNTS CHE05210 PERCENT = PERCENT / MAXPNTS CHE05220 IF (IPO(3) .EQ. 1) WRITE(IOUT,*) 'RMS, %',RMS,PERCENT CHE05230 RETURN CHE05240 END CHE05250 SUBROUTINE FMGEN(F,T,M) CHE05260 C CHE05270 IMPLICIT REAL*8 (A-H,O-Z) CHE05280 COMMON/IO/IN,IOUT CHE05290 C CHE05300 DIMENSION F(M) CHE05310 DIMENSION GA(35) CHE05320 C CHE05330 EQUIVALENCE (APPROX,OLDSUM) CHE05340 C CHE05350 DATA ZERO/0.0E0/, HALF/0.5E0/, ONE/1.0E0/, TWO/2.0E0/, TEN/10.0E0/CHE05360 $ ,PI/3.14159265358979E0/, F42/42.0E0/, F80/80.0E0/ CHE05370 C CHE05380 2001 FORMAT(42H1FAILURE IN FMGEN FOR SMALL T: IX.GT.50, / CHE05390 $ 6H IX = ,I3,7H, T = ,E20.14) CHE05400 2002 FORMAT(37H1FAILURE IN FMGEN FOR INTERMEDIATE T,/ CHE05410 $ 6H T = ,E20.14) CHE05420 C CHE05430 TEXP=ZERO CHE05440 IF(T-F80)2,3,3 CHE05450 2 TEXP=EXP(-T) CHE05460 3 CONTINUE CHE05470 IF(T-TEN)10,70,70 CHE05480 C***********************************************************************CHE05490 C 0 .LT. T .LT. 10 CHE05500 C***********************************************************************CHE05510 10 TERM=HALF*GA(M)*TEXP CHE05520 TX=ONE CHE05530 IX=M+1 CHE05540 SUM=TX/GA(IX) CHE05550 OLDSUM=SUM CHE05560 20 IX=IX+1 CHE05570 TX=TX*T CHE05580 IF(IX - 35) 40,40,30 CHE05590 30 WRITE(IOUT,2001)IX,T CHE05600 STOP 'FMGEN' CHE05610 40 SUM=SUM+TX/GA(IX) CHE05620 IF(TOL-ABS(OLDSUM/SUM-ONE))50,60,60 CHE05630 50 OLDSUM=SUM CHE05640 GO TO 20 CHE05650 60 F(M)=SUM*TERM CHE05660 GO TO 160 CHE05670 C CHE05680 70 IF(T-F42)80,150,150 CHE05690 C***********************************************************************CHE05700 C 10 .LE. T .LT. 42 CHE05710 C***********************************************************************CHE05720 80 A=FLOAT(M-1) CHE05730 B=A+HALF CHE05740 A=A-HALF CHE05750 TX=ONE/T CHE05760 MM1=M-1 CHE05770 APPROX=RPITWO*SQRT(TX)*(TX**MM1) CHE05780 IF(MM1)90,110,90 CHE05790 90 DO 100 IX=1,MM1 CHE05800 B=B-ONE CHE05810 100 APPROX=APPROX*B CHE05820 110 FIMULT=HALF*TEXP*TX CHE05830 SUM=ZERO CHE05840 IF(FIMULT)120,140,120 CHE05850 120 FIPROP=FIMULT/APPROX CHE05860 TERM=ONE CHE05870 SUM =ONE CHE05880 NOTRMS=INT(T)+MM1 CHE05890 DO 130 IX=2,NOTRMS CHE05900 TERM=TERM*A*TX CHE05910 SUM=SUM+TERM CHE05920 IF(ABS(TERM*FIPROP/SUM)-TOL)140,140,130 CHE05930 130 A=A-ONE CHE05940 WRITE(IOUT,2002)T CHE05950 STOP 'FMGEN' CHE05960 140 F(M)=APPROX-FIMULT*SUM CHE05970 GO TO 160 CHE05980 C***********************************************************************CHE05990 C T .GE. 42 CHE06000 C***********************************************************************CHE06010 150 TX=FLOAT(M)-HALF CHE06020 F(M)=HALF*GA(M)/(T**TX) CHE06030 C***********************************************************************CHE06040 C RECUR DOWNWARDS TO F(1) CHE06050 C***********************************************************************CHE06060 160 TX=T+T CHE06070 SUM=FLOAT(M+M-3) CHE06080 MM1=M-1 CHE06090 IF(MM1)170,190,170 CHE06100 170 DO 180 IX=1,MM1 CHE06110 F(M-IX)=(TX*F(M-IX+1)+TEXP)/SUM CHE06120 180 SUM=SUM-TWO CHE06130 190 RETURN CHE06140 C CHE06150 ENTRY FMSET CHE06160 C CHE06170 GA(1)=SQRT(PI) CHE06180 TOL=HALF CHE06190 DO 200 I=2,35 CHE06200 GA(I)=GA(I-1)*TOL CHE06210 200 TOL=TOL+ONE CHE06220 TOL = 5.0E-09 CHE06230 RPITWO=HALF*GA(1) CHE06240 RETURN CHE06250 END CHE06260 CHE06270 SUBROUTINE INTGRL (H,X1,X2,X3,ICHARG,I6TO5) CHE06280 C CHE06290 C ROUTINE TO CALCULATE THE ELECTRON-CHARGE MATRIX ELEMENTS FOR THE CHE06300 C POLARIZATION POTENTIAL. CODE REVISED FROM THE ONE ELECTRON PACKAGECHE06310 C AS IT EXISTED AUGUST, 1983. CHE06320 C CHE06330 C CHE06340 C REVISED BY M.M. FRANCL JANUARY 1984 FOR PRINCETON CHEMISTRY CHE06350 C DEPARTMENT VAX 11/780 CHE06360 C CHE06370 C REVISED TO BE COMPATIBLE WITH COMMON /B/ FROM GAUSSIAN 82 CHE06380 C MAY 1984 M.M. FRANCL CHE06390 C CHE06400 C REVISED TO USE ** BASIS SETS AND THOSE HAVING P ONLY SHELLS CHE06410 C JANUARY 1986 M.M. FRANCL CHE06420 C CHE06430 C REVISED FOR GAUSSIAN 86 CHECKPOINT FILES FOR YALE UNIVERSITY CHE06440 C FEBRUARY 1988 CURT BRENEMAN CHE06450 C CHE06460 C CHE06470 IMPLICIT REAL*8 (A-H,O-Z) CHE06480 INTEGER*4 SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON,SHLADF CHE06490 C CHE06500 C+++ CHE06510 COMMON /MOL/ NATOMS,JCHARG,MULTIP,NAE,NBE,NEL,NBASIS, CHE06520 $ IAN(401),ATMCHG(400),C(3,400) CHE06530 C CHE06540 C=== Gaussian88 Modification. New Common /b/ size. CHE06550 Common/B/EXX(6000),C1(6000),C2(6000),C3(2000),CF(2000), CHE06560 $SHLADF(4000),X(2000),Y(2000), CHE06570 $Z(2000),JAN(2000),ShellA(2000),ShellN(2000),ShellT(2000), CHE06580 $ShellC(2000),AOS(2000),AON(2000),NShell,MaxTyp CHE06590 C CHE06600 C=== Old G86 common /b/ CHE06610 c COMMON/B/EXX(1200),C1(1200),C2(1200),C3(400),CF(400),SHLADF(800),CHE06620 c $ X(400),Y(400),Z(400),JAN(400),SHELLA(400),SHELLN(400), CHE06630 c $ SHELLT(400),SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP CHE06640 c CHE06650 C+++ CHE06660 C COMMON /B/ EXX(240),C1(240),C2(240),C3(80),CF(80),SHLADF(160), CHE06670 C $ X(80),Y(80),Z(80), CHE06680 C $ JAN(80),SHELLA(80),SHELLN(80),SHELLT(80),SHELLC(80) CHE06690 C $ ,AOS(80),AON(80),NSHELL,MAXTYP CHE06700 C COMMON /MOL/ NATOMS,JCHARG,MULTIP,NAE,NBE,NEL,NBASIS,IAN(101), CHE06710 C $ ATMCHG(100),C(3,100) CHE06720 COMMON /IPO/ IPO(10) CHE06730 COMMON/IO/ IN,IOUT CHE06740 C CHE06750 DIMENSION H(1) CHE06760 DIMENSION RENORM(10) CHE06770 DIMENSION OF(9),OX(9),TX(13),ABX(5),ABY(5),ABZ(5),ABSQ(5), CHE06780 *A(5),B(5),F(5),APB(5),CPX(5),CPY(5),CPZ(5),FM(5) CHE06790 DIMENSION EPN(100) CHE06800 C CHE06810 COMMON/H100/ CHE06820 $EP00,EP10,EP20,EP30,EP40,EP50,EP60,EP70,EP80,EP90, CHE06830 $EP01,EP11,EP21,EP31,EP41,EP51,EP61,EP71,EP81,EP91, CHE06840 $EP02,EP12,EP22,EP32,EP42,EP52,EP62,EP72,EP82,EP92, CHE06850 $EP03,EP13,EP23,EP33,EP43,EP53,EP63,EP73,EP83,EP93, CHE06860 $EP04,EP14,EP24,EP34,EP44,EP54,EP64,EP74,EP84,EP94, CHE06870 $EP05,EP15,EP25,EP35,EP45,EP55,EP65,EP75,EP85,EP95, CHE06880 $EP06,EP16,EP26,EP36,EP46,EP56,EP66,EP76,EP86,EP96, CHE06890 $EP07,EP17,EP27,EP37,EP47,EP57,EP67,EP77,EP87,EP97, CHE06900 $EP08,EP18,EP28,EP38,EP48,EP58,EP68,EP78,EP88,EP98, CHE06910 $EP09,EP19,EP29,EP39,EP49,EP59,EP69,EP79,EP89,EP99 CHE06920 C CHE06930 DIMENSION EEP(100) CHE06940 DIMENSION MAX(6) CHE06950 C CHE06960 C LOCAL VARIABLES. CHE06970 C CHE06980 DIMENSION AG(6),CSA(6),CPA(6),CDA(6), CHE06990 $ BG(6),CSB(6),CPB(6),CDB(6), CHE07000 $ DPP(9) CHE07010 EQUIVALENCE(OF0,OF(1)),(OF1,OF(2)),(OF2,OF(3)), CHE07020 $ (OF3,OF(4)),(OF4,OF(5)),(OF5,OF(6)), CHE07030 $ (OF6,OF(7)),(OF7,OF(8)),(OF8,OF(9)) CHE07040 EQUIVALENCE(OX0,OX(1)),(OX1,OX(2)),(OX2,OX(3)), CHE07050 $ (OX3,OX(4)),(OX4,OX(5)),(OX5,OX(6)), CHE07060 $ (OX6,OX(7)),(OX7,OX(8)),(OX8,OX(9)) CHE07070 EQUIVALENCE(A1,A(2)),(A2,A(3)),(A3,A(4)),(A4,A(5)) CHE07080 EQUIVALENCE(B1,B(2)),(B2,B(3)),(B3,B(4)),(B4,B(5)) CHE07090 EQUIVALENCE(T01,T0),(T02,T1),(T03,T2), CHE07100 $ (T04,T3),(T05,T4),(T06,T5), CHE07110 $ (T07,T6),(T08,T7),(T09,T8) CHE07120 EQUIVALENCE(T10,TX(10)),(T11,TX(11)),(T12,TX(12)),(T13,TX(13)) CHE07130 EQUIVALENCE(T0,TX(1)),(T1,TX(2)),(T2,TX(3)), CHE07140 $ (T3,TX(4)),(T4,TX(5)),(T5,TX(6)), CHE07150 $ (T6,TX(7)),(T7,TX(8)),(T8,TX(9)) CHE07160 EQUIVALENCE(C001,T01),(C050,T02),(C054,T09), CHE07170 $ (C067,T13),(C068,T08),(C074,T03) CHE07180 EQUIVALENCE(ABX1,ABX(2)),(ABX2,ABX(3)), CHE07190 $ (ABX3,ABX(4)),(ABX4,ABX(5)) CHE07200 EQUIVALENCE(AB004,ABX1),(AB006,ABX2),(AB023,ABX3),(AB029,ABX4) CHE07210 EQUIVALENCE(ABY1,ABY(2)),(ABY2,ABY(3)), CHE07220 $ (ABY3,ABY(4)),(ABY4,ABY(5)) CHE07230 EQUIVALENCE(AB007,ABY1),(AB010,ABY2),(AB032,ABY3),(AB035,ABY4) CHE07240 EQUIVALENCE(ABZ1,ABZ(2)),(ABZ2,ABZ(3)), CHE07250 $ (ABZ3,ABZ(4)),(ABZ4,ABZ(5)) CHE07260 EQUIVALENCE(AB002,ABZ1),(AB003,ABZ2),(AB011,ABZ3),(AB017,ABZ4) CHE07270 EQUIVALENCE(ABSQ1,ABSQ(2)),(ABSQ2,ABSQ(3)), CHE07280 $ (ABSQ3,ABSQ(4)),(ABSQ4,ABSQ(5)) CHE07290 EQUIVALENCE(APB1,APB(2)),(APB2,APB(3)), CHE07300 $ (APB3,APB(4)),(APB4,APB(5)) CHE07310 EQUIVALENCE(CPX1,CPX(2)),(CPX2,CPX(3)), CHE07320 $ (CPX3,CPX(4)),(CPX4,CPX(5)) CHE07330 EQUIVALENCE(CPY1,CPY(2)),(CPY2,CPY(3)), CHE07340 $ (CPY3,CPY(4)),(CPY4,CPY(5)) CHE07350 EQUIVALENCE(CPZ1,CPZ(2)),(CPZ2,CPZ(3)), CHE07360 $ (CPZ3,CPZ(4)),(CPZ4,CPZ(5)) CHE07370 EQUIVALENCE(F1,F(2)),(F2,F(3)),(F3,F(4)),(F4,F(5)) CHE07380 EQUIVALENCE(FM0,FM(1)),(FM1,FM(2)),(FM2,FM(3)),(FM3,FM(4)), CHE07390 $ (FM4,FM(5)) CHE07400 EQUIVALENCE (D001,FM0) CHE07410 EQUIVALENCE(EP00,EEP(1)) CHE07420 C CHE07430 DATA MAX/1,4,9,1,4,10/ CHE07440 DATA TX/1.0E0,0.5E0,0.25E0,0.125E0,0.375E0,0.625E-01,0.1875E0, CHE07450 $ 0.75E0,1.5E0,2.25E0,1.125E0,0.0E0,3.0E0/ CHE07460 DATA ZERO/0.0/,HALF/0.5/,ONE/1.0/,ONEPT5/1.5/,TWO/2.0/,THREE/3.0/,CHE07470 *ROOT3/1.732050808/,PI/3.14159265358979/ CHE07480 DATA ANTOAU /1.889726878D0/ CHE07490 C CHE07500 2010 FORMAT(/1X,'ELECTRON-CHARGE MATRIX ELEMENTS'/) CHE07510 C CHE07520 C CALL ROUTINE TO MODIFY COMMON /B/ IF P ONLY SHELLS ARE PRESENT CHE07530 C CHE07540 CALL STAR (NBASIS,SHELLT,SHELLC,AOS,NSHELL,NOSTAR) CHE07550 C CHE07560 C***********************************************************************CHE07570 C INITIALIZE THIS SEGMENT. CHE07580 C***********************************************************************CHE07590 C CHE07600 C ******************************************************************CHE07610 C COMPUTE SIZE OF S T AND V ARRAYS CHE07620 C ******************************************************************CHE07630 NTT=(NBASIS*(NBASIS+1))/2 CHE07640 I5OR6=3 CHE07650 CC IF(IGO(4) .NE. 0) I5OR6 = 0 CHE07660 C ******************************************************************CHE07670 C INITIALIZE RENORM USED TO NORMALIZE D FUNCTIONS CHE07680 C ******************************************************************CHE07690 DO 100 I=1,10 CHE07700 100 RENORM(I)=ONE CHE07710 RENORM(5)=ROOT3 CHE07720 RENORM(8)=ROOT3 CHE07730 RENORM(9)=ROOT3 CHE07740 C ******************************************************************CHE07750 C CLEAR H ARRAY CHE07760 C ******************************************************************CHE07770 DO 50 I=1,NTT CHE07780 50 H(I)=ZERO CHE07790 C ******************************************************************CHE07800 C * INITIALIZE THE VARIABLES USED BY ROUTINE FMGEN. *CHE07810 C ******************************************************************CHE07820 CALL FMSET CHE07830 DO 95 I=1,5 CHE07840 95 FM(I)=ZERO CHE07850 ABX(1)=ONE CHE07860 ABY(1)=ONE CHE07870 ABZ(1)=ONE CHE07880 A(1)=ONE CHE07890 B(1)=ONE CHE07900 F(1)=ONE CHE07910 CPX(1)=ONE CHE07920 CPY(1)=ONE CHE07930 CPZ(1)=ONE CHE07940 APB(1)=ONE CHE07950 ABSQ(1)=ONE CHE07960 C***********************************************************************CHE07970 C LOOP OVER SHELLS ISHELL AND JSHELL. CHE07980 C***********************************************************************CHE07990 DO 1000 ISHELL=1,NSHELL CHE08000 DO 1000 JSHELL=1,ISHELL CHE08010 SYMFAC = ONE CHE08020 C ******************************************************************CHE08030 C ZERO LOCATIONS CHE08040 C ******************************************************************CHE08050 80 CONTINUE CHE08060 DO 9447 JI=1,100 CHE08070 EPN(JI)=ZERO CHE08080 9447 CONTINUE CHE08090 IF(SHELLT(ISHELL)-SHELLT(JSHELL))120,120,110 CHE08100 110 INEW=JSHELL CHE08110 JNEW=ISHELL CHE08120 LA=SHELLT(JSHELL) CHE08130 LB=SHELLT(ISHELL) CHE08140 GO TO 200 CHE08150 120 INEW=ISHELL CHE08160 JNEW=JSHELL CHE08170 LA=SHELLT(ISHELL) CHE08180 LB=SHELLT(JSHELL) CHE08190 200 CONTINUE CHE08200 LAP1=LA+1 CHE08210 LBP1=LB+1 CHE08220 LAMAX=MAX(LAP1+I5OR6) CHE08230 LBMAX=MAX(LBP1+I5OR6) CHE08240 ITYPE=3*LB+LA CHE08250 M=LA+LB+1 CHE08260 NGA=SHELLN(INEW) CHE08270 NGB=SHELLN(JNEW) CHE08280 AX=X(INEW) CHE08290 BX=X(JNEW) CHE08300 AY=Y(INEW) CHE08310 BY=Y(JNEW) CHE08320 AZ=Z(INEW) CHE08330 BZ=Z(JNEW) CHE08340 ISHA=SHELLA(INEW) CHE08350 ISHB=SHELLA(JNEW) CHE08360 ISHAD = SHLADF(INEW) CHE08370 ISHBD = SHLADF(JNEW) CHE08380 IAOS=AOS(INEW) CHE08390 JAOS=AOS(JNEW) CHE08400 C ******************************************************************CHE08410 C OBTAIN INFORMATION ABOUT SHELLS INEW AND JNEW CHE08420 C ******************************************************************CHE08430 DO 101 I=1,NGA CHE08440 N=ISHA+I-1 CHE08450 ND = ISHAD + I -1 CHE08460 IF (MAXTYP .LE. 1) ND=1 CHE08470 AG(I)=EXX(N) CHE08480 CSA(I)=C1(N) CHE08490 CPA(I)=C2(N) CHE08500 101 CDA(I)=C3(ND) CHE08510 CHE08520 DO 102 I=1,NGB CHE08530 N=ISHB+I-1 CHE08540 ND = ISHBD + I -1 CHE08550 BG(I)=EXX(N) CHE08560 CSB(I)=C1(N) CHE08570 CPB(I)=C2(N) CHE08580 102 CDB(I)=C3(ND) CHE08590 CHE08600 ABX(2)=BX-AX CHE08610 ABY(2)=BY-AY CHE08620 ABZ(2)=BZ-AZ CHE08630 RABSQ=ABX(2)*ABX(2)+ABY(2)*ABY(2)+ABZ(2)*ABZ(2) CHE08640 ABSQ(2)=RABSQ CHE08650 DO 103 I=3,5 CHE08660 ABX(I)=ABX(I-1)*ABX(2) CHE08670 ABY(I)=ABY(I-1)*ABY(2) CHE08680 ABZ(I)=ABZ(I-1)*ABZ(2) CHE08690 103 ABSQ(I)=ABSQ(I-1)*ABSQ(2) CHE08700 AB001=ONE CHE08710 AB005=ABX1*ABZ1 CHE08720 AB008=ABY1*ABZ1 CHE08730 AB009=ABX1*ABY1 CHE08740 AB012=ABX1*ABZ2 CHE08750 AB013=ABX2*ABZ1 CHE08760 AB014=ABY1*ABZ2 CHE08770 AB015=ABX1*ABY1*ABZ1 CHE08780 AB016=ABY2*ABZ1 CHE08790 AB018=ABX1*ABZ3 CHE08800 AB019=ABX2*ABZ2 CHE08810 AB020=ABY1*ABZ3 CHE08820 AB021=ABX1*ABY1*ABZ2 CHE08830 AB022=ABY2*ABZ2 CHE08840 AB024=ABX2*ABY1 CHE08850 AB025=ABX1*ABY2 CHE08860 AB026=ABX3*ABZ1 CHE08870 AB027=ABX2*ABY1*ABZ1 CHE08880 AB028=ABX1*ABY2*ABZ1 CHE08890 AB030=ABX3*ABY1 CHE08900 AB031=ABX2*ABY2 CHE08910 AB033=ABY3*ABZ1 CHE08920 AB034=ABX1*ABY3 CHE08930 C***********************************************************************CHE08940 C LOOP OVER GAUSSIANS (CONTRACTION LOOP). CHE08950 C***********************************************************************CHE08960 DO 105 IGAUSS=1,NGA CHE08970 AA=AG(IGAUSS) CHE08980 DO 105 JGAUSS=1,NGB CHE08990 BB=BG(JGAUSS) CHE09000 AAPBB=AA+BB CHE09010 APBB=ONE/AAPBB CHE09020 F2=TWO*AA*BB*APBB CHE09030 PX=(AA*AX+BB*BX)*APBB CHE09040 PY=(AA*AY+BB*BY)*APBB CHE09050 PZ=(AA*AZ+BB*BZ)*APBB CHE09060 A(2)=ONE/AA CHE09070 B(2)=ONE/BB CHE09080 F(2)=F2 CHE09090 APB(2)=APBB CHE09100 YX=PI*APBB CHE09110 EXX1=HALF*F2*RABSQ CHE09120 IF(EXX1-80.0E0)4172,4173,4173 CHE09130 4173 EXX1=ZERO CHE09140 GO TO 4714 CHE09150 4172 EXX1=EXP(-EXX1) CHE09160 4714 CONTINUE CHE09170 OV=(YX**ONEPT5)*EXX1 CHE09180 OVEK=THREE*AA*BB*APBB CHE09190 EK=F2*AA*BB*APBB*OV CHE09200 EP=TWO*YX*EXX1 CHE09210 DO 119 I=3,5 CHE09220 A(I)=A(I-1)*A(2) CHE09230 B(I)=B(I-1)*B(2) CHE09240 APB(I)=APB(I-1)*APB(2) CHE09250 119 F(I)=F(I-1)*F(2) CHE09260 DPP(1)=CSA(IGAUSS)*CSB(JGAUSS) CHE09270 DPP(2)=CPA(IGAUSS)*CSB(JGAUSS) CHE09280 DPP(3)=CDA(IGAUSS)*CSB(JGAUSS) CHE09290 DPP(4)=CSA(IGAUSS)*CPB(JGAUSS) CHE09300 DPP(5)=CPA(IGAUSS)*CPB(JGAUSS) CHE09310 DPP(6)=CDA(IGAUSS)*CPB(JGAUSS) CHE09320 DPP(7)=CSA(IGAUSS)*CDB(JGAUSS) CHE09330 DPP(8)=CPA(IGAUSS)*CDB(JGAUSS) CHE09340 DPP(9)=CDA(IGAUSS)*CDB(JGAUSS) CHE09350 DO 2132 I=1,9 CHE09360 OF(I)=DPP(I)*OV CHE09370 2132 OX(I)=DPP(I)*EK CHE09380 DO 2139 I=1,100 CHE09390 2139 EEP(I)=ZERO CHE09400 C002=T02*A1*F1 CHE09410 C006=T02*B1*F1 CHE09420 C007=T03*A1*B1*F2 CHE09430 C008=T03*A1*B1*F1 CHE09440 C027=T01*A1 CHE09450 C031=T01*A1*B1*F1 CHE09460 C032=T02*A1*B1 CHE09470 C051=T02*A1*B1*F2 CHE09480 C012=T02*B1 CHE09490 C013=T03*B2*F2 CHE09500 C014=T03*B2*F1 CHE09510 C036=T01*B2*F1 CHE09520 C037=T02*B2 CHE09530 C056=T01*B1*F1 CHE09540 C030=T01*B1 CHE09550 C018=T04*A1*B2*F2 CHE09560 IF(ITYPE-7)3060,3040,3041 CHE09570 3041 CONTINUE CHE09580 C003=T02*A1 CHE09590 C004=T03*A2*F2 CHE09600 C005=T03*A2*F1 CHE09610 C009=T04*A2*B1*F3 CHE09620 C010=T05*A2*B1*F2 CHE09630 C011=T04*A2*B1*F2 CHE09640 C017=T03*A1*B1 CHE09650 C019=T04*A1*B2*F1 CHE09660 C020=T04*A2*B1*F1 CHE09670 C021=T06*A2*B2*F4 CHE09680 C022=T05*A2*B2*F3 CHE09690 C023=T07*A2*B2*F2 CHE09700 C024=T07*A2*B2*F3 CHE09710 C025=T06*A2*B2*F3 CHE09720 C026=T06*A2*B2*F2 CHE09730 C028=T01*A2*F1 CHE09740 C029=T02*A2 CHE09750 C033=T08*A2*B1*F2 CHE09760 C034=T09*A2*B1*F1 CHE09770 C035=T02*A2*B1*F1 CHE09780 C040=T02*A1*B2*F1 CHE09790 C041=T03*A1*B2 CHE09800 C042=T03*A2*B1 CHE09810 C043=T02*A2*B2*F3 CHE09820 C044=T10*A2*B2*F2 CHE09830 C045=T08*A2*B2*F1 CHE09840 C046=T11*A2*B2*F2 CHE09850 C047=T05*A2*B2*F2 CHE09860 C048=T03*A2*B2*F1 CHE09870 C049=T01*A1*F1 CHE09880 C057=T12*A1*B1*F1 CHE09890 C058=T03*A1 CHE09900 C059=T03*B1 CHE09910 C060=T03*A1*B2*F3 CHE09920 C061=T04*B2*F2 CHE09930 C062=T04*B2*F1 CHE09940 C063=T03*A2*B1*F3 CHE09950 C064=T01*A1*B1*F2 CHE09960 C065=T09*B1*F1 CHE09970 C066=T09*A1*F1 CHE09980 C069=T04*A2*F2 CHE09990 C070=T04*A2*F1 CHE10000 C071=T03*A2*B1*F2 CHE10010 C072=T08*A1*F1 CHE10020 C073=T03*A1*B2*F2 CHE10030 C075=T08*B1*F1 CHE10040 C076=T04*A1*B1*F2 CHE10050 3040 CONTINUE CHE10060 C015=T04*A1*B2*F3 CHE10070 C016=T05*A1*B2*F2 CHE10080 C038=T08*A1*B2*F2 CHE10090 C039=T09*A1*B2*F1 CHE10100 C040=T02*A1*B2*F1 CHE10110 C052=T02*A1*B1*F1 CHE10120 C053=T03*B1*F1 CHE10130 C055=T03*A1*F1 CHE10140 3060 CONTINUE CHE10150 CX=X1 CHE10160 CY=X2 CHE10170 CZ=X3 CHE10180 CPX(2)=PX-CX CHE10190 CPY(2)=PY-CY CHE10200 CPZ(2)=PZ-CZ CHE10210 CP2=CPX(2)*CPX(2)+CPY(2)*CPY(2)+CPZ(2)*CPZ(2) CHE10220 CALL FMGEN(FM,AAPBB*CP2,M) CHE10230 DO 108 I=3,5 CHE10240 CPX(I)=CPX(I-1)*CPX(2) CHE10250 CPY(I)=CPY(I-1)*CPY(2) CHE10260 108 CPZ(I)=CPZ(I-1)*CPZ(2) CHE10270 EPAN=EP*FLOAT(-ICHARG) CHE10280 DO 2136 I=1,9 CHE10290 2136 OF(I)=DPP(I)*EPAN CHE10300 D002=CPZ1*FM1 CHE10310 D003=CPZ2*FM2 CHE10320 D004=APB1*FM1 CHE10330 D005=CPX1*FM1 CHE10340 D006=CPX1*CPZ1*FM2 CHE10350 D007=CPX2*FM2 CHE10360 D008=CPY1*FM1 CHE10370 D009=CPY1*CPZ1*FM2 CHE10380 D010=CPX1*CPY1*FM2 CHE10390 D011=CPY2*FM2 CHE10400 D012=CPZ3*FM3 CHE10410 D013=APB1*CPZ1*FM2 CHE10420 D014=CPX1*CPZ2*FM3 CHE10430 D015=APB1*CPX1*FM2 CHE10440 D016=CPX2*CPZ1*FM3 CHE10450 D017=CPY1*CPZ2*FM3 CHE10460 D018=APB1*CPY1*FM2 CHE10470 D019=CPX1*CPY1*CPZ1*FM3 CHE10480 D020=CPY2*CPZ1*FM3 CHE10490 D034=CPX3*FM3 CHE10500 D035=CPX2*CPY1*FM3 CHE10510 D036=CPX1*CPY2*FM3 CHE10520 D043=CPY3*FM3 CHE10530 C ******************************************************************CHE10540 C * SS *CHE10550 C ******************************************************************CHE10560 EP00=OF0*(+C001*AB001*D001) CHE10570 IF(ITYPE)3230,3262,3230 CHE10580 C ******************************************************************CHE10590 C * SP *CHE10600 C ******************************************************************CHE10610 3230 CONTINUE CHE10620 EP01=OF3*(-C006*AB002*D001-C001*AB001*D002) CHE10630 EP03=OF3*(-C006*AB004*D001-C001*AB001*D005) CHE10640 EP06=OF3*(-C006*AB007*D001-C001*AB001*D008) CHE10650 IF(ITYPE-7)3240,3242,3241 CHE10660 3240 IF(ITYPE-4)3262,3261,3260 CHE10670 C ******************************************************************CHE10680 C * DD *CHE10690 C ******************************************************************CHE10700 3241 CONTINUE CHE10710 D021=CPZ4*FM4 CHE10720 D022=APB1*CPZ2*FM3 CHE10730 D023=APB2*FM2 CHE10740 D024=CPX1*CPZ3*FM4 CHE10750 D025=APB1*CPX1*CPZ1*FM3 CHE10760 D026=CPX2*CPZ2*FM4 CHE10770 D027=APB1*CPX2*FM3 CHE10780 D028=CPY1*CPZ3*FM4 CHE10790 D029=APB1*CPY1*CPZ1*FM3 CHE10800 D030=CPX1*CPY1*CPZ2*FM4 CHE10810 D031=APB1*CPX1*CPY1*FM3 CHE10820 D032=CPY2*CPZ2*FM4 CHE10830 D033=APB1*CPY2*FM3 CHE10840 D037=CPX3*CPZ1*FM4 CHE10850 D038=CPX2*CPY1*CPZ1*FM4 CHE10860 D039=CPX1*CPY2*CPZ1*FM4 CHE10870 D040=CPX4*FM4 CHE10880 D041=CPX3*CPY1*FM4 CHE10890 D042=CPX2*CPY2*FM4 CHE10900 D044=CPY3*CPZ1*FM4 CHE10910 D045=CPX1*CPY3*FM4 CHE10920 D046=CPY4*FM4 CHE10930 EP20=OF2*(+C003*AB001*D001+C004*AB003*D001-C005*AB001*D001-C049*ABCHE10940 $002*D002+C001*AB001*D003-C050*AB001*D004) CHE10950 EP40=OF2*(+C004*AB005*D001-C002*AB004*D002-C002*AB002*D005+C001*ABCHE10960 $001*D006) CHE10970 EP50=OF2*(+C003*AB001*D001+C004*AB006*D001-C005*AB001*D001-C049*ABCHE10980 $004*D005+C001*AB001*D007-C050*AB001*D004) CHE10990 EP70=OF2*(+C004*AB008*D001-C002*AB007*D002-C002*AB002*D008+C001*ABCHE11000 $001*D009) CHE11010 EP80=OF2*(+C004*AB009*D001-C002*AB004*D008-C002*AB007*D005+C001*ABCHE11020 $001*D010) CHE11030 EP90=OF2*(+C003*AB001*D001+C004*AB010*D001-C005*AB001*D001-C049*ABCHE11040 $007*D008+C001*AB001*D011-C050*AB001*D004) CHE11050 EP21=OF5*(-C008*AB002*D001-C003*AB001*D002-C009*AB011*D001+C010*ABCHE11060 $002*D001+C051*AB003*D002-C052*AB001*D002-C006*AB002*D003+C053*AB00CHE11070 $2*D004-C004*AB003*D002+C005*AB001*D002+C049*AB002*D003-C002*AB002*CHE11080 $D004-C001*AB001*D012+C054*AB001*D013) CHE11090 EP41=OF5*(-C009*AB012*D001+C011*AB004*D001+C007*AB005*D002+C007*ABCHE11100 $003*D005-C008*AB001*D005-C006*AB002*D006-C004*AB005*D002+C002*AB00CHE11110 $4*D003-C055*AB004*D004+C002*AB002*D006-C001*AB001*D014+C050*AB001*CHE11120 $D015) CHE11130 EP51=OF5*(-C008*AB002*D001-C003*AB001*D002-C009*AB013*D001+C011*ABCHE11140 $002*D001+C051*AB005*D005-C006*AB002*D007+C053*AB002*D004-C004*AB00CHE11150 $6*D002+C005*AB001*D002+C049*AB004*D006-C001*AB001*D016+C050*AB001*CHE11160 $D013) CHE11170 EP71=OF5*(-C009*AB014*D001+C011*AB007*D001+C007*AB008*D002+C007*ABCHE11180 $003*D008-C008*AB001*D008-C006*AB002*D009-C004*AB008*D002+C002*AB00CHE11190 $7*D003-C055*AB007*D004+C002*AB002*D009-C001*AB001*D017+C050*AB001*CHE11200 $D018) CHE11210 EP81=OF5*(-C009*AB015*D001+C007*AB005*D008+C007*AB008*D005-C006*ABCHE11220 $002*D010-C004*AB009*D002+C002*AB004*D009+C002*AB007*D006-C001*AB00CHE11230 $1*D019) CHE11240 EP91=OF5*(-C008*AB002*D001-C003*AB001*D002-C009*AB016*D001+C011*ABCHE11250 $002*D001+C051*AB008*D008-C006*AB002*D011+C053*AB002*D004-C004*AB01CHE11260 $0*D002+C005*AB001*D002+C049*AB007*D009-C001*AB001*D020+C050*AB001*CHE11270 $D013) CHE11280 EP22=OF8*(+C017*AB001*D001+C018*AB003*D001-C019*AB001*D001+C057*ABCHE11290 $002*D002+C003*AB001*D003-C058*AB001*D004+C011*AB003*D001-C020*AB00CHE11300 $1*D001+C012*AB001*D003-C059*AB001*D004+C021*AB017*D001-C022*AB003*CHE11310 $D001-C060*AB011*D002+C023*AB001*D001+C038*AB002*D002+C013*AB003*D0CHE11320 $03-C061*AB003*D004-C014*AB001*D003+C062*AB001*D004+C063*AB011*D002CHE11330 $-C033*AB002*D002-C064*AB003*D003+C051*AB003*D004+C031*AB001*D003-CCHE11340 $052*AB001*D004+C056*AB002*D012-C065*AB002*D013+C004*AB003*D003-C00CHE11350 $5*AB001*D003-C049*AB002*D012+C066*AB002*D013+C001*AB001*D021-C067*CHE11360 $AB001*D022+C068*AB001*D023-C069*AB003*D004+C070*AB001*D004) CHE11370 EP42=OF8*(+C011*AB005*D001-C008*AB004*D002-C008*AB002*D005+C012*ABCHE11380 $001*D006+C021*AB018*D001-C024*AB005*D001-C015*AB012*D002-C015*AB01CHE11390 $1*D005+C016*AB002*D005+C013*AB003*D006+C018*AB004*D002-C014*AB001*CHE11400 $D006+C063*AB012*D002-C071*AB004*D002-C051*AB005*D003+C007*AB005*D0CHE11410 $04-C051*AB003*D006+C052*AB001*D006+C056*AB002*D014-C006*AB002*D015CHE11420 $+C004*AB005*D003-C002*AB004*D012+C072*AB004*D013-C002*AB002*D014+CCHE11430 $001*AB001*D024-C054*AB001*D025-C069*AB005*D004+C055*AB002*D015) CHE11440 EP52=OF8*(+C017*AB001*D001+C018*AB003*D001-C019*AB001*D001+C052*ABCHE11450 $002*D002+C003*AB001*D003-C058*AB001*D004+C011*AB006*D001-C020*AB00CHE11460 $1*D001-C052*AB004*D005+C012*AB001*D007-C059*AB001*D004+C021*AB019*CHE11470 $D001-C025*AB003*D001-C060*AB012*D005+C013*AB003*D007-C061*AB003*D0CHE11480 $04-C025*AB006*D001+C026*AB001*D001+C073*AB004*D005-C014*AB001*D007CHE11490 $+C062*AB001*D004+C063*AB013*D002-C071*AB002*D002-C064*AB005*D006+CCHE11500 $056*AB002*D016-C006*AB002*D013+C004*AB006*D003-C005*AB001*D003-C04CHE11510 $9*AB004*D014+C001*AB001*D026-C050*AB001*D022-C069*AB006*D004+C070*CHE11520 $AB001*D004+C002*AB004*D015-C050*AB001*D027+C074*AB001*D023) CHE11530 EP72=OF8*(+C011*AB008*D001-C008*AB007*D002-C008*AB002*D008+C012*ABCHE11540 $001*D009+C021*AB020*D001-C024*AB008*D001-C015*AB014*D002-C015*AB01CHE11550 $1*D008+C016*AB002*D008+C013*AB003*D009+C018*AB007*D002-C014*AB001*CHE11560 $D009+C063*AB014*D002-C071*AB007*D002-C051*AB008*D003+C007*AB008*D0CHE11570 $04-C051*AB003*D009+C052*AB001*D009+C056*AB002*D017-C006*AB002*D018CHE11580 $+C004*AB008*D003-C002*AB007*D012+C072*AB007*D013-C002*AB002*D017+CCHE11590 $001*AB001*D028-C054*AB001*D029-C069*AB008*D004+C055*AB002*D018) CHE11600 EP82=OF8*(+C011*AB009*D001-C008*AB004*D008-C008*AB007*D005+C012*ABCHE11610 $001*D010+C021*AB021*D001-C015*AB012*D008-C015*AB014*D005+C013*AB00CHE11620 $3*D010-C025*AB009*D001+C018*AB004*D008+C018*AB007*D005-C014*AB001*CHE11630 $D010+C063*AB015*D002-C051*AB005*D009-C051*AB008*D006+C056*AB002*D0CHE11640 $19+C004*AB009*D003-C002*AB004*D017-C002*AB007*D014+C001*AB001*D030CHE11650 $-C069*AB009*D004+C055*AB004*D018+C055*AB007*D015-C050*AB001*D031) CHE11660 EP92=OF8*(+C017*AB001*D001+C018*AB003*D001-C019*AB001*D001+C052*ABCHE11670 $002*D002+C003*AB001*D003-C058*AB001*D004+C011*AB010*D001-C020*AB00CHE11680 $1*D001-C052*AB007*D008+C012*AB001*D011-C059*AB001*D004+C021*AB022*CHE11690 $D001-C025*AB003*D001-C060*AB014*D008+C013*AB003*D011-C061*AB003*D0CHE11700 $04-C025*AB010*D001+C026*AB001*D001+C073*AB007*D008-C014*AB001*D011CHE11710 $+C062*AB001*D004+C063*AB016*D002-C071*AB002*D002-C064*AB008*D009+CCHE11720 $056*AB002*D020-C006*AB002*D013+C004*AB010*D003-C005*AB001*D003-C04CHE11730 $9*AB007*D017+C001*AB001*D032-C050*AB001*D022-C069*AB010*D004+C070*CHE11740 $AB001*D004+C002*AB007*D018-C050*AB001*D033+C074*AB001*D023) CHE11750 EP23=OF5*(-C008*AB004*D001-C003*AB001*D005-C009*AB012*D001+C011*ABCHE11760 $004*D001+C051*AB005*D002-C006*AB004*D003+C053*AB004*D004-C004*AB00CHE11770 $3*D005+C005*AB001*D005+C049*AB002*D006-C001*AB001*D014+C050*AB001*CHE11780 $D015) CHE11790 EP43=OF5*(-C009*AB013*D001+C007*AB006*D002+C011*AB002*D001-C008*ABCHE11800 $001*D002+C007*AB005*D005-C006*AB004*D006-C004*AB005*D005+C002*AB00CHE11810 $4*D006+C002*AB002*D007-C001*AB001*D016-C055*AB002*D004+C050*AB001*CHE11820 $D013) CHE11830 EP53=OF5*(-C008*AB004*D001-C003*AB001*D005-C009*AB023*D001+C010*ABCHE11840 $004*D001+C051*AB006*D005-C052*AB001*D005-C006*AB004*D007+C053*AB00CHE11850 $4*D004-C004*AB006*D005+C005*AB001*D005+C049*AB004*D007-C002*AB004*CHE11860 $D004-C001*AB001*D034+C054*AB001*D015) CHE11870 EP73=OF5*(-C009*AB015*D001+C007*AB009*D002+C007*AB005*D008-C006*ABCHE11880 $004*D009-C004*AB008*D005+C002*AB007*D006+C002*AB002*D010-C001*AB00CHE11890 $1*D019) CHE11900 EP83=OF5*(-C009*AB024*D001+C007*AB006*D008+C011*AB007*D001-C008*ABCHE11910 $001*D008+C007*AB009*D005-C006*AB004*D010-C004*AB009*D005+C002*AB00CHE11920 $4*D010+C002*AB007*D007-C001*AB001*D035-C055*AB007*D004+C050*AB001*CHE11930 $D018) CHE11940 EP93=OF5*(-C008*AB004*D001-C003*AB001*D005-C009*AB025*D001+C011*ABCHE11950 $004*D001+C051*AB009*D008-C006*AB004*D011+C053*AB004*D004-C004*AB01CHE11960 $0*D005+C005*AB001*D005+C049*AB007*D010-C001*AB001*D036+C050*AB001*CHE11970 $D015) CHE11980 EP24=OF8*(+C018*AB005*D001+C008*AB004*D002+C008*AB002*D005+C003*ABCHE11990 $001*D006+C021*AB018*D001-C024*AB005*D001-C060*AB012*D002+C073*AB00CHE12000 $4*D002+C013*AB005*D003-C061*AB005*D004+C009*AB012*D002-C011*AB004*CHE12010 $D002-C051*AB005*D003+C007*AB005*D004+C006*AB004*D012-C075*AB004*D0CHE12020 $13+C009*AB011*D005-C010*AB002*D005-C051*AB003*D006+C052*AB001*D006CHE12030 $+C006*AB002*D014-C053*AB002*D015+C004*AB003*D006-C005*AB001*D006-CCHE12040 $049*AB002*D014+C002*AB002*D015+C001*AB001*D024-C054*AB001*D025) CHE12050 EP44=OF8*(+C021*AB019*D001-C025*AB006*D001-C015*AB013*D002-C025*ABCHE12060 $003*D001+C026*AB001*D001+C018*AB002*D002-C015*AB012*D005+C018*AB00CHE12070 $4*D005+C013*AB005*D006+C009*AB013*D002-C007*AB006*D003+C076*AB006*CHE12080 $D004-C011*AB002*D002+C008*AB001*D003-C008*AB001*D004-C051*AB005*D0CHE12090 $06+C006*AB004*D014-C053*AB004*D015+C009*AB012*D005-C011*AB004*D005CHE12100 $-C007*AB003*D007+C008*AB001*D007+C006*AB002*D016+C076*AB003*D004-CCHE12110 $053*AB002*D013+C004*AB005*D006-C002*AB004*D014+C055*AB004*D015-C00CHE12120 $2*AB002*D016+C001*AB001*D026-C050*AB001*D027+C055*AB002*D013-C050*CHE12130 $AB001*D022+C074*AB001*D023) CHE12140 EP54=OF8*(+C018*AB005*D001+C008*AB004*D002+C008*AB002*D005+C003*ABCHE12150 $001*D006+C021*AB026*D001-C024*AB005*D001-C060*AB013*D005+C073*AB00CHE12160 $2*D005+C013*AB005*D007-C061*AB005*D004+C009*AB023*D002-C010*AB004*CHE12170 $D002-C051*AB006*D006+C052*AB001*D006+C006*AB004*D016-C053*AB004*D0CHE12180 $13+C009*AB013*D005-C011*AB002*D005-C051*AB005*D007+C007*AB005*D004CHE12190 $+C006*AB002*D034-C075*AB002*D015+C004*AB006*D006-C005*AB001*D006-CCHE12200 $049*AB004*D016+C002*AB004*D013+C001*AB001*D037-C054*AB001*D025) CHE12210 EP74=OF8*(+C021*AB021*D001-C025*AB009*D001-C015*AB015*D002-C015*ABCHE12220 $012*D008+C018*AB004*D008+C013*AB005*D009+C009*AB015*D002-C007*AB00CHE12230 $9*D003+C076*AB009*D004-C007*AB005*D009+C006*AB004*D017-C053*AB004*CHE12240 $D018+C009*AB014*D005-C011*AB007*D005-C007*AB008*D006-C007*AB003*D0CHE12250 $10+C008*AB001*D010+C006*AB002*D019+C004*AB008*D006-C002*AB007*D014CHE12260 $+C055*AB007*D015-C002*AB002*D019+C001*AB001*D030-C050*AB001*D031) CHE12270 EP84=OF8*(+C021*AB027*D001-C015*AB013*D008-C025*AB008*D001+C018*ABCHE12280 $002*D008-C015*AB015*D005+C013*AB005*D010+C009*AB024*D002-C007*AB00CHE12290 $6*D009-C011*AB007*D002+C008*AB001*D009-C007*AB009*D006+C006*AB004*CHE12300 $D019+C009*AB015*D005-C007*AB005*D010-C007*AB008*D007+C006*AB002*D0CHE12310 $35+C076*AB008*D004-C053*AB002*D018+C004*AB009*D006-C002*AB004*D019CHE12320 $-C002*AB007*D016+C001*AB001*D038+C055*AB007*D013-C050*AB001*D029) CHE12330 EP94=OF8*(+C018*AB005*D001+C008*AB004*D002+C008*AB002*D005+C003*ABCHE12340 $001*D006+C021*AB028*D001-C025*AB005*D001-C060*AB015*D008+C013*AB00CHE12350 $5*D011-C061*AB005*D004+C009*AB025*D002-C011*AB004*D002-C051*AB009*CHE12360 $D009+C006*AB004*D020-C053*AB004*D013+C009*AB016*D005-C011*AB002*D0CHE12370 $05-C051*AB008*D010+C006*AB002*D036-C053*AB002*D015+C004*AB010*D006CHE12380 $-C005*AB001*D006-C049*AB007*D019+C001*AB001*D039-C050*AB001*D025) CHE12390 EP25=OF8*(+C017*AB001*D001+C018*AB006*D001-C019*AB001*D001+C052*ABCHE12400 $004*D005+C003*AB001*D007-C058*AB001*D004+C011*AB003*D001-C020*AB00CHE12410 $1*D001-C052*AB002*D002+C012*AB001*D003-C059*AB001*D004+C021*AB019*CHE12420 $D001-C025*AB006*D001-C060*AB013*D002+C013*AB006*D003-C061*AB006*D0CHE12430 $04-C025*AB003*D001+C026*AB001*D001+C073*AB002*D002-C014*AB001*D003CHE12440 $+C062*AB001*D004+C063*AB012*D005-C071*AB004*D005-C064*AB005*D006+CCHE12450 $056*AB004*D014-C006*AB004*D015+C004*AB003*D007-C005*AB001*D007-C04CHE12460 $9*AB002*D016+C001*AB001*D026-C050*AB001*D027-C069*AB003*D004+C070*CHE12470 $AB001*D004+C002*AB002*D013-C050*AB001*D022+C074*AB001*D023) CHE12480 EP45=OF8*(+C011*AB005*D001-C008*AB004*D002-C008*AB002*D005+C012*ABCHE12490 $001*D006+C021*AB026*D001-C015*AB023*D002-C024*AB005*D001+C016*AB00CHE12500 $4*D002-C015*AB013*D005+C013*AB006*D006+C018*AB002*D005-C014*AB001*CHE12510 $D006+C063*AB013*D005-C051*AB006*D006-C071*AB002*D005+C052*AB001*D0CHE12520 $06-C051*AB005*D007+C056*AB004*D016+C007*AB005*D004-C006*AB004*D013CHE12530 $+C004*AB005*D007-C002*AB004*D016-C002*AB002*D034+C001*AB001*D037+CCHE12540 $072*AB002*D015-C054*AB001*D025-C069*AB005*D004+C055*AB004*D013) CHE12550 EP55=OF8*(+C017*AB001*D001+C018*AB006*D001-C019*AB001*D001+C057*ABCHE12560 $004*D005+C003*AB001*D007-C058*AB001*D004+C011*AB006*D001-C020*AB00CHE12570 $1*D001+C012*AB001*D007-C059*AB001*D004+C021*AB029*D001-C022*AB006*CHE12580 $D001-C060*AB023*D005+C023*AB001*D001+C038*AB004*D005+C013*AB006*D0CHE12590 $07-C061*AB006*D004-C014*AB001*D007+C062*AB001*D004+C063*AB023*D005CHE12600 $-C033*AB004*D005-C064*AB006*D007+C051*AB006*D004+C031*AB001*D007-CCHE12610 $052*AB001*D004+C056*AB004*D034-C065*AB004*D015+C004*AB006*D007-C00CHE12620 $5*AB001*D007-C049*AB004*D034+C066*AB004*D015+C001*AB001*D040-C067*CHE12630 $AB001*D027+C068*AB001*D023-C069*AB006*D004+C070*AB001*D004) CHE12640 EP75=OF8*(+C011*AB008*D001-C008*AB007*D002-C008*AB002*D008+C012*ABCHE12650 $001*D009+C021*AB027*D001-C015*AB024*D002-C015*AB013*D008+C013*AB00CHE12660 $6*D009-C025*AB008*D001+C018*AB007*D002+C018*AB002*D008-C014*AB001*CHE12670 $D009+C063*AB015*D005-C051*AB009*D006-C051*AB005*D010+C056*AB004*D0CHE12680 $19+C004*AB008*D007-C002*AB007*D016-C002*AB002*D035+C001*AB001*D038CHE12690 $-C069*AB008*D004+C055*AB007*D013+C055*AB002*D018-C050*AB001*D029) CHE12700 EP85=OF8*(+C011*AB009*D001-C008*AB004*D008-C008*AB007*D005+C012*ABCHE12710 $001*D010+C021*AB030*D001-C015*AB023*D008-C024*AB009*D001+C016*AB00CHE12720 $4*D008-C015*AB024*D005+C013*AB006*D010+C018*AB007*D005-C014*AB001*CHE12730 $D010+C063*AB024*D005-C051*AB006*D010-C071*AB007*D005+C052*AB001*D0CHE12740 $10-C051*AB009*D007+C056*AB004*D035+C007*AB009*D004-C006*AB004*D018CHE12750 $+C004*AB009*D007-C002*AB004*D035-C002*AB007*D034+C001*AB001*D041+CCHE12760 $072*AB007*D015-C054*AB001*D031-C069*AB009*D004+C055*AB004*D018) CHE12770 EP95=OF8*(+C017*AB001*D001+C018*AB006*D001-C019*AB001*D001+C052*ABCHE12780 $004*D005+C003*AB001*D007-C058*AB001*D004+C011*AB010*D001-C020*AB00CHE12790 $1*D001-C052*AB007*D008+C012*AB001*D011-C059*AB001*D004+C021*AB031*CHE12800 $D001-C025*AB006*D001-C060*AB024*D008+C013*AB006*D011-C061*AB006*D0CHE12810 $04-C025*AB010*D001+C026*AB001*D001+C073*AB007*D008-C014*AB001*D011CHE12820 $+C062*AB001*D004+C063*AB025*D005-C071*AB004*D005-C064*AB009*D010+CCHE12830 $056*AB004*D036-C006*AB004*D015+C004*AB010*D007-C005*AB001*D007-C04CHE12840 $9*AB007*D035+C001*AB001*D042-C050*AB001*D027-C069*AB010*D004+C070*CHE12850 $AB001*D004+C002*AB007*D018-C050*AB001*D033+C074*AB001*D023) CHE12860 EP26=OF5*(-C008*AB007*D001-C003*AB001*D008-C009*AB014*D001+C011*ABCHE12870 $007*D001+C051*AB008*D002-C006*AB007*D003+C053*AB007*D004-C004*AB00CHE12880 $3*D008+C005*AB001*D008+C049*AB002*D009-C001*AB001*D017+C050*AB001*CHE12890 $D018) CHE12900 EP46=OF5*(-C009*AB015*D001+C007*AB009*D002+C007*AB008*D005-C006*ABCHE12910 $007*D006-C004*AB005*D008+C002*AB004*D009+C002*AB002*D010-C001*AB00CHE12920 $1*D019) CHE12930 EP56=OF5*(-C008*AB007*D001-C003*AB001*D008-C009*AB024*D001+C011*ABCHE12940 $007*D001+C051*AB009*D005-C006*AB007*D007+C053*AB007*D004-C004*AB00CHE12950 $6*D008+C005*AB001*D008+C049*AB004*D010-C001*AB001*D035+C050*AB001*CHE12960 $D018) CHE12970 EP76=OF5*(-C009*AB016*D001+C007*AB010*D002+C011*AB002*D001-C008*ABCHE12980 $001*D002+C007*AB008*D008-C006*AB007*D009-C004*AB008*D008+C002*AB00CHE12990 $7*D009+C002*AB002*D011-C001*AB001*D020-C055*AB002*D004+C050*AB001*CHE13000 $D013) CHE13010 EP86=OF5*(-C009*AB025*D001+C011*AB004*D001+C007*AB009*D008+C007*ABCHE13020 $010*D005-C008*AB001*D005-C006*AB007*D010-C004*AB009*D008+C002*AB00CHE13030 $4*D011-C055*AB004*D004+C002*AB007*D010-C001*AB001*D036+C050*AB001*CHE13040 $D015) CHE13050 EP96=OF5*(-C008*AB007*D001-C003*AB001*D008-C009*AB032*D001+C010*ABCHE13060 $007*D001+C051*AB010*D008-C052*AB001*D008-C006*AB007*D011+C053*AB00CHE13070 $7*D004-C004*AB010*D008+C005*AB001*D008+C049*AB007*D011-C002*AB007*CHE13080 $D004-C001*AB001*D043+C054*AB001*D018) CHE13090 EP27=OF8*(+C018*AB008*D001+C008*AB007*D002+C008*AB002*D008+C003*ABCHE13100 $001*D009+C021*AB020*D001-C024*AB008*D001-C060*AB014*D002+C073*AB00CHE13110 $7*D002+C013*AB008*D003-C061*AB008*D004+C009*AB014*D002-C011*AB007*CHE13120 $D002-C051*AB008*D003+C007*AB008*D004+C006*AB007*D012-C075*AB007*D0CHE13130 $13+C009*AB011*D008-C010*AB002*D008-C051*AB003*D009+C052*AB001*D009CHE13140 $+C006*AB002*D017-C053*AB002*D018+C004*AB003*D009-C005*AB001*D009-CCHE13150 $049*AB002*D017+C002*AB002*D018+C001*AB001*D028-C054*AB001*D029) CHE13160 EP47=OF8*(+C021*AB021*D001-C025*AB009*D001-C015*AB015*D002-C015*ABCHE13170 $014*D005+C018*AB007*D005+C013*AB008*D006+C009*AB015*D002-C007*AB00CHE13180 $9*D003+C076*AB009*D004-C007*AB008*D006+C006*AB007*D014-C053*AB007*CHE13190 $D015+C009*AB012*D008-C011*AB004*D008-C007*AB005*D009-C007*AB003*D0CHE13200 $10+C008*AB001*D010+C006*AB002*D019+C004*AB005*D009-C002*AB004*D017CHE13210 $+C055*AB004*D018-C002*AB002*D019+C001*AB001*D030-C050*AB001*D031) CHE13220 EP57=OF8*(+C018*AB008*D001+C008*AB007*D002+C008*AB002*D008+C003*ABCHE13230 $001*D009+C021*AB027*D001-C025*AB008*D001-C060*AB015*D005+C013*AB00CHE13240 $8*D007-C061*AB008*D004+C009*AB024*D002-C011*AB007*D002-C051*AB009*CHE13250 $D006+C006*AB007*D016-C053*AB007*D013+C009*AB013*D008-C011*AB002*D0CHE13260 $08-C051*AB005*D010+C006*AB002*D035-C053*AB002*D018+C004*AB006*D009CHE13270 $-C005*AB001*D009-C049*AB004*D019+C001*AB001*D038-C050*AB001*D029) CHE13280 EP77=OF8*(+C021*AB022*D001-C025*AB010*D001-C015*AB016*D002-C025*ABCHE13290 $003*D001+C026*AB001*D001+C018*AB002*D002-C015*AB014*D008+C018*AB00CHE13300 $7*D008+C013*AB008*D009+C009*AB016*D002-C007*AB010*D003+C076*AB010*CHE13310 $D004-C011*AB002*D002+C008*AB001*D003-C008*AB001*D004-C051*AB008*D0CHE13320 $09+C006*AB007*D017-C053*AB007*D018+C009*AB014*D008-C011*AB007*D008CHE13330 $-C007*AB003*D011+C008*AB001*D011+C006*AB002*D020+C076*AB003*D004-CCHE13340 $053*AB002*D013+C004*AB008*D009-C002*AB007*D017+C055*AB007*D018-C00CHE13350 $2*AB002*D020+C001*AB001*D032-C050*AB001*D033+C055*AB002*D013-C050*CHE13360 $AB001*D022+C074*AB001*D023) CHE13370 EP87=OF8*(+C021*AB028*D001-C025*AB005*D001-C015*AB015*D008-C015*ABCHE13380 $016*D005+C018*AB002*D005+C013*AB008*D010+C009*AB025*D002-C011*AB00CHE13390 $4*D002-C007*AB009*D009-C007*AB010*D006+C008*AB001*D006+C006*AB007*CHE13400 $D019+C009*AB015*D008-C007*AB005*D011+C076*AB005*D004-C007*AB008*D0CHE13410 $10+C006*AB002*D036-C053*AB002*D015+C004*AB009*D009-C002*AB004*D020CHE13420 $+C055*AB004*D013-C002*AB007*D019+C001*AB001*D039-C050*AB001*D025) CHE13430 EP97=OF8*(+C018*AB008*D001+C008*AB007*D002+C008*AB002*D008+C003*ABCHE13440 $001*D009+C021*AB033*D001-C024*AB008*D001-C060*AB016*D008+C073*AB00CHE13450 $2*D008+C013*AB008*D011-C061*AB008*D004+C009*AB032*D002-C010*AB007*CHE13460 $D002-C051*AB010*D009+C052*AB001*D009+C006*AB007*D020-C053*AB007*D0CHE13470 $13+C009*AB016*D008-C011*AB002*D008-C051*AB008*D011+C007*AB008*D004CHE13480 $+C006*AB002*D043-C075*AB002*D018+C004*AB010*D009-C005*AB001*D009-CCHE13490 $049*AB007*D020+C002*AB007*D013+C001*AB001*D044-C054*AB001*D029) CHE13500 EP28=OF8*(+C018*AB009*D001+C008*AB004*D008+C008*AB007*D005+C003*ABCHE13510 $001*D010+C021*AB021*D001-C025*AB009*D001-C060*AB015*D002+C013*AB00CHE13520 $9*D003-C061*AB009*D004+C009*AB012*D008-C011*AB004*D008-C051*AB005*CHE13530 $D009+C006*AB004*D017-C053*AB004*D018+C009*AB014*D005-C011*AB007*D0CHE13540 $05-C051*AB008*D006+C006*AB007*D014-C053*AB007*D015+C004*AB003*D010CHE13550 $-C005*AB001*D010-C049*AB002*D019+C001*AB001*D030-C050*AB001*D031) CHE13560 EP48=OF8*(+C021*AB027*D001-C015*AB024*D002-C025*AB008*D001+C018*ABCHE13570 $007*D002-C015*AB015*D005+C013*AB009*D006+C009*AB013*D008-C007*AB00CHE13580 $6*D009-C011*AB002*D008+C008*AB001*D009-C007*AB005*D010+C006*AB004*CHE13590 $D019+C009*AB015*D005-C007*AB009*D006-C007*AB008*D007+C006*AB007*D0CHE13600 $16+C076*AB008*D004-C053*AB007*D013+C004*AB005*D010-C002*AB004*D019CHE13610 $-C002*AB002*D035+C001*AB001*D038+C055*AB002*D018-C050*AB001*D029) CHE13620 EP58=OF8*(+C018*AB009*D001+C008*AB004*D008+C008*AB007*D005+C003*ABCHE13630 $001*D010+C021*AB030*D001-C024*AB009*D001-C060*AB024*D005+C073*AB00CHE13640 $7*D005+C013*AB009*D007-C061*AB009*D004+C009*AB023*D008-C010*AB004*CHE13650 $D008-C051*AB006*D010+C052*AB001*D010+C006*AB004*D035-C053*AB004*D0CHE13660 $18+C009*AB024*D005-C011*AB007*D005-C051*AB009*D007+C007*AB009*D004CHE13670 $+C006*AB007*D034-C075*AB007*D015+C004*AB006*D010-C005*AB001*D010-CCHE13680 $049*AB004*D035+C002*AB004*D018+C001*AB001*D041-C054*AB001*D031) CHE13690 EP78=OF8*(+C021*AB028*D001-C015*AB025*D002-C025*AB005*D001+C018*ABCHE13700 $004*D002-C015*AB015*D008+C013*AB009*D009+C009*AB015*D008-C007*AB00CHE13710 $9*D009-C007*AB005*D011+C006*AB004*D020+C076*AB005*D004-C053*AB004*CHE13720 $D013+C009*AB016*D005-C007*AB010*D006-C011*AB002*D005+C008*AB001*D0CHE13730 $06-C007*AB008*D010+C006*AB007*D019+C004*AB008*D010-C002*AB007*D019CHE13740 $-C002*AB002*D036+C001*AB001*D039+C055*AB002*D015-C050*AB001*D025) CHE13750 EP88=OF8*(+C021*AB031*D001-C025*AB006*D001-C015*AB024*D008-C025*ABCHE13760 $010*D001+C026*AB001*D001+C018*AB007*D008-C015*AB025*D005+C018*AB00CHE13770 $4*D005+C013*AB009*D010+C009*AB024*D008-C007*AB006*D011+C076*AB006*CHE13780 $D004-C011*AB007*D008+C008*AB001*D011-C008*AB001*D004-C051*AB009*D0CHE13790 $10+C006*AB004*D036-C053*AB004*D015+C009*AB025*D005-C011*AB004*D005CHE13800 $-C007*AB010*D007+C008*AB001*D007+C006*AB007*D035+C076*AB010*D004-CCHE13810 $053*AB007*D018+C004*AB009*D010-C002*AB004*D036+C055*AB004*D015-C00CHE13820 $2*AB007*D035+C001*AB001*D042-C050*AB001*D027+C055*AB007*D018-C050*CHE13830 $AB001*D033+C074*AB001*D023) CHE13840 EP98=OF8*(+C018*AB009*D001+C008*AB004*D008+C008*AB007*D005+C003*ABCHE13850 $001*D010+C021*AB034*D001-C024*AB009*D001-C060*AB025*D008+C073*AB00CHE13860 $4*D008+C013*AB009*D011-C061*AB009*D004+C009*AB025*D008-C011*AB004*CHE13870 $D008-C051*AB009*D011+C007*AB009*D004+C006*AB004*D043-C075*AB004*D0CHE13880 $18+C009*AB032*D005-C010*AB007*D005-C051*AB010*D010+C052*AB001*D010CHE13890 $+C006*AB007*D036-C053*AB007*D015+C004*AB010*D010-C005*AB001*D010-CCHE13900 $049*AB007*D036+C002*AB007*D015+C001*AB001*D045-C054*AB001*D031) CHE13910 EP29=OF8*(+C017*AB001*D001+C018*AB010*D001-C019*AB001*D001+C052*ABCHE13920 $007*D008+C003*AB001*D011-C058*AB001*D004+C011*AB003*D001-C020*AB00CHE13930 $1*D001-C052*AB002*D002+C012*AB001*D003-C059*AB001*D004+C021*AB022*CHE13940 $D001-C025*AB010*D001-C060*AB016*D002+C013*AB010*D003-C061*AB010*D0CHE13950 $04-C025*AB003*D001+C026*AB001*D001+C073*AB002*D002-C014*AB001*D003CHE13960 $+C062*AB001*D004+C063*AB014*D008-C071*AB007*D008-C064*AB008*D009+CCHE13970 $056*AB007*D017-C006*AB007*D018+C004*AB003*D011-C005*AB001*D011-C04CHE13980 $9*AB002*D020+C001*AB001*D032-C050*AB001*D033-C069*AB003*D004+C070*CHE13990 $AB001*D004+C002*AB002*D013-C050*AB001*D022+C074*AB001*D023) CHE14000 EP49=OF8*(+C011*AB005*D001-C008*AB004*D002-C008*AB002*D005+C012*ABCHE14010 $001*D006+C021*AB028*D001-C015*AB025*D002-C015*AB016*D005+C013*AB01CHE14020 $0*D006-C025*AB005*D001+C018*AB004*D002+C018*AB002*D005-C014*AB001*CHE14030 $D006+C063*AB015*D008-C051*AB009*D009-C051*AB008*D010+C056*AB007*D0CHE14040 $19+C004*AB005*D011-C002*AB004*D020-C002*AB002*D036+C001*AB001*D039CHE14050 $-C069*AB005*D004+C055*AB004*D013+C055*AB002*D015-C050*AB001*D025) CHE14060 EP59=OF8*(+C017*AB001*D001+C018*AB010*D001-C019*AB001*D001+C052*ABCHE14070 $007*D008+C003*AB001*D011-C058*AB001*D004+C011*AB006*D001-C020*AB00CHE14080 $1*D001-C052*AB004*D005+C012*AB001*D007-C059*AB001*D004+C021*AB031*CHE14090 $D001-C025*AB010*D001-C060*AB025*D005+C013*AB010*D007-C061*AB010*D0CHE14100 $04-C025*AB006*D001+C026*AB001*D001+C073*AB004*D005-C014*AB001*D007CHE14110 $+C062*AB001*D004+C063*AB024*D008-C071*AB007*D008-C064*AB009*D010+CCHE14120 $056*AB007*D035-C006*AB007*D018+C004*AB006*D011-C005*AB001*D011-C04CHE14130 $9*AB004*D036+C001*AB001*D042-C050*AB001*D033-C069*AB006*D004+C070*CHE14140 $AB001*D004+C002*AB004*D015-C050*AB001*D027+C074*AB001*D023) CHE14150 EP79=OF8*(+C011*AB008*D001-C008*AB007*D002-C008*AB002*D008+C012*ABCHE14160 $001*D009+C021*AB033*D001-C015*AB032*D002-C024*AB008*D001+C016*AB00CHE14170 $7*D002-C015*AB016*D008+C013*AB010*D009+C018*AB002*D008-C014*AB001*CHE14180 $D009+C063*AB016*D008-C051*AB010*D009-C071*AB002*D008+C052*AB001*D0CHE14190 $09-C051*AB008*D011+C056*AB007*D020+C007*AB008*D004-C006*AB007*D013CHE14200 $+C004*AB008*D011-C002*AB007*D020-C002*AB002*D043+C001*AB001*D044+CCHE14210 $072*AB002*D018-C054*AB001*D029-C069*AB008*D004+C055*AB007*D013) CHE14220 EP89=OF8*(+C011*AB009*D001-C008*AB004*D008-C008*AB007*D005+C012*ABCHE14230 $001*D010+C021*AB034*D001-C024*AB009*D001-C015*AB025*D008-C015*AB03CHE14240 $2*D005+C016*AB007*D005+C013*AB010*D010+C018*AB004*D008-C014*AB001*CHE14250 $D010+C063*AB025*D008-C071*AB004*D008-C051*AB009*D011+C007*AB009*D0CHE14260 $04-C051*AB010*D010+C052*AB001*D010+C056*AB007*D036-C006*AB007*D015CHE14270 $+C004*AB009*D011-C002*AB004*D043+C072*AB004*D018-C002*AB007*D036+CCHE14280 $001*AB001*D045-C054*AB001*D031-C069*AB009*D004+C055*AB007*D015) CHE14290 EP99=OF8*(+C017*AB001*D001+C018*AB010*D001-C019*AB001*D001+C057*ABCHE14300 $007*D008+C003*AB001*D011-C058*AB001*D004+C011*AB010*D001-C020*AB00CHE14310 $1*D001+C012*AB001*D011-C059*AB001*D004+C021*AB035*D001-C022*AB010*CHE14320 $D001-C060*AB032*D008+C023*AB001*D001+C038*AB007*D008+C013*AB010*D0CHE14330 $11-C061*AB010*D004-C014*AB001*D011+C062*AB001*D004+C063*AB032*D008CHE14340 $-C033*AB007*D008-C064*AB010*D011+C051*AB010*D004+C031*AB001*D011-CCHE14350 $052*AB001*D004+C056*AB007*D043-C065*AB007*D018+C004*AB010*D011-C00CHE14360 $5*AB001*D011-C049*AB007*D043+C066*AB007*D018+C001*AB001*D046-C067*CHE14370 $AB001*D033+C068*AB001*D023-C069*AB010*D004+C070*AB001*D004) CHE14380 C ******************************************************************CHE14390 C * PD *CHE14400 C ******************************************************************CHE14410 3242 CONTINUE CHE14420 EP12=OF7*(+C008*AB002*D001-C012*AB001*D002+C015*AB011*D001-C016*ABCHE14430 $002*D001-C013*AB003*D002+C014*AB001*D002+C051*AB003*D002-C052*AB00CHE14440 $1*D002-C056*AB002*D003+C006*AB002*D004+C002*AB002*D003-C001*AB001*CHE14450 $D012+C054*AB001*D013-C055*AB002*D004) CHE14460 EP32=OF7*(+C008*AB004*D001-C012*AB001*D005+C015*AB012*D001-C013*ABCHE14470 $003*D005-C018*AB004*D001+C014*AB001*D005+C051*AB005*D002-C056*AB00CHE14480 $2*D006+C002*AB004*D003-C001*AB001*D014-C055*AB004*D004+C050*AB001*CHE14490 $D015) CHE14500 EP62=OF7*(+C008*AB007*D001-C012*AB001*D008+C015*AB014*D001-C013*ABCHE14510 $003*D008-C018*AB007*D001+C014*AB001*D008+C051*AB008*D002-C056*AB00CHE14520 $2*D009+C002*AB007*D003-C001*AB001*D017-C055*AB007*D004+C050*AB001*CHE14530 $D018) CHE14540 EP14=OF7*(+C015*AB012*D001-C018*AB004*D001-C013*AB005*D002+C007*ABCHE14550 $005*D002-C006*AB004*D003+C053*AB004*D004+C007*AB003*D005-C008*AB00CHE14560 $1*D005-C006*AB002*D006+C002*AB002*D006-C001*AB001*D014+C050*AB001*CHE14570 $D015) CHE14580 EP34=OF7*(+C015*AB013*D001-C018*AB002*D001-C013*AB005*D005+C007*ABCHE14590 $006*D002-C008*AB001*D002-C006*AB004*D006+C007*AB005*D005-C006*AB00CHE14600 $2*D007+C053*AB002*D004+C002*AB004*D006-C001*AB001*D016+C050*AB001*CHE14610 $D013) CHE14620 EP64=OF7*(+C015*AB015*D001-C013*AB005*D008+C007*AB009*D002-C006*ABCHE14630 $004*D009+C007*AB008*D005-C006*AB002*D010+C002*AB007*D006-C001*AB00CHE14640 $1*D019) CHE14650 EP15=OF7*(+C008*AB002*D001-C012*AB001*D002+C015*AB013*D001-C013*ABCHE14660 $006*D002-C018*AB002*D001+C014*AB001*D002+C051*AB005*D005-C056*AB00CHE14670 $4*D006+C002*AB002*D007-C001*AB001*D016-C055*AB002*D004+C050*AB001*CHE14680 $D013) CHE14690 EP35=OF7*(+C008*AB004*D001-C012*AB001*D005+C015*AB023*D001-C016*ABCHE14700 $004*D001-C013*AB006*D005+C014*AB001*D005+C051*AB006*D005-C052*AB00CHE14710 $1*D005-C056*AB004*D007+C006*AB004*D004+C002*AB004*D007-C001*AB001*CHE14720 $D034+C054*AB001*D015-C055*AB004*D004) CHE14730 EP65=OF7*(+C008*AB007*D001-C012*AB001*D008+C015*AB024*D001-C013*ABCHE14740 $006*D008-C018*AB007*D001+C014*AB001*D008+C051*AB009*D005-C056*AB00CHE14750 $4*D010+C002*AB007*D007-C001*AB001*D035-C055*AB007*D004+C050*AB001*CHE14760 $D018) CHE14770 EP17=OF7*(+C015*AB014*D001-C018*AB007*D001-C013*AB008*D002+C007*ABCHE14780 $008*D002-C006*AB007*D003+C053*AB007*D004+C007*AB003*D008-C008*AB00CHE14790 $1*D008-C006*AB002*D009+C002*AB002*D009-C001*AB001*D017+C050*AB001*CHE14800 $D018) CHE14810 EP37=OF7*(+C015*AB015*D001-C013*AB008*D005+C007*AB009*D002-C006*ABCHE14820 $007*D006+C007*AB005*D008-C006*AB002*D010+C002*AB004*D009-C001*AB00CHE14830 $1*D019) CHE14840 EP67=OF7*(+C015*AB016*D001-C018*AB002*D001-C013*AB008*D008+C007*ABCHE14850 $010*D002-C008*AB001*D002-C006*AB007*D009+C007*AB008*D008-C006*AB00CHE14860 $2*D011+C053*AB002*D004+C002*AB007*D009-C001*AB001*D020+C050*AB001*CHE14870 $D013) CHE14880 EP18=OF7*(+C015*AB015*D001-C013*AB009*D002+C007*AB005*D008-C006*ABCHE14890 $004*D009+C007*AB008*D005-C006*AB007*D006+C002*AB002*D010-C001*AB00CHE14900 $1*D019) CHE14910 EP38=OF7*(+C015*AB024*D001-C018*AB007*D001-C013*AB009*D005+C007*ABCHE14920 $006*D008-C008*AB001*D008-C006*AB004*D010+C007*AB009*D005-C006*AB00CHE14930 $7*D007+C053*AB007*D004+C002*AB004*D010-C001*AB001*D035+C050*AB001*CHE14940 $D018) CHE14950 EP68=OF7*(+C015*AB025*D001-C018*AB004*D001-C013*AB009*D008+C007*ABCHE14960 $009*D008-C006*AB004*D011+C053*AB004*D004+C007*AB010*D005-C008*AB00CHE14970 $1*D005-C006*AB007*D010+C002*AB007*D010-C001*AB001*D036+C050*AB001*CHE14980 $D015) CHE14990 EP19=OF7*(+C008*AB002*D001-C012*AB001*D002+C015*AB016*D001-C013*ABCHE15000 $010*D002-C018*AB002*D001+C014*AB001*D002+C051*AB008*D008-C056*AB00CHE15010 $7*D009+C002*AB002*D011-C001*AB001*D020-C055*AB002*D004+C050*AB001*CHE15020 $D013) CHE15030 EP39=OF7*(+C008*AB004*D001-C012*AB001*D005+C015*AB025*D001-C013*ABCHE15040 $010*D005-C018*AB004*D001+C014*AB001*D005+C051*AB009*D008-C056*AB00CHE15050 $7*D010+C002*AB004*D011-C001*AB001*D036-C055*AB004*D004+C050*AB001*CHE15060 $D015) CHE15070 EP69=OF7*(+C008*AB007*D001-C012*AB001*D008+C015*AB032*D001-C016*ABCHE15080 $007*D001-C013*AB010*D008+C014*AB001*D008+C051*AB010*D008-C052*AB00CHE15090 $1*D008-C056*AB007*D011+C006*AB007*D004+C002*AB007*D011-C001*AB001*CHE15100 $D043+C054*AB001*D018-C055*AB007*D004) CHE15110 C ******************************************************************CHE15120 C * SD *CHE15130 C ******************************************************************CHE15140 3260 CONTINUE CHE15150 EP02=OF6*(+C012*AB001*D001+C013*AB003*D001-C014*AB001*D001+C056*ABCHE15160 $002*D002+C001*AB001*D003-C050*AB001*D004) CHE15170 EP04=OF6*(+C013*AB005*D001+C006*AB004*D002+C006*AB002*D005+C001*ABCHE15180 $001*D006) CHE15190 EP05=OF6*(+C012*AB001*D001+C013*AB006*D001-C014*AB001*D001+C056*ABCHE15200 $004*D005+C001*AB001*D007-C050*AB001*D004) CHE15210 EP07=OF6*(+C013*AB008*D001+C006*AB007*D002+C006*AB002*D008+C001*ABCHE15220 $001*D009) CHE15230 EP08=OF6*(+C013*AB009*D001+C006*AB004*D008+C006*AB007*D005+C001*ABCHE15240 $001*D010) CHE15250 EP09=OF6*(+C012*AB001*D001+C013*AB010*D001-C014*AB001*D001+C056*ABCHE15260 $007*D008+C001*AB001*D011-C050*AB001*D004) CHE15270 IF(ITYPE-6)3261,3262,3261 CHE15280 C ******************************************************************CHE15290 C * PP *CHE15300 C ******************************************************************CHE15310 3261 CONTINUE CHE15320 EP10=OF1*(+C002*AB002*D001-C001*AB001*D002) CHE15330 EP30=OF1*(+C002*AB004*D001-C001*AB001*D005) CHE15340 EP60=OF1*(+C002*AB007*D001-C001*AB001*D008) CHE15350 EP11=OF4*(-C007*AB003*D001+C008*AB001*D001+C006*AB002*D002-C002*ABCHE15360 $002*D002+C001*AB001*D003-C050*AB001*D004) CHE15370 EP31=OF4*(-C007*AB005*D001+C006*AB002*D005-C002*AB004*D002+C001*ABCHE15380 $001*D006) CHE15390 EP61=OF4*(-C007*AB008*D001+C006*AB002*D008-C002*AB007*D002+C001*ABCHE15400 $001*D009) CHE15410 EP13=OF4*(-C007*AB005*D001+C006*AB004*D002-C002*AB002*D005+C001*ABCHE15420 $001*D006) CHE15430 EP33=OF4*(-C007*AB006*D001+C008*AB001*D001+C006*AB004*D005-C002*ABCHE15440 $004*D005+C001*AB001*D007-C050*AB001*D004) CHE15450 EP63=OF4*(-C007*AB009*D001+C006*AB004*D008-C002*AB007*D005+C001*ABCHE15460 $001*D010) CHE15470 EP16=OF4*(-C007*AB008*D001+C006*AB007*D002-C002*AB002*D008+C001*ABCHE15480 $001*D009) CHE15490 EP36=OF4*(-C007*AB009*D001+C006*AB007*D005-C002*AB004*D008+C001*ABCHE15500 $001*D010) CHE15510 EP66=OF4*(-C007*AB010*D001+C008*AB001*D001+C006*AB007*D008-C002*ABCHE15520 $007*D008+C001*AB001*D011-C050*AB001*D004) CHE15530 3262 CONTINUE CHE15540 DO 2137 I=1,100 CHE15550 2137 EPN(I)=EPN(I)+EEP(I) CHE15560 105 CONTINUE CHE15570 C ******************************************************************CHE15580 C END OF LOOP OVER GAUSSIANS CHE15590 C STORE IN ARRAYS CHE15600 C ******************************************************************CHE15610 INTC=0 CHE15620 DO 500 J=1,10 CHE15630 R3B=RENORM(J) CHE15640 DO 500 I=1,10 CHE15650 R3A=R3B*RENORM(I) CHE15660 INTC=INTC+1 CHE15670 500 EPN(INTC) = ( EPN(INTC) )*R3A*SYMFAC CHE15680 CALL REDUC1(EPN,LAMAX,LBMAX,I6TO5) CHE15690 CALL MATFIL(H,EPN,AOS,SHELLT,INEW,JNEW,LAMAX,LBMAX,LA,LB) CHE15700 1000 CONTINUE CHE15710 C CHE15720 C REFORMAT COMMON /B/ AND THE H ARRAY IF THIS BASIS CONTAINS CHE15730 C P ONLY SHELLS CHE15740 C CHE15750 IF (IPO(4) .EQ. 0) GOTO 1285 CHE15760 WRITE(IOUT,*) 'DEBUG OF UNSTAR' CHE15770 CALL LINOUT (H,NBASIS,0,0) CHE15780 1285 CONTINUE CHE15790 C CHE15800 CALL UNSTAR (NBASIS,SHELLT,SHELLC,AOS,NSHELL,H,NOSTAR) CHE15810 C CHE15820 IF(IPO(4).EQ.0) GOTO 1500 CHE15830 WRITE(IOUT,2010) CHE15840 CALL LINOUT(H,NBASIS,0,0) CHE15850 1500 CONTINUE CHE15860 RETURN CHE15870 END CHE15880 SUBROUTINE INV(A,N,IS,IAD1,IAD2,D,MDM) CHE15890 IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHE15900 C ******************************************************************CHE15910 C INVERSION OF SQUARE MATRIX A BY MEANS OF THE GAUSS-JORDAN CHE15920 C ALGORITHM CHE15930 C CHE15940 C APRIL 72/RS9B CHE15950 C ******************************************************************CHE15960 DIMENSION A(MDM,MDM),IS(2,MDM),IAD1(MDM),IAD2(MDM),D(MDM) CHE15970 C CHE15980 COMMON/IO/IN,IOUT,IPUNCH CHE15990 C CHE16000 DATA ZERO/0.0D0/, ONE/1.0D0/, SMALL/1.0D-20/ CHE16010 C CHE16020 2000 FORMAT(' WARNING FROM INV: MATRIX IS SINGULAR') CHE16030 C ******************************************************************CHE16040 DO 1 L=1,N CHE16050 IS(1,L)=0 CHE16060 1 IS(2,L)=0 CHE16070 DO 9 IMA=1,N CHE16080 B= ZERO CHE16090 DO 2 L=1,N CHE16100 DO 2 M=1,N CHE16110 IF(IS(1,L).EQ.1.OR.IS(2,M).EQ.1) GOTO 2 CHE16120 E=DABS(A(L,M)) CHE16130 IF(E.LT.B) GOTO 8 CHE16140 I=L CHE16150 K=M CHE16160 8 B=DMAX1(B,E) CHE16170 2 CONTINUE CHE16180 IS(1,I)=1 CHE16190 IS(2,K)=1 CHE16200 IAD1(K)=I CHE16210 IAD2(I)=K CHE16220 B=A(I,K) CHE16230 C.....PIVOT CHE16240 IF(DABS(B).LT. SMALL) GOTO 20 CHE16250 A(I,K)=ONE/B CHE16260 DO 6 L=1,N CHE16270 IF(L.EQ.K) GOTO 6 CHE16280 C.....KELLERZEILE CHE16290 A(I,L)=-A(I,L)/B CHE16300 6 CONTINUE CHE16310 DO 5 L=1,N CHE16320 DO 5 M=1,N CHE16330 IF(L.EQ.I.OR.M.EQ.K) GOTO 5 CHE16340 C.....RECHTECK-REGEL CHE16350 A(L,M)=A(L,M)+A(L,K)*A(I,M) CHE16360 5 CONTINUE CHE16370 DO 11 L=1,N CHE16380 IF(L.EQ.I) GOTO 11 CHE16390 C.....PIVOT-SPALTE CHE16400 A(L,K)=A(L,K)/B CHE16410 11 CONTINUE CHE16420 9 CONTINUE CHE16430 C.....PERMUTATION DER ZEILEN, UM DIE NATUERLICHE ORDNUNG WIEDER HERZUSTECHE16440 DO 15 L=1,N CHE16450 DO 13 J=1,N CHE16460 K=IAD1(J) CHE16470 13 D(J)=A(K,L) CHE16480 DO 14 J=1,N CHE16490 14 A(J,L)=D(J) CHE16500 15 CONTINUE CHE16510 C.....PERMUTATION DER SPALTEN CHE16520 DO 16 L=1,N CHE16530 DO 17 J=1,N CHE16540 K=IAD2(J) CHE16550 17 D(J)=A(L,K) CHE16560 DO 18 J=1,N CHE16570 18 A(L,J)=D(J) CHE16580 16 CONTINUE CHE16590 RETURN CHE16600 C CHE16610 C ERROR EXIT: MATRIX IS SINGULAR CHE16620 20 WRITE(IOUT,2000) CHE16630 STOP 'INV IN POLAR' CHE16640 END CHE16650 SUBROUTINE LINOUT(X,N,KEY,IZERO) CHE16660 C CHE16670 C GENERAL LINEAR MATRIX OUTPUT ROUTINE CHE16680 C CHE16690 C KEY=0 MATRIX SYMMETRIC CHE16700 C KEY=1 MATRIX SQUARE ASYMMETRIC CHE16710 C CHE16720 C IZERO=0 ZERO MATRIX ELEMENTS LESS THAN CUTOFF CHE16730 C IZERO=1 DO NOT ZERO MATRIX ELEMENTS CHE16740 C CHE16750 C CUTOFF=1.0E-06 CHE16760 C CHE16770 IMPLICIT REAL*8 (A-H,O-Z) CHE16780 COMMON/IO/IN,IOUT CHE16790 C CHE16800 DIMENSION S(9),X(1) CHE16810 C CHE16820 DATA CUTOFF/1.0E-06/ CHE16830 DATA ZERO/0.0E0/ CHE16840 C CHE16850 IA(I)=(I*(I-1))/2 CHE16860 C CHE16870 C CHE16880 ILOWER=1 CHE16890 100 IUPPER=MIN0(ILOWER+8,N) CHE16900 IRANGE=MIN0(IUPPER-ILOWER+1,9) CHE16910 WRITE (IOUT,9000) (J,J=ILOWER,IUPPER) CHE16920 WRITE (IOUT,9010) CHE16930 DO 160 I=1,N CHE16940 K=1 CHE16950 DO 150 J=ILOWER,IUPPER CHE16960 IF(KEY)110,120,110 CHE16970 110 IJ=N*(J-1)+I CHE16980 GO TO 140 CHE16990 120 IJ=IA(I)+J CHE17000 IF(I-J)130,140,140 CHE17010 130 IJ=IA(J)+I CHE17020 140 S(K)=X(IJ) CHE17030 IF(IZERO.EQ.0.AND.ABS(S(K)).LE.CUTOFF) S(K)=ZERO CHE17040 150 K=K+1 CHE17050 160 WRITE (IOUT,9020) I,(S(J),J=1,IRANGE) CHE17060 WRITE (IOUT,9010) CHE17070 ILOWER=ILOWER+9 CHE17080 IF(N-IUPPER)170,170,100 CHE17090 170 RETURN CHE17100 9000 FORMAT(12X,8(I3,11X),I3) CHE17110 9010 FORMAT(/) CHE17120 9020 FORMAT(1X,I3,2X,9E14.6) CHE17130 END CHE17140 SUBROUTINE MATFIL(A,AA,AOS,SHELLT,INEW,JNEW,LAMAX,LBMAX,LA,LB) CHE17150 C CHE17160 C GAUSSIAN 77/UCI CHE17170 C CHE17180 IMPLICIT REAL*8 (A-H,O-Z) CHE17190 INTEGER AOS(1), SHELLT(1) CHE17200 C CHE17210 DIMENSION A(1),AA(1) CHE17220 C CHE17230 LIND(I)=(I*(I-1))/2 CHE17240 C CHE17250 ISTART=AOS(INEW) CHE17260 JSTART=AOS(JNEW) CHE17270 IAL = 0 CHE17280 IAU = 5 CHE17290 IBL = 0 CHE17300 IBU = 5 CHE17310 IMA = 0 CHE17320 IMB = 0 CHE17330 IF(SHELLT(INEW) .EQ. 2) IMA = 1 CHE17340 IF(SHELLT(JNEW) .EQ. 2) IMB = 1 CHE17350 C CHE17360 120 INTC=0 CHE17370 DO 170 J=1,LBMAX CHE17380 DO 170 I=1,LAMAX CHE17390 INTC=INTC+1 CHE17400 IF( LA.GT.1 .AND. I.GT.IAL .AND. I.LT.IAU )GO TO 170 CHE17410 IF( LA.EQ.1 .AND. I.EQ.IMA )GO TO 170 CHE17420 IF( LB.GT.1 .AND. J.GT.IBL .AND. J.LT.IBU )GO TO 170 CHE17430 IF( LB.EQ.1 .AND. J.EQ.IMB )GO TO 170 CHE17440 IND=ISTART+I-1 CHE17450 JND=JSTART+J-1 CHE17460 IF(IND-JND)130,140,150 CHE17470 130 IJ=LIND(JND)+IND CHE17480 GO TO 160 CHE17490 140 IJ=LIND(IND+1) CHE17500 GO TO 160 CHE17510 150 IJ=LIND(IND)+JND CHE17520 160 A(IJ)=AA(INTC) CHE17530 170 CONTINUE CHE17540 RETURN CHE17550 END CHE17560 SUBROUTINE MULTAY(A,Y,X,N,MAXDIM) CHE17570 C CHE17580 C MATRIX MULTIPLICATION ROUTINE CHE17590 C CHE17600 IMPLICIT REAL*8 (A-H,O-Z) CHE17610 C CHE17620 DIMENSION A(MAXDIM,MAXDIM),Y(MAXDIM),X(MAXDIM) CHE17630 C CHE17640 DATA ZERO/0.0/ CHE17650 C CHE17660 DO 200 IROW=1,N CHE17670 SUM = ZERO CHE17680 DO 100 JCOL=1,N CHE17690 SUM = SUM + A(IROW,JCOL) * Y(JCOL) CHE17700 100 CONTINUE CHE17710 X(IROW) = SUM CHE17720 200 CONTINUE CHE17730 RETURN CHE17740 END CHE17750 C CHE17760 SUBROUTINE OUTPUT CHE17770 C CHE17780 C CHE17790 C L.E. CHIRLIAN CHE17800 C APRIL 1985 CHE17810 C CHE17820 C A SUBROUTINE TO OUTPUT THE CHARGES AND OTHER PERTINANT CHE17830 C INFORMATION FROM THE CHELP PROGRAM CHE17840 C CHE17850 C Slightly Modified for CHELPG operations by Curt Breneman CHE17860 C Yale University Department of Chemistry, 2/88 CHE17870 C CHE17880 IMPLICIT REAL*8 (A-H,O-Z) CHE17890 PARAMETER (NPOINTS = 50000) CHE17900 INTEGER*4 SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON,SHLADF CHE17910 CHARACTER*40 CHKFIL CHE17920 C CHE17930 COMMON /IO/ IN,IOUT CHE17940 COMMON /IPO/ IPO(5) CHE17950 C+++ CHE17960 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS, CHE17970 $ IAN(401),ATMCHG(400),C(3,400) CHE17980 C+++ CHE17990 C COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(101), CHE18000 C 1 ATMCHG(100),C(3,100) CHE18010 COMMON /OUT/ Q(400),RMS,PD,NTITLE(20,3),ND,NLIN,NEND(3), CHE18020 1 CHKFIL CHE18030 COMMON /POINTS/ P(3,NPOINTS), NP CHE18040 DATA DEB/0.393427328/ CHE18050 c CHE18060 c CHE18070 c write(6,*) 'Debug --', nlin,nend(1),nend(2),nend(3),nwords CHE18080 C CHE18090 C CALCULATE THE DIPOLE MOMENT FROM THE FITTED CHARGES CHE18100 C CHE18110 C CHE18120 DIPX=0. CHE18130 DIPY=0. CHE18140 DIPZ=0. CHE18150 DO 99 I=1,NATOMS CHE18160 DIPX=DIPX+(Q(I)*C(1,I)) CHE18170 DIPY=DIPY+(Q(I)*C(2,I)) CHE18180 DIPZ=DIPZ+(Q(I)*C(3,I)) CHE18190 99 CONTINUE CHE18200 DIPX=DIPX/DEB CHE18210 DIPY=DIPY/DEB CHE18220 DIPZ=DIPZ/DEB CHE18230 C CHE18240 C CALCULATE TOTAL DIPOLE MOMENT CHE18250 C CHE18260 DIPTOT = DSQRT(DIPX**2+DIPY**2+DIPZ**2) CHE18270 C CHE18280 C CREATE OUTPUT CHE18290 C CHE18300 WRITE (IOUT,100) CHE18310 100 FORMAT (/,/,17X,'CHARGES FROM ELECTROSTATIC POTENTIAL GRID') CHE18320 WRITE (IOUT,110) CHE18330 WRITE (IOUT,111) CHE18340 110 FORMAT (/,36X,'CHELPGrid',/) CHE18350 111 FORMAT (/,15X,'Grid Modification.') CHE18360 DO 24 I=1,NLIN CHE18370 WRITE (6,1200)(NTITLE(J,I),J=1,NEND(I)) CHE18380 1200 FORMAT(2X,19A4) CHE18390 24 CONTINUE CHE18400 C CHE18410 C WRITE CHECKPOINT FILE NAME CHE18420 C CHE18430 WRITE (IOUT,150)CHKFIL CHE18440 150 FORMAT(/2X,'CHECKPOINT FILE: ',A40) CHE18450 C CHE18460 C PRINT DATE CHE18470 C CHE18480 C*** Take out for Trace-7 CHE18490 C CALL FOR$JDATE(IMONTH,IDATE,IYEAR) CHE18500 C*** CHE18510 WRITE (IOUT,170)IMONTH,IDATE,IYEAR CHE18520 170 FORMAT (/2X,I2,'-',I2,'-',I2) CHE18530 C CHE18540 C***********************************************************************CHE18550 C WRITE GEOMETRY CHE18560 C***********************************************************************CHE18570 C CHE18580 WRITE (IOUT,180) CHE18590 180 FORMAT (/2X,36X,'MOLECULAR GEOMETRY') CHE18600 WRITE (IOUT,190) CHE18610 190 FORMAT (/,/,17X,'ATOMIC NUMBER',8X,'X',12X,'Y',12X,'Z') CHE18620 DO 30 I=1,NATOMS CHE18630 WRITE (IOUT,200)IAN(I),C(1,I),C(2,I),C(3,I) CHE18640 200 FORMAT (/,23X,I2,8X,F10.7,3X,F10.7,3X,F10.7) CHE18650 30 CONTINUE CHE18660 WRITE (IOUT,210)ICHARG CHE18670 210 FORMAT (/2X,'THE TOTAL CHARGE IS CONSTRAINED TO: ',I3) CHE18680 WRITE (IOUT,240) CHE18690 240 FORMAT (/,36X,'NET CHARGES') CHE18700 WRITE (IOUT,250) CHE18710 250 FORMAT (/,28X,'ATOMIC NUMBER',5X,'CHARGE') CHE18720 WRITE (IOUT,260)(IAN(I),Q(I),I=1,NATOMS) CHE18730 WRITE (6,101) DIPTOT CHE18740 101 FORMAT (/,2X,'THE DIPOLE MOMENT OF THESE CHARGES IS: ',F8.5) CHE18750 260 FORMAT (/,34X,I2,10X,F8.4) CHE18760 WRITE (IOUT,270)NP CHE18770 270 FORMAT(/,2X,'FIT TO ELECTROSTATIC POTENTIAL AT ',I6,' POINTS') CHE18780 WRITE (IOUT,280)RMS CHE18790 280 FORMAT (/,2X,'ROOT MEAN SQUARE DEVIATION IS ',F6.4,' KCAL/MOLE') CHE18800 RETURN CHE18810 END CHE18820 CHE18830 SUBROUTINE READIN CHE18840 C CHE18850 C WRITTEN BY M.M. FRANCL FOR THE CHE18860 C PRINCETON CHEMISTRY DEPARTMENT VAX 11/780 UNDER VMS 3.4. CHE18870 C MODIFIED BY L.E. CHIRLIAN UNDER VMS 3.7. CHE18880 C CHE18890 C MODIFIED FOR GAUSSIAN 86 BY CURT BRENEMAN (VMS 4.5) CHE18900 C Modified for G88/90 by Curt Breneman, 2/89 CHE18910 C YALE UNIVERSITY DEPARTMENT OF CHEMISTRY. CHE18920 C CHE18930 C THIS VERSION IS COMPATIBLE WITH GAUSSIAN 82 FROM CARNEGIE- CHE18940 C MELLON UNIVERSITY AND IS DESIGNED FOR THE INPUT OF MO AND CHE18950 C BASIS INFORMATION FROM CHECKPOINT FILES. THIS VERSION IS CHE18960 C TO BE USED FOR THE DETERMINATION OF ATOMIC CHARGES FROM CHE18970 C ELECTROSTATIC POTENTIALS DETERMINED BY FIRST ORDER HARTREE CHE18980 C FOCK PERURBATION THEORY. CHE18990 C CHE19000 C OLD LIMITATIONS: NO MORE THAN 256 BASIS FUNCTIONS CHE19010 C NO MORE THAN 80 SHELLS CHE19020 C CHE19030 C NEW LIMITATIONS: NO MORE THAN 1280 BASIS FUNCTIONS CHE19040 C NO MORE THAN 400 SHELLS CHE19050 C CHE19060 IMPLICIT REAL*8 (A-H,O-Z) CHE19070 INTEGER*4 SHELLA,SHELLN,SHELLT,SHELLC,AOS,AON,SHLADF,FILNUM CHE19080 CHARACTER*40 CHKFIL CHE19090 PARAMETER (NUMPTS = 20) CHE19100 DIMENSION LINE(20) CHE19110 C CHE19120 COMMON /IO/ IN,IOUT CHE19130 c+++ CHE19140 c Change for G86 : New Commons /MOL/ and /B/ CHE19150 c CHE19160 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS, CHE19170 $ IAN(401),ATMCHG(400),C(3,400) CHE19180 C CHE19190 C=== Gaussian88 Modification. New Common /b/ size. CHE19200 Common/B/EXX(6000),C1(6000),C2(6000),C3(2000),CF(2000), CHE19210 $SHLADF(4000),X(2000),Y(2000), CHE19220 $Z(2000),JAN(2000),ShellA(2000),ShellN(2000),ShellT(2000), CHE19230 $ShellC(2000),AOS(2000),AON(2000),NShell,MaxTyp CHE19240 C=== Old G86 Common /b/ CHE19250 c COMMON/B/EXX(1200),C1(1200),C2(1200),C3(400),CF(400),SHLADF(800),CHE19260 c $ X(400),Y(400),Z(400),JAN(400),SHELLA(400),SHELLN(400), CHE19270 c $ SHELLT(400),SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP CHE19280 c CHE19290 c+++ CHE19300 C%%% CHE19310 c Original CHELP common /B/ CHE19320 c CHE19330 c COMMON /B/ EXX(240),C1(240),C2(240),C3(80),CF(80),SHLADF(160), CHE19340 c $ X(80),Y(80),Z(80), CHE19350 c $ JAN(80),SHELLA(80),SHELLN(80),SHELLT(80),SHELLC(80), CHE19360 c $ AOS(80),AON(80),NSHELL,MAXTYP CHE19370 C COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(101), CHE19380 C $ ATMCHG(100),C(3,100) CHE19390 C%%% CHE19400 COMMON /IPO/ IPO(5) CHE19410 COMMON /OUT/ Q(400),RMS,PD,NTITLE(20,3),ND,NLIN,NEND(3), CHE19420 1 CHKFIL CHE19430 COMMON /CHARGE/ COEF_ALPHA(100000),COEF_BETA(100000),IUHF CHE19440 COMMON /SPHERE/ VDWR(400), NPTS CHE19450 C VECT(3,NUMPTS) CHE19460 C CHE19470 DATA MAXBAS /1280/ CHE19480 DATA MAXPTS/ 50000/ CHE19490 DATA NPO/ 5/ CHE19500 DATA IUNIT/ 3/, IREAD/ 2/, IFIND/11/, IBLNK/4H / CHE19510 C DATA VECT/0.00000000, 0.00000000, 1.00000000, CHE19520 C $ 0.23807485, -0.08801514, -0.96725059, CHE19530 C $ -0.46055608, 0.17026540, 0.87114740, CHE19540 C $ 0.65287142, -0.24136347, -0.71798508, CHE19550 C $ -0.80242446, 0.29665251, 0.51779559, CHE19560 C $ 0.00000000, 0.00000000, 1.00000000, CHE19570 C $ -0.20401674, -0.15100817, -0.96725059, CHE19580 C $ 0.39467063, 0.29212549, 0.87114740, CHE19590 C $ -0.55947405, -0.41410893, -0.71798508, CHE19600 C $ 0.68763258, 0.50896872, 0.51779559, CHE19610 C $ -0.94978689, -0.28553486, -0.12796369, CHE19620 C $ 0.88757697, 0.26683266, 0.37550960, CHE19630 C $ -0.76723180, -0.23065324, -0.59846007, CHE19640 C $ 0.59663385, 0.17936630, 0.78221211, CHE19650 C $ -0.38695708, -0.11633108, -0.91473018, CHE19660 C $ 0.28119199, 0.95108168, -0.12796369, CHE19670 C $ -0.26277424, -0.88878695, 0.37550960, CHE19680 C $ 0.22714509, 0.76827772, -0.59846007, CHE19690 C $ -0.17663821, -0.59744720, 0.78221211, CHE19700 C $ 0.11456173, 0.38748460, -0.91473018/ CHE19710 C CHE19720 C Old "spherical" unit vectors (14 of them) CHE19730 C CHE19740 c 0.5773502691896258,0.5773502691896258, CHE19750 c $ 0.5773502691896258, CHE19760 c 1 -0.5773502691896258,-0.5773502691896258,0.5773502691896258, CHE19770 c 2 0.5773502691896258,-0.5773502691896258,-0.5773502691896258, CHE19780 c 3 -0.5773502691896258,0.5773502691896258,-0.5773502691896258, CHE19790 c 4 0.0000000000000000E+00,-1.000000000000000, CHE19800 c $ 0.0000000000000000E+00, CHE19810 c 5 0.0000000000000000E+00,0.0000000000000000E+00, CHE19820 c $ -1.000000000000000, CHE19830 c 6 -1.000000000000000,0.0000000000000000E+00, CHE19840 c $ 0.0000000000000000E+00, CHE19850 c 7 -0.5773502691896258,-0.5773502691896258,-0.5773502691896258, CHE19860 c 8 1.000000000000000,0.0000000000000000E+00, CHE19870 c $ 0.0000000000000000E+00, CHE19880 c 9 0.0000000000000000E+00,1.000000000000000, CHE19890 c $ 0.0000000000000000E+00, CHE19900 c $ 0.5773502691896258,0.5773502691896258,-0.5773502691896258, CHE19910 c $ 0.0000000000000000E+00,0.0000000000000000E+00, CHE19920 c $ 1.000000000000000, CHE19930 c $ -0.5773502691896258,0.5773502691896258,0.5773502691896258, CHE19940 c $ 0.5773502691896258,-0.5773502691896258,0.5773502691896258, CHE19950 CHE19960 IN = 5 CHE19970 IOUT = 6 CHE19980 C CHE19990 C CHECKPOINT FILE NAME CHE20000 C CHE20010 READ(IN,1000) CHKFIL CHE20020 1000 FORMAT(A40) CHE20030 C CHE20040 C INPUT INFORMATION CHE20050 C CHE20060 1010 FORMAT(20A4) CHE20070 DO 1921 I=1,3 CHE20080 NLIN= I CHE20090 READ (5,1010) LINE CHE20100 IF (LINE(1) .EQ. IBLNK) THEN CHE20110 NLIN=NLIN-1 CHE20120 GOTO 192 CHE20130 END IF CHE20140 DO 1922 J=1,20 CHE20150 L=20-J CHE20160 IF (LINE(L) .NE. IBLNK) THEN CHE20170 NEND(I) = L CHE20180 DO 1923 K=1,NEND(I) CHE20190 NTITLE(K,I) = LINE(K) CHE20200 1923 CONTINUE CHE20210 GOTO 1921 CHE20220 END IF CHE20230 1922 CONTINUE CHE20240 1921 CONTINUE CHE20250 NLIN=NLIN+1 CHE20260 192 CONTINUE CHE20270 C CHE20280 C CHE20290 C READ IN PRINT OPTIONS CHE20300 C CHE20310 3000 READ(IN,*) (IPO(I),I=1,NPO) CHE20320 C CHE20330 C READ IN # OF D FUNCTIONS CHE20340 C NOTE: IF THE BASIS SET USES 5 D FUNCTION, ND MUST BE CHE20350 C SET EQUAL TO 1 TO ACCOMODATE THE INTEGRAL PACKAGE. CHE20360 C IF THE BASIS SET USES 6 D FUNCTIONS, ND IS SET EQUAL TO CHE20370 C 0. CHE20380 C CHE20390 READ(IN,*) ND CHE20400 IF (ND .NE. 5 .AND. ND .NE. 6) THEN CHE20410 STOP '# OF D FUNCTIONS MUST BE 5 OR 6' CHE20420 END IF CHE20430 IF (ND .EQ. 5) THEN CHE20440 ND = 1 CHE20450 GOTO 15 CHE20460 END IF CHE20470 ND = 0 CHE20480 15 CONTINUE CHE20490 C CHE20500 C CHE20510 C INITIATE FILEIO CHE20520 C CHE20530 C*** Different Fopen statement for Trace-7 CHE20540 CALL FOPEN (IUNIT,5,CHKFIL,IALLOC,junk) CHE20550 c CALL FOPEN (IUNIT,'old',CHKFIL(1:linend(chkfil))//char(0)) CHE20560 C CHE20570 IWWRIT = IPO(1) CHE20580 C***********************************************************************CHE20590 C CHE20600 C READ IN COMMON /MOL/ CHE20610 C CHE20620 c NWORDS = 1804 CHE20630 c IFILENO = 30997 CHE20640 c CALL FILEIO (IREAD,IFILENO,NWORDS,NATOMS,IALLOC) CHE20650 IRwMol=997 CHE20660 MaxAtm=400 CHE20670 LenMol = 4*MaxAtm + InToWP(8+MaxAtm) CHE20680 Call FileIO(2,-FilNum(IRwMol,IUnit),LenMol,NAtoms,0) CHE20690 C CHE20700 C***********************************************************************CHE20710 C CHE20720 C READ IN SPHERE DATA (VAN DER WAALS RADII, # OF POINTS TO CHE20730 C FIT CHE20740 C CHE20750 C CHE20760 READ (IN,*)(VDWR(I),I=1,NATOMS) CHE20770 READ (IN,*)NPTS CHE20780 IF (NPTS .GT. MAXPTS) THEN CHE20790 STOP 'MAXIMUM NUMBER OF POINTS MUST BE LESS THAN 50000' CHE20800 END IF CHE20810 C CHE20820 C SET MAXIMUM VAN DER WAALS RADII TO 4 CHE20830 C CHE20840 VMAX=4. CHE20850 DO 20 I=1,NATOMS CHE20860 IF (VDWR(I) .GT. VMAX) THEN CHE20870 WRITE (IOUT, 2500) I CHE20880 2500 FORMAT (3X, 'THE VAN DER WAALS RADII OF ATOM', I3,CHE20890 1 'IS OUT OF RANGE') CHE20900 STOP CHE20910 END IF CHE20920 20 CONTINUE CHE20930 C CHE20940 READ (IN,*) VFACT CHE20950 DO 21 I=1,NATOMS CHE20960 VDWR(I)=VDWR(I)*VFACT CHE20970 21 CONTINUE CHE20980 C***********************************************************************CHE20990 C CHE21000 C READ IN BASIS SET INFORMATION (COMMON /B/) CHE21010 C CHE21020 IFILENO = 30506 CHE21030 CALL FILEIO (IFIND,IFILENO,NWORDS,EXX,0) CHE21040 CALL FILEIO (IREAD,-IFILENO,NWORDS,EXX,0) CHE21050 C***********************************************************************CHE21060 IF(IWWRIT .NE. 1) GOTO 170 CHE21070 WRITE(IOUT,8000)(C(1,I),C(2,I),C(3,I),I=1,NATOMS) CHE21080 8000 FORMAT(/1X,'COORDINATES'/(1X,3F12.6)) CHE21090 WRITE(IOUT,8020) NATOMS,ICHARG,MULTIP,NAE,NBE,NE,NBASIS CHE21100 $ ,NSHELL,MAXTYP CHE21110 8020 FORMAT(/1X,'NATOMS = ',I3 CHE21120 $/1X,'ICHARG = ',I3 CHE21130 $/1X,'MULTIP = ',I3 CHE21140 $/1X,'NAE = ',I3 CHE21150 $/1X,'NBE = ',I3 CHE21160 $/1X,'NE = ',I3 CHE21170 $/1X,'NBASIS = ',I3 CHE21180 $/1X,'NSHELL = ',I3 CHE21190 $/1X,'MAXTYP = ',I3) CHE21200 WRITE(IOUT,8030) (IAN(I),I=1,NATOMS) CHE21210 8030 FORMAT(/1X,'IAN'/(1X,20I3)) CHE21220 WRITE(IOUT,8050) (JAN(I),SHELLT(I),SHELLA(I),I=1,NSHELL) CHE21230 8050 FORMAT(/1X,'CENTER TYPE SHELLA'/(1X,3I7)) CHE21240 WRITE(IOUT,8055) SHELLA(NSHELL+1) CHE21250 8055 FORMAT(1X,14X,I7) CHE21260 WRITE(IOUT,8060) (EXX(I),C1(I),C2(I),I=1,NSHELL) CHE21270 8060 FORMAT(/1X,12X,'EXPON',8X,'EXPCOF(S)',8X,'EXPCOF(P)', CHE21280 $/(1X,3E17.9)) CHE21290 WRITE(IOUT,8070) (C3(I),CF(I),I=1,NSHELL) CHE21300 8070 FORMAT(/1X,12X,'EXPCOF(D)',8X,'EXPCOF(F)', CHE21310 $/(1X,2E17.9)) CHE21320 WRITE (IOUT,3575) CHE21330 3575 FORMAT(/,15X,'ATOM #',5X,'V.D.W. RADII (MULTIPLIED BY FACTOR)') CHE21340 DO 3500 I=1,NATOMS CHE21350 WRITE (IOUT,4000)I,VDWR(I) CHE21360 4000 FORMAT (15X,I5,20X,F5.2) CHE21370 3500 CONTINUE CHE21380 c WRITE (IOUT,4500)NPTS CHE21390 4500 FORMAT(/2X,'NUMBER OF POINTS TO FIT',I6) CHE21400 170 CONTINUE CHE21410 C***********************************************************************CHE21420 C CHE21430 C READ IN ALPHA MO COEFFICIENTS CHE21440 C CHE21450 IFILENO = 30524 CHE21460 CALL FILEIO (IFIND,-IFILENO,NWORDS,COEF_ALPHA,0) CHE21470 CALL FILEIO (IREAD,-IFILENO,NWORDS,COEF_ALPHA,0) CHE21480 C***********************************************************************CHE21490 C CHE21500 C READ IN THE BETA MO COEFFICIENTS CHE21510 C CHE21520 IFILENO = 30526 CHE21530 CALL FILEIO (IFIND,IFILENO,NWORDS,COEF_BETA,0) CHE21540 IF (NWORDS.EQ.0) THEN CHE21550 IUHF = 0 CHE21560 GOTO 300 CHE21570 END IF CHE21580 IUHF = 1 CHE21590 CALL FILEIO (IREAD,-IFILENO,NWORDS,COEF_BETA,0) CHE21600 C***********************************************************************CHE21610 300 CONTINUE CHE21620 C***********************************************************************CHE21630 RETURN CHE21640 END CHE21650 SUBROUTINE REDUC1(X,LAMAX,LBMAX,I6TO5) CHE21660 C CHE21670 C MODIFIED FOR POLARIZATION POTENTIAL CALCULATIONS CHE21680 C M.M. FRANCL FEBRUARY 1984 CHE21690 C CHE21700 IMPLICIT REAL*8 (A-H,O-Z) CHE21710 C CHE21720 DIMENSION X(100),S(100),IND5(9),IND6(10) CHE21730 C CHE21740 DATA PT5/0.5/ CHE21750 DATA R3OV2/0.8660254040/ CHE21760 DATA IND5/1, CHE21770 $ 4,7,2, CHE21780 $ 3,6,9,5,8/ CHE21790 DATA IND6/1, CHE21800 $ 4,7,2, CHE21810 $ 6,10,3,9,5,8/ CHE21820 C CHE21830 C ******************************************************************CHE21840 C ROUTINE REORDERS FROM ARRANGEMENT: S,Z,ZZ,X,XZ,XX,Y,YZ,XY,YY CHE21850 C TO S,X,Y,Z,XX,YY,ZZ,XY,XZ,YZ CHE21860 C OR FROM S,Z,X,Y TO S,X,Y,Z CHE21870 C THIS ENSURES LABELING COMPATIBILITY BETWEEN THE SP AND D PACKAGES CHE21880 C AT THE SAME TIME THE INTEGRALS ARE MOVED TO THE FIRST 1,4,10,16, CHE21890 C 40 OR 100 LOCATIONS, DEPENDING ON THE SHELL QUANTUM NUMBERS CHE21900 C ******************************************************************CHE21910 NWORD=LAMAX*LBMAX CHE21920 IF(NWORD-1)5,180,5 CHE21930 5 INTC=0 CHE21940 IF(I6TO5 .EQ. 1) GOTO 40 CHE21950 10 DO 20 I=1,LBMAX CHE21960 ISB=10*(IND6(I)-1) CHE21970 DO 20 J=1,LAMAX CHE21980 ISA=ISB+IND6(J) CHE21990 INTC=INTC+1 CHE22000 20 S(INTC)=X(ISA) CHE22010 GO TO 160 CHE22020 C ******************************************************************CHE22030 C ROUTINE TO REDUCE SIX D FUNCTIONS TO FIVE CHE22040 C ALSO REORDERS FROM : S,Z,ZZ,X,XZ,XX,Y,YZ,YX,YY CHE22050 C TO S,X,Y,Z,ZZ,XX-YY,XY,XZ,YZ CHE22060 C OR FROM S,Z,X,Y TO S,X,Y,Z CHE22070 C FOR COMPATIBILITY WITH SP PACKAGE CHE22080 C ******************************************************************CHE22090 40 DO 150 I=1,LBMAX CHE22100 ISB=10*(IND5(I)-1) CHE22110 C IFB=0 FOR S,X,Y,Z,XY,XZ,YZ, IFB=1 FOR ZZ-RR, IFB=2 FOR XX-YY CHE22120 IFB = 0 CHE22130 IF(I .EQ. 5) IFB = 1 CHE22140 IF(I .EQ. 6) IFB = 2 CHE22150 80 DO 150 J=1,LAMAX CHE22160 ISA=ISB+IND5(J) CHE22170 IFA = 0 CHE22180 IF(J .EQ. 5) IFA = 1 CHE22190 IF(J .EQ. 6) IFA = 2 CHE22200 120 IHOP = 3*IFB + IFA + 1 CHE22210 GOTO(130,122,123,124,125,126,127,128,129),IHOP CHE22220 C CHE22230 C ******************************************************************CHE22240 C * (F,O,ZA2) *CHE22250 C ******************************************************************CHE22260 122 XX=ZZ1(X,ISA,3,7) CHE22270 GO TO 140 CHE22280 C CHE22290 C ******************************************************************CHE22300 C * (F,O,XA2-YA2) *CHE22310 C ******************************************************************CHE22320 123 XX=XY1(X,ISA,4) CHE22330 GO TO 140 CHE22340 C CHE22350 C ******************************************************************CHE22360 C * (ZB2,O,F) *CHE22370 C ******************************************************************CHE22380 124 XX=ZZ1(X,ISA,30,70) CHE22390 GO TO 140 CHE22400 C CHE22410 C ******************************************************************CHE22420 C * (ZB2,O,ZA2) *CHE22430 C ******************************************************************CHE22440 125 XX=ZZ1(X,ISA,30,70)-PT5*(ZZ1(X,ISA+3,30,70)+ZZ1(X,ISA+7,30,70)) CHE22450 GO TO 140 CHE22460 C CHE22470 C ******************************************************************CHE22480 C * (ZB2,O,XA2-YA2) *CHE22490 C ******************************************************************CHE22500 126 XX=R3OV2*(ZZ1(X,ISA,30,70)-ZZ1(X,ISA+4,30,70)) CHE22510 GO TO 140 CHE22520 C CHE22530 C ******************************************************************CHE22540 C * (XB2-YB2,O,F) *CHE22550 C ******************************************************************CHE22560 127 XX=XY1(X,ISA,40) CHE22570 GO TO 140 CHE22580 C CHE22590 C ******************************************************************CHE22600 C * (XB2-YB2,O,ZA2) *CHE22610 C ******************************************************************CHE22620 128 XX=R3OV2*(ZZ1(X,ISA,3,7)-ZZ1(X,ISA+40,3,7)) CHE22630 GO TO 140 CHE22640 C CHE22650 C ******************************************************************CHE22660 C * (XB2-YB2,O,XA2-YA2) *CHE22670 C ******************************************************************CHE22680 129 XX=R3OV2*(XY1(X,ISA,4)-XY1(X,ISA+40,4)) CHE22690 GO TO 140 CHE22700 C CHE22710 C ******************************************************************CHE22720 C * (F,O,F) *CHE22730 C ******************************************************************CHE22740 130 XX=X(ISA) CHE22750 140 INTC=INTC+1 CHE22760 150 S(INTC)=XX CHE22770 160 DO 170 I=1,NWORD CHE22780 170 X(I)=S(I) CHE22790 180 RETURN CHE22800 END CHE22810 SUBROUTINE STAR(NBASIS,SHELLT,SHELLC,AOS,NSHELL,NOSTAR) CHE22820 C CHE22830 C ROUTINE TO MODIFY COMMON /B/ TO THE EXPECTED FORMAT FOR INTGRL CHE22840 C FOR BASIS SETS HAVING P ONLY SHELLS, SUCH AS THE 6-31G** BASIS CHE22850 C CHE22860 IMPLICIT REAL*8 (A-H,O-Z) CHE22870 INTEGER*4 SHELLC,SHELLT,AOS CHE22880 C CHE22890 DIMENSION SHELLC(2000),SHELLT(2000),AOS(2000) CHE22900 C CHE22910 C LOOP OVER SHELLS CHE22920 C CHE22930 DO 100 I=1,NSHELL CHE22940 IF (SHELLT(I).EQ.1 .AND. SHELLC(I).EQ.1) THEN CHE22950 NBASIS = NBASIS + 1 CHE22960 NOSTAR = 1 CHE22970 DO 200 J=I,NSHELL CHE22980 AOS(J) = AOS(J) + 1 CHE22990 200 CONTINUE CHE23000 END IF CHE23010 100 CONTINUE CHE23020 RETURN CHE23030 END CHE23040 SUBROUTINE UEP CHE23050 C CHE23060 C ROUTINE TO CALCULATE THE ELECTROSTATIC POTENTIAL FROM FIRST ORDCHE23070 C PERTURBATION THEORY CHE23080 C CHE23090 C M.M. FRANCL JULY 1985 CHE23100 C MODIFIED VERSION OF A MEPHISTO ROUTINE CHE23110 C RESTRICTED TO UNRESTRICTED HARTREE-FOCK WAVEFUNCTIONS CHE23120 C CHE23130 IMPLICIT REAL*8 (A-H,O-Z) CHE23140 PARAMETER (NPOINTS = 50000) CHE23150 INTEGER*4 SHELLA,SHELLN,SHELLT,AOS,SHELLC,AON,HANDLE CHE23160 CHARACTER*40 CHKFIL CHE23170 C CHE23180 COMMON /IO/ IN,IOUT CHE23190 COMMON /IPO/ IPO(5) CHE23200 C+++ CHE23210 COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS, CHE23220 $ IAN(401),ATMCHG(400),C(3,400) CHE23230 C CHE23240 C=== Gaussian88 Modification for enlarged common /b/. CHE23250 Common/BB/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), CHE23260 $Z(2000),JAN(2000),ShellA(2000),ShellN(2000),ShellT(2000), CHE23270 $ShellC(2000),AOS(2000),AON(2000),NShell,MaxTyp CHE23280 C CHE23290 C=== Old G86 Common /b/ CHE23300 c COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200), CHE23310 c $ X(400),Y(400),Z(400),JAN(400),SHELLA(400),SHELLN(400), CHE23320 c $ SHELLT(400),SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP CHE23330 C+++ CHE23340 C COMMON /B/ EXX(240),C1(240),C2(240),C3(240),X(80),Y(80),Z(80), CHE23350 C $ JAN(80),SHELLA(80),SHELLN(80),SHELLT(80),SHELLC(80) CHE23360 C $ ,AOS(80),AON(80),NSHELL,MAXTYP CHE23370 C COMMON /MOL/ NATOMS,ICHARG,MULTIP,NAE,NBE,NEL,NBASIS,IAN(101), CHE23380 C $ ATMCHG(100),C(3,100) CHE23390 COMMON /POINTS/ P(3,NPOINTS),MAXPNTS CHE23400 COMMON /ELP/ ELECP(NPOINTS) CHE23410 COMMON /CHARGE/ COEF_ALPHA(100000),COEF_BETA(100000),IUHF CHE23420 COMMON /OUT/ Q(400),RMS,PERCENT,NTITLE(20,3),I6TO5,NLIN,NEND(3), CHE23430 1 CHKFIL CHE23440 C CHE23450 DIMENSION HPERT(100000),INDEX(1280) CHE23460 C CHE23470 DATA IPTCHG/1.0/ CHE23480 DATA ZERO/0.0/, TWO/2.0/, VNUCMAX/30.0/ CHE23490 C CHE23500 C INTIALIZE TIMING CHE23510 C CHE23520 HANDLE = 0 CHE23530 C CHE23540 C SET UP THE INDEXING TABLE FOR HPERT CHE23550 C CHE23560 DO 100 I=1,NBASIS CHE23570 INDEX(I) = (I-1)*I/2 CHE23580 100 CONTINUE CHE23590 C CHE23600 C BEGIN LOOP TO CALCULATE ELECTROSTATIC POTENTIAL CHE23610 C CHE23620 DO 200 NPNT=1,MAXPNTS CHE23630 X1 = P(1,NPNT) CHE23640 X2 = P(2,NPNT) CHE23650 X3 = P(3,NPNT) CHE23660 C CHE23670 C CALCULATE THE ONE-ELECTRON INTEGRALS CHE23680 C CHE23690 IF (IPO(5).EQ.1) THEN CHE23700 WRITE(IOUT,3010) CHE23710 3010 FORMAT(1X,'TIME FOR INTEGRALS') CHE23720 C*** CHE23730 C ISTAT = LIB$INIT_TIMER(HANDLE) CHE23740 C*** CHE23750 END IF CHE23760 C CHE23770 CALL INTGRL (HPERT,X1,X2,X3,IPTCHG,I6TO5) CHE23780 C CHE23790 C*** CHE23800 C IF (IPO(5).EQ.1) ISTAT = LIB$SHOW_TIMER(HANDLE) CHE23810 C*** CHE23820 C CHE23830 IF (IPO(4).EQ.1) CALL LINOUT (HPERT,NBASIS,0,0) CHE23840 C CHE23850 IF (IPO(5).EQ.1) THEN CHE23860 WRITE(IOUT,3000) CHE23870 3000 FORMAT(1X,'TIME FOR TRANSFORM') CHE23880 C*** CHE23890 C ISTAT = LIB$INIT_TIMER(HANDLE) CHE23900 C*** CHE23910 END IF CHE23920 C CHE23930 C FORM THE HPERT MATRIX ELEMENTS CHE23940 C CHE23950 C ALPHA CODE CHE23960 C CHE23970 E = ZERO CHE23980 ICOEFI = -NBASIS CHE23990 C CHE24000 C SUM OVER OCCUPIED ALPHA MOS CHE24010 C CHE24020 DO 220 II=1,NAE CHE24030 ICOEFI = ICOEFI + NBASIS CHE24040 C CHE24050 C CALCULATE ELECTROSTATIC POTENTIAL CHE24060 C CHE24070 DO 221 IP=1,NBASIS CHE24080 CPI = COEF_ALPHA(ICOEFI+IP) CHE24090 IPDEX = INDEX(IP) CHE24100 C CHE24110 DO 222 IQ=1,IP CHE24120 E = E + CPI * COEF_ALPHA(ICOEFI+IQ) * HPERT(IPDEX+IQ) CHE24130 222 CONTINUE CHE24140 DO 223 IQ=IP+1,NBASIS CHE24150 E = E + CPI * COEF_ALPHA(ICOEFI+IQ) * HPERT(IP+INDEX(IQ)) CHE24160 223 CONTINUE CHE24170 C CHE24180 221 CONTINUE CHE24190 220 CONTINUE CHE24200 C CHE24210 C BETA CODE CHE24220 C CHE24230 ICOEFI = -NBASIS CHE24240 C CHE24250 C SUM OVER OCCUPIED BETA MOS CHE24260 C CHE24270 DO 420 II=1,NBE CHE24280 ICOEFI = ICOEFI + NBASIS CHE24290 C CHE24300 C CALCULATE ELECTROSTATIC POTENTIAL CHE24310 C CHE24320 DO 421 IP=1,NBASIS CHE24330 CPI = COEF_BETA(ICOEFI+IP) CHE24340 IPDEX = INDEX(IP) CHE24350 C CHE24360 DO 422 IQ=1,IP CHE24370 E = E + CPI * COEF_BETA(ICOEFI+IQ) * HPERT(IPDEX+IQ) CHE24380 422 CONTINUE CHE24390 DO 423 IQ=IP+1,NBASIS CHE24400 E = E + CPI * COEF_BETA(ICOEFI+IQ) * HPERT(IP+INDEX(IQ)) CHE24410 E = E + CPI * COEF_* HPERT(IP+INDEX(IQ)) CHE24420 423 CONTINUE CHE24430 C CHE24440 421 CONTINUE CHE24450 420 CONTINUE CHE24460 C CHE24470 C*** CHE24480 C IF (IPO(5) .EQ. 1) ISTAT = LIB$SHOW_TIMER(HANDLE) CHE24490 C*** CHE24500 C CHE24510 C CALCULATE NUCLEAR PART OF ELECTROSTATIC POTENTIAL CHE24520 C CHE24530 VNUC = ZERO CHE24540 DO 300 IATOM=1,NATOMS CHE24550 DEL1 = C(1,IATOM) - X1 CHE24560 DEL2 = C(2,IATOM) - X2 CHE24570 DEL3 = C(3,IATOM) - X3 CHE24580 RA = DSQRT(DEL1*DEL1 + DEL2*DEL2 + DEL3*DEL3) CHE24590 IF (RA.EQ.ZERO) THEN CHE24600 VNUC=VNUCMAX CHE24610 GOTO 310 CHE24620 END IF CHE24630 VNUC = VNUC + IAN(IATOM) / RA CHE24640 300 CONTINUE CHE24650 310 CONTINUE CHE24660 C CHE24670 ELECP(NPNT) = (E + VNUC * IPTCHG) CHE24680 IF (IPO(5) .EQ. 1) WRITE(IOUT,*) 'E(',NPNT,') = ',E CHE24690 200 CONTINUE CHE24700 RETURN CHE24710 END CHE24720 SUBROUTINE UNSTAR(NBASIS,SHELLT,SHELLC,AOS,NSHELL,H,NOSTAR) CHE24730 C CHE24740 C ROUTINE TO REFORMAT COMMON/B/ AND THE H ARRAY FOR BASIS CHE24750 C SETS HAVING P ONLY SHELLS CHE24760 C CHE24770 IMPLICIT REAL*8 (A-H,O-Z) CHE24780 INTEGER*4 SHELLC,SHELLT,AOS CHE24790 C CHE24800 DIMENSION SHELLC(2000),SHELLT(2000),AOS(2000),H(1) CHE24810 C CHE24820 IF (NOSTAR.EQ.0) RETURN CHE24830 C CHE24840 C LOOP OVER SHELLS CHE24850 C CHE24860 DO 100 I=1,NSHELL CHE24870 IF (SHELLT(I).EQ.1 .AND. SHELLC(I).EQ.1) THEN CHE24880 C CHE24890 C REMOVE EXTRA ROWS AND COLUMNS CHE24900 C CHE24910 C LOOP OVER ROWS CHE24920 C CHE24930 IBASIS = AOS(I) CHE24940 ITEM = (IBASIS-1) * IBASIS / 2 CHE24950 DO 200 J=IBASIS+1,NBASIS CHE24960 C CHE24970 C LOOP OVER COLUMNS CHE24980 C CHE24990 NEWITEM = (J-1) * J /2 CHE25000 DO 250 K=1,IBASIS-1 CHE25010 ITEM = ITEM + 1 CHE25020 NEWITEM = NEWITEM + 1 CHE25030 H(ITEM) = H(NEWITEM) CHE25040 250 CONTINUE CHE25050 C CHE25060 C SKIP THE VALUE IN THE IBASIS TH COLUMN CHE25070 C CHE25080 NEWITEM = NEWITEM + 1 CHE25090 C CHE25100 DO 260 K=IBASIS+1,J CHE25110 ITEM = ITEM + 1 CHE25120 NEWITEM = NEWITEM + 1 CHE25130 H(ITEM) = H(NEWITEM) CHE25140 260 CONTINUE CHE25150 200 CONTINUE CHE25160 NBASIS = NBASIS - 1 CHE25170 C CHE25180 C RESTRUCTURE AOS TO ACCOUNT FOR THE S SHELL REMOVED CHE25190 C CHE25200 DO 300 IAOS = I,NSHELL CHE25210 AOS(IAOS) = AOS(IAOS) - 1 CHE25220 300 CONTINUE CHE25230 C CHE25240 END IF CHE25250 100 CONTINUE CHE25260 RETURN CHE25270 END CHE25280 FUNCTION XY1(X,I,IY) CHE25290 C CHE25300 DIMENSION X(100) CHE25310 C CHE25320 DATA HALFR3/0.8660254040/ CHE25330 C CHE25340 XY1=HALFR3*(X(I)-X(I+IY)) CHE25350 RETURN CHE25360 END CHE25370 FUNCTION ZZ1(X,I,IX,IY) CHE25380 C CHE25390 DIMENSION X(100) CHE25400 C CHE25410 DATA HALF/0.5/ CHE25420 C CHE25430 ZZ1=X(I)-HALF*(X(I+IX)+X(I+IY)) CHE25440 RETURN CHE25450 END CHE25460