      SUBROUTINE INSTRU
C     PROGRAM CNDOP
CB.01 LAST CHANGE 30 NOV 2020
C     THIS IS PROGRAM CNDOP, A SYNTHESIS OF:                            CNI00040
C     ...CNINDO (QCPE 141) PAUL N. KUZNETSOV, INSPIRED BY               CNI00050
C     ...JOHN A. POPLE AND DAVID L. BEVERIDGE, APPROXIMATE MOLECULAR    CNI00060
C     ......ORBITAL THEORY (MCGRAW-HILL, NEW YORK, NY 1971)             CNI00070
C     QCPE=EX-QUANTUM CHEMISTRY PROGRAM EXCHANGE, INDIANA UNIVERSITY    CNI00080
C     ...AND MANY IMPROVEMENTS/EXTENSIONS ..............................CNI00090
C     ...CNDOP-SCHWEIG  (QCPE 261) BY HASE AND A.SCHWEIG (GE,AS,SE,BR)  CNI00100
C     ...ORLOC          (QCPE 267) BY PAUL M.KUZNESOF                   CNI00110
C     ...CNDO/S (NON-CI) BY JANET DEL BENE AND HEINZ H.JAFFE            CNI00120
C     ...INDO/S (NON-CI) BY KROGH-JESPERSEN AND MARK ALAN RATNER        CNI00130
C     ...CNDOP FOR THIRD ROW ATOMS BY D.P.SANTRY, J.SABIN, AND WEISS    CNI00135
C     ......AND KORTH J.AM.CHEM.SOC.100:2670 (1978)                     CNI00140
C     ...CNDO/ON (CNDOTWO)  BY ROALD HOFFMANN (CORNELL)                 CNI00150
C     ...PULAY DIIS (PETER PULAY, J.COMP.CHEM.3:556(1982)               CNI00160
C     ...CNDO/2-FPP (RHEE,METZGER AND WIYGUL,J.CHEM.PHYS.77:899(1982)   CNI00170
C     ...CNDO/2-FPPI IMPROVEMENTS AND REPAIRS TO CNDO/2-FPP (WITH HELP  CNI00180
C     ......FROM JAMES E.EILERS (EASTMAN KODAK AND SUNY ROCKPORT) 1985  CNI00190
C-----------------------------------------------------------------------CNI00230
C     RUNNING ON UNIV. OF MISSISSIPPI DEC 1077       (1976-79)          CNI00240
C     MODIFIED FOR HEIDELBERG IBM 370/168            (SEP 1979)         CNI00250
C     MODIFIED FOR UNIV.DE BORDEAUX I DEC VAX 11/780 (APR 1980)         CNI00260
C     MODIFIED FOR UNIV. OF MISS. DEC 1077           (SEP 1980)         CNI00270
C     MODIFIED FOR UNIV. OF MISS. IBM 4341           (JUN 1984)         CNI00280
C     MODIFIED FOR UNIV. OF MISS. AMDAHL 470/V8      (JUN 1985)         CNI00290
C     MODIFIED FOR UNIV. OF ALA. IBM 3081D           (FEB 1988)         CNI00300
C     MODIFIED FOR UNIV. OF ALA. IBM 3090 VS FORTRAN)    (1990)         CNI00303
C     MODIFIED FOR IBM 65XD THINKPAD PC+DEC VISUAL FORTRAN 5.0(JUN 1998)CNI00305
C     MODIFIED FOR MACBOOK PRO WITH INTEL COMPILER   (JUL 2015)         CNI00308
C-----------------------------------------------------------------------
C     Intel compiler problems ("INTEL DEVELOPER STUDIO"):
C     QUERY: sysctl -a | grep machdep.cpu.brand_string
C     ANSWER:
C     machdep.cpu.brand_string: Intel(R) Core (TM) i9-9880H CPU @ 2.38GHz
C ----NEWEST VERSION OF INTEL FORTRAN COMPILER: 19.1.3
C     (XE 2020)/20 OCT 2020 :
C     version installed on MacBookPro: DZNF-LD9GW6XZ  (2020.11.02)
C     EDUCATOR INTEL PARAllEL STUDIO XE COMPOSER EDITION FOR FORTRAN macOS
C     "active 31 Oct 2021"
C     INTEL USERNAME=rmetzger99@ua,edu,newest password=segg00#baz
C     2020.11.30: COMMAND LINE: source /opt/intel/bin/compilervars.sh intel64
C     STOPPED WORKING ON 2020.11.30......
C-----FROM Ronald_G_intel ON 13 NOV 2020 posted on
C     community.intel.cOm/Intel/Fortran-COmpiler/macOS:
C     SUBTITLE 1: "Intel(R) Parallel Studio XE 2020 for macOS*  and all prior
C     versions of Intel(R) Parallel Studio XE for macOS* are NOT compatible with
C     macOS* 11 Big Sur.
C     SUBTITLE 2: "Errors will be missing libraries suh as -lSystem not found"
C     Subtitle 3: More background
C     TEXT: "New In macOS 11 Big Sur 11.0.1, the system ships wIth a built-in
C     dynamic linker cache of all system-provided libraries. As part of this
C     change, copies of dynamic libraries are no longer present on the file
C     system. Code that attempts to check for dyaniic library pesence by
C     looking for a file at a path or enumerating a direcotry will fail.
C     https://developer.apple.com/documentation/macos-release-notes/
C     macos-big-sur-11_0_1-release-notes
C     -----------
C     North America Customer Support Center: tel=1-916-377-7000
C     MTuWThF 7:00 AM TO 5:0 PM Pacific time: NO HELP !!!

C     Intel customer.support.case.number=04888283 (2020.11.30)
C-----------------------------------------------------------------------
C-----PROGRAMMER: ROBERT MELVILLE METZGER, DEPT. OF CHEMISTRY-----------CNI00310
C     UNIVERSITY OF ALABAMA, TUSCALOOSA AL 35487-9671 USA               CNI00320
C     TELEPHONE (205)-348-5952, (205)-977-6298, (205)-344-5706          CNI00330
C-----------------------------------------------------------------------CNI00340
C DESCRIPTION OF INPUT DATA DECK.                                       CNI00350
C-----------------------------------------------------------------------CNI00360
CDATA CARD TYPE 1: TITLE CARD (READ BY MAIN PROGRAM)                    CNI00370
C01    FORMAT (18A4)                                                    CNI00380
C01    COLS  1-72: ITITOL=ALPHANUMERIC INFORMATION FOR TITLE OF JOB.    CNI00390
C01                (18A4)                                               CNI00400
C-----------------------------------------------------------------------CNI00410
C DATA CARD TYPE 2: OPTIONS CARD (READ BY MAIN PROGRAM)                 CNI00420
C02    FORMAT (A4,1X,A4)                                                CNI00430
C02    COLS  1- 4: OPTION=CNDO: CNDO/2 CALCULATION WILL BE DONE.        CNI00440
C02                (A4)  =INDO: INDO CALCULATION WILL BE DONE.          CNI00450
C02    COL      5: (1X)   LEAVE BLANK.                                  CNI00460
C02    COLS  6- 9: OPNCLO=OPEN: OPEN-SHELL CALCULATION WILL BE DONE.    CNI00470
C02                (A4)  =CLSD: CLOSED-SHELL CALCULATION WILL BE DONE.  CNI00480
C02    COLS 10-16: (7X)   TYPE 'IPIECE=' IF YOU LIKE.                   CNI00490
C02    COLS 17-18: IPIECE=0: STANDARD RUN (DEFAULT)                     CNI00500
C02                (I2)  =10: IPOLAR=1 RUN, BUR ZERO FIELD ONLY.        CNI00510
C02                           DIPOLE MOMENT AND POLARIZA-               CNI00520
C02                           BILITY DATA (PROVIDED I;POLAR=1 IS        CNI00530
C02                           SPECIFIED) IS STORED ON FORTRAN           CNI00540
C02                           LOGICAL LPIECE FOR LATER USE.             CNI00550
C02                      =11: IPOLAR=1 RUN, WITH X-FIELD ONLY.          CNI00560
C02                           LPIECE IS USED FOR INPUT AND              CNI00570
C02                           OUTPUT.                                   CNI00580
C02                      =12: IPOLAR=1 RUN, WITH Y-FIELD ONLY.          CNI00590
C02                           INTERMEDIATE DATA IS RETRIEVED            CNI00600
C02                           FROM LPIECE, AND NEW DATA ARE PUT ON LPIECCNI00610
C02                      =13: IPOLAR=1 RUN, WITH Z-FIELD, AND WRAP-UP.  CNI00620
C02    COLS 19-25: (7X)       TYPE 'IPLFCN=' IF YOU LIKE                CNI00630
C02    COL     26: IPLFCN=0:  DO NOT ADD POLARIZATION FUNCTIONS TO      CNI00640
C02                (I1)       BASIS SET (DEFAULT).                      CNI00650
C02                      =1:  DO ADD POLARIZATION FUNCTIONS TO BASIS    CNI00660
C02                           SET. METHOD OF MURRELL AND TEIXEIRA-DIAS, CNI00670
C02                           MOL.PHYS.19,329(1970) AND J.CHEM.SOC.     CNI00680
C02                           FARADAY TRANS.II,906(1975)                CNI00690
C02                           CNDO ONLY. ADD 2P TO H, 3D TO C,N,O,F.    CNI00700
C02                           3D TO NA,MG,AL,SI,P,S,CL.                 CNI00710
C02                           IPLFCN=1 CAN RUN ONLY WITH INUPAR=0       CNI00720
C02                           (POPLE SCHEME) OR WITH INUPAR=4           CNI00730
C02    COLS 27-33: (7X)       TYPE 'BONDMX=' IF YOU LIKE                CNI00740
C02    COLS 34-37: BONDMX=    MAXIMUM DISTANCE (ANGSTROMS) BETWEEN      CNI00750
C02                (F4.0)     COVALENTLY BONDED ATOMS. ESSENTIAL        CNI00760
C02                           FOR DECOMPOSITION OF ATOM-IN-MOLECULE     CNI00770
C02                           POLARIZABILITIES. (DEFAULT=1.60)          CNI00780
C02    COLS 38-44: (7X)       TYPE 'IBRIEF=' IF YOU LIKE                CNI00790
C02    COL     45: IBRIEF=0:  STANDARD RUN, ALL INTERMEDIATE MATRICES   CNI00800
C02                (I1)       WILL BE PRINTED (DEFAULT)                 CNI00810
C02                      =1:  SHORTENED OUTPUT: ONLY ESSENTIAL RESULTS  CNI00820
C02                           WILL BE PRINTED                           CNI00830
C02    COLS 46-52: (7X)       TYPE 'SHIFTR=' IF YOU LIKE                CNI00840
C02    COLS 53-56: SHIFTR=0.0: STANDARD RUN                             CNI00850
C02                (F4.0)     IF SHIFTR IS NOT ZERO THEN SAUNDERS       CNI00860
C02                           VIRTUAL ENERGY LEVEL SHIFTING TRICK WILL  CNI00870
C02                           BE USED TO IMPROVE SCF CYCLE CONVERGENCE  CNI00880
C02                           METHOD IS DESCRIBED BY G.PONGOR,          CNI00890
C02                           CHEM.PHYS.LETTERS 24,603 (1974).          CNI00900
C02                           VIRTUAL LEVELS ARE SHIFTED UPWARDS BY     CNI00910
C02                           SHIFTR HARTREES....                       CNI00920
C02    COLS 57-60:            TYPE 'IRN=' IF YOU LIKE                   CNI00930
C02    COL     61: IRN=   0:  DO NOT TICKLE FOCK MATRIX WITH RANDOM NO. CNI00940
C02                (I1)=  1:  DO TICKLE FOCK MATRIX                     CNI00950
C02    COLS 62-65:            TYPE 'IDM=' IF YOU LIKE                   CNI00960
C02    COL     66: IDM=   0:  DO NOT AVERAGE DENSITY MATRIX BETWEEN CYCLCNI00970
C02                (I1)=  1:  DO AVERAGE DENSITY MATRIX BETWEEN CYCLES  CNI00980
C02    COLS 67-71:            TYPE 'IPUL=' IF YOU LIKE                  CNI00990
C02    COL     72: IPUL  =0:  DO NOT DO PULAY GRADIENT MINIMIZATION     CNI01000
C02                (I1)  =1:  PERFORM PULAY DIIS GRADIENT MINIMIZATION  CNI01010
C02                           (COSTS LOTS OF CORE....)                  CNI01020
C-----------------------------------------------------------------------CNI01030
C DATA CARD TYPE  3: SIZE, D ORBITAL PARTICIPATION,FIELD CONTROL CARD.  CNI01040
C03                          (READ BY MAIN PROGRAM)                     CNI01045
C03    COLS  1- 4: NATOMS=   NUMBER OF ATOMS, AND NUMBER OF             CNI01050
C03                (I4)      DATA CARDS TYPE 4.                         CNI01060
C03    COLS  5- 8: NCHARG=   FORMAL ELECTRIC CHARGE (INTEGER) ON        CNI01070
C03                (I4)      MOLECULE                                   CNI01080
C03    COLS  9-12: MULTIP=   MULTIPLICITY OF MOLECULE (SPIN)            CNI01090
C03                (I4)                                                 CNI01100
C03    COLS 13-19: (7X)      TYPE 'INODEE=' IF YOU LIKE.                CNI01110
C03    COL     20: INODEE=0: IN A CNDO/2 CALCULATION (OPTION=CNDO)      CNI01120
C03                          FOR 2ND AND 3RD ROW ATOMS,                 CNI01130
C03                          (NA,MG,AL,SI,P,S,CL; GE,AS,SE,BR)          CNI01140
C03                          DO INCLUDE D ORBITALS. (DEFAULT=0)         CNI01150
C03                          (IPLFCN=1 REQUIRES INODEE=0)               CNI01160
C03                      =1: IN CNDO/2, FOR 2ND AND 3RD ROW ATOMS,      CNI01170
C03                          IGNORE D ORBITALS                          CNI01180
C03                          (INUPAR=5 BELOW REQUIRES INODEE=1)         CNI01190
C03    COLS 21-27: (7X)      TYPE 'INUPAR=' IF YOU LIKE                 CNI01200
C03    COL     28: INUPAR=0: USE CNDO PARAMETERS FOR NA,MG,AL,SI,P,S,CL CNI01210
C03                (I1)      FROM DOBOSH-POPLE PROGRAM (SEE             CNI01220
C03                          POPLE-BEVERIDGE BOOK)                      CNI01230
C03                      =1: USE CNDO PARAMETRS FOR                     CNI01240
C03                          NA,MG,AL,SI,P,S,CL FROM                    CNI01250
C03                          SANTRY,SABIN, AND WEISS                    CNI01260
C03                          (JACS 90,3309(1968),JACS 94,6651(1972))    CNI01270
C03                          AND PROGRAM FLOCIN FROM SABIN (U.FLA.)     CNI01280
C03                      =2: USE CNDO PARAMETERS FOR H,C,N,O FROM       CNI01290
C03                          J. DEL BENE AND H.H.JAFFE, J.CHEM.PHYS.48, CNI01300
C03                          1807,4050(1968), AND T.MIYAZAKI AND H.     CNI01310
C03                          SHINODA, BULL.CHEM.SOC.JAPAN 46,1216(1973) CNI01320
C03                          AND R.L.ELLIS,G.KUEHNLENZ, AND H.H.JAFFE,  CNI01330
C03                          THEOR.CHIM.ACTA 26,131 (1972).             CNI01340
C03                          FOR KD=0.300 CF. R.W.SCHULTE AND A.SCHWEIG,CNI01350
C03                          THEOR.CHIM.ACTA,33,19(1974)                CNI01360
C03                          NO CONFIGURATION INTERACTIONS VERSION.     CNI01370
C03                      =3: SAME AS INUPAR=2, BUT                      CNI01380
C03                          WITH CONFIGURATION INTERACTION).           CNI01390
C02                  *****    =3 DOES NOT WORK YET....                  CNI01400
C03                      =4: USE INDO/S PARAMETERS FROM K.KROGH-        CNI01410
C03                          JESPERSEN AND M.RATNER, J.CHEM.PHYS.65,    CNI01420
C03                          1305(1976) AND THEOR.CHIM.ACTA 47,283      CNI01430
C03                          (1978)...                                  CNI01440
C03                          NO CONFIGURATION INTERACTIONS.             CNI01450
C03                      =5: USE INDO PARAMETERS FOR NA,MG,AL,SI,P,S,CL,CNI01460
C03                          OF M.S.GORDON, M.D.BJORKE, F.J.MARSH,      CNI01470
C03                          AND M.S.KORTH, J.AM.CHEM.SOC.100,          CNI01480
C03                          2670 (1978). INUPAR=5 REQUIRES             CNI01490
C03                          INODEE=1                                   CNI01500
C03    COLS 29-35: (7X)      TYPE 'ICONVR=' IF YOU LIKE                 CNI01510
C03    COLS 36-38: ICONVR=   CONVERGENCE CRITERION EXPONENT.            CNI01520
C03                (I3)      PROGRAM WILL HALT IF THE                   CNI01530
C03                          ENERGY (WHEN IPOLAR=0) OR THE DENSITY      CNI01540
C03                          MATRIX ELEMENTS SHIFT LESS THAN            CNI01550
C03                          10**(-ICONVR) IN ONE CYCLE.                CNI01560
C03    COLS 39-45: (7X)      TYPE 'NLOCIT=' IF YOU LIKE                 CNI01570
C03    COLS 46-49: NLOCIT=   NUMBER OF ITERATIONS DESIRED TO ACHIEVE    CNI01580
C03                (I4)      LOCALIZED M.O. CONVERGENCE.                CNI01590
C03                          IF NO LOCALIZED MOS DESIRED, PUT NLOCIT=0  CNI01600
C03    COLS 50-56: (7X)      TYPE 'IPOLAR=' IF YOU LIKE.                CNI01610
C03    COL     57: IPOLAR=0: NO ELECTRIC FIELD . MOLECULE SITS          CNI01620
C03                (I1)      IN ZERO EXTERNAL FIELD. POLARIZABILITY     CNI01630
C03                          WILL NOT BE CALCULATED.                    CNI01640
C03                      =1: POLARIZABILITY WILL BE CALCULATED.         CNI01650
C03                          FOUR ITERATIONS: FIRST: NO FIELD.          CNI01660
C03                          SECOND: FIELD ALONG X; THIRD: FIELD ALONG  CNI01670
C03                          Y; FOURTH: FIELD ALONG Z CARTESIAN         CNI01680
C03                          DIRECTION.                                 CNI01690
C03                      =2: HYPERPOLARIZABILITY (BETA) WILL BE         CNI01700
C03                          CALCULATED. FIELD WILL BE FIRST +0.01      CNI01710
C03                          ELECTRONS/ANGSTROMS**2, THEN -0.01         CNI01720
C03                          ELECTRONS/ANGSTROMS, THEN FINALLY          CNI01730
C03                          0.000001 ELECTRONS/ANGSTROMS, AND          CNI01740
C03                          10 ITERATIONS WILL BE PERFORMED.           CNI01750
C03                          1ST ITER: ZERO FIELD.                      CNI01760
C03                          2ND, 3RD, 4TH ITER.: FIELD = 0.01 IN X,    CNI01770
C03                          THEN Y, THEN Z DIRECTIONS; 5TH, 6TH, 7TH:  CNI01780
C03                          FIELD =-0.01 IN X, Y, AND Z DIRECTIONS;    CNI01790
C03                          8TH, 9TH, 10TH: FIELD = 0.000001 IN X, Y,  CNI01800
C03                          AND THEN Z DIRECTIONS. INTERMEDIATE RSULTS CNI01810
C03                          STORED ON FORTRAN LOGICAL LPIECE (WHICH    CNI01820
C03                          MUST BE NON-ZERO).                         CNI01830
C03            ****       IPOLAR=2 DOES NOT WORK YET....                CNI01840
C03    COLS 58-64: (7X)      TYPE 'EFIELD=' IF YOU LIKE.                CNI01850
C03    COLS 65-72: EFIELD =  SIZE OF ELECTRIC FIELD, IN (ELECTRONS      CNI01860
C03                (F8.0)    /ANGSTROMS**2)                             CNI01870
C---------------------------------------------------------------------- CNI01880
C DATA CARDS TYPE 4: ATOM CARDS (READ BY READIN)                        CNI01890
C04    COLS  1- 4: IAN   =   ATOMIC NUMBER (Z) OF ATOM. E.G.            CNI01900
C04                (I4)      FOR H, IAN=1; FOR C, IAN=6; FOR U, IAN=92. CNI01910
C04    COLS  5- 7: (3X)      LEAVE BLANK.                               CNI01920
C04    COLS  8-19: C(I,1)=   CARTESIAN COORDINATE X (ANGSTROMS)         CNI01930
C04                (F12.7)   FOR ATOM                                   CNI01940
C04    COLS 20-22: (3X)      LEAVE BLANK                                CNI01950
C04    COLS 23-34: C(I,2)=   CARTESIAN COORDINATE Y (ANGSTROMS)         CNI01960
C04                (F12.7)   FOR ATOM                                   CNI01970
C04    COLS 35-37: (3X)      LEAVE BLANK                                CNI01980
C04    COLS 38-49: C(I,3)=   CARTESIAN COORDINATE Z (ANGSTROMS)         CNI01990
C04                (F12.7)   FOR ATOM.                                  CNI02000
C04    COLS 50-51: (2X)      LEAVE BLANK                                CNI02010
C04    COLS 52-55: ITITLE=   ALPHANUMERIC TITLE FOR ATOM (OPTIONAL)     CNI02020
C04                (A4)                                                 CNI02030
C04    COLS 56-57: ISYMOP=1: THE COORDINATES OF THIS ATOM CORRESPOND TO CNI02040
C04                (I2)      THE REDUCED COORDINATES INPUT TO CELMAP    CNI02050
C04                          FROM A CRYSTAL STRUCTURE DETERMINATION,    CNI02060
C04                          (ATOM IS FROM ASYMMETYRIC UNIT WITHOUT     CNI02070
C04                          COORDINATE TRANSFORMATION); THUS THE ATOM  CNI02080
C04                          WILL HAVE THE PROPER POLARIZABILITY TENSOR CNI02090
C04                          ORIENTATION FOR OUTPUT TO CELMAP AND EWALD CNI02100
C04                          (IMPORTANT ONLY IF IPOLAR=1 FOR LARGE      CNI02110
C04                          MOLECULES)                                 CNI02120
C04                     =0:  (OR ANY POSITIVE INTEGER.NE.1): ABOVE DOES CNI02130
C04                          NOT HOLD.                                  CNI02140
C-------------------------------------------------------------------    CNI02150
C05    RESCALING CARDS  (READ BY ATDATA)                                CNI02160
C05    FIRST CARD (FORMAT (7X,I1,6X,F10.0,4X,I2)                        CNI02170
C05    COLS  1- 7:           WRITE 'NPARAM=' IF YOU LIKE                CNI02180
C05    COL      8: NPARAM=   NUMBER OF ELEMENTS WITH NEW POLARIZATION   CNI02190
C05                (I1)      PARAMETERS (NPARAM.LE.35)                  CNI02200
C05    COLS  9-14:           WRITE 'FUDGE=' IF YOU LIKE                 CNI02202
C05    COLS 15-24: FUDGE=    MULTIPLIER FOR MINIMUM BOND DISTANCE USED  CNI02204
C05                (F10.0)   TO ENABLE THE SUM OF AIM POLARIZABILITIES  CNIO2205
C05                          APPROACH THE MOLECULAR POLARIZABILITY      CNI02207
C05    COLS 25-29:           WRITE 'IBIM=' IF YOU LIKE                  CNI02208
C05    COLS 30-31: IBIM=     INTEGER SPECIFYING WHICH ATOM IN YOUR      CNI
C05                (I2)      ATOMS LIST WILL BE THE LAST ATOM SEARCHED  CNI
C05                          BECAUSE THAT ATOM WILL NOT GET A           CNI
C05                          BOND-IN-MOLECULE POLARIZABILITY            CNI
C05                          (E.G. N IN NH3, C IN CH4, P IN PF3)        CNI
C--------------------------------------------------                     CNI02210
C06 DATA CARDS TYPE 6 (NPARAM OF THEM; READ BY ATDATA)                  CNI02220
C06    FORMAT (7X,I2,2X,F5.3,2X,F5.3,6(3X,F5.3))                        CNI02230
C06    COLS  1- 7:           TYPE 'ELEMNT=' IF YOU LIKE                 CNI02240
C06    COLS  8- 9: K       = ATOMIC NUMBER OF ELEMENT (1 FOR H,6 FOR C) CNI02250
C06                (I2)      WITH NEW POLARIZATION PARAMETERS           CNI02260
C06    COLS 10-11:           TYPE 'Z=' IF YOU LIKE                      CNI02270
C06    COLS 12-16: UMU(K,2)= SLATER EXPONENT FOR POLARIZATION FCN (BOHR)CNI02280
C06                (F5.3)                                               CNI02290
C06    COLS 17-18:           TYPE 'E=' IF YOU LIKE                      CNI02300
C06    COLS 19-23: ENEG(K,2)=ELCTRONEGATIVITY (EV) FOR POLARIZ FCN      CNI02310
C06                (F5.3)                                               CNI02320
C06    COLS 24-26:           TYPE 'K1=' IF YOU LIKE                     CNI02330
C06    COLS 27-31: RKAPPA(K,1)=KAPPA FOR ELEMENT (P-SIGMA)              CNI02340
C06                (F5.3)                                               CNI02350
C06    COLS 32-34:           TYPE "K2=" IF YOU LIKE                     CNI02360
C06    COLS 35-39: RKAPPA(K,2)= KAPPA FOR ELEMENT (P-PI OR D-PIPRIME)   CNI02370
C06                (F5.3)                                               CNI02380
C06    COLS 40-42:           TYPE "K3=" IF YOU LIKE                     CNI02390
C06    COLS 43-47: RKAPPA(K,3)= KAPPA FOR ELEMENT (D-PI)                CNI02400
C06                (F5.3)                                               CNI02410
C06    COLS 48-50:           TYPE "K4=" IF YOU LIKE                     CNI02420
C06    COLS 51-55: RKAPPA(K,4)= KAPPA FOR ELEMENT (D-DELTA)             CNI02430
C06                (F5.3)                                               CNI02440
C06    COLS 56-58:           TYPE "K5=" IF YOU LIKE                     CNI02450
C06    COLS 59-63: RKAPPA(K,5)= KAPPA FOR ELEMENT (D-ORB)               CNI02460
C06                (F5.3)                                               CNI02470
C06    COLS 64-66:           TYPE "K6=" IF YOU LIKE                     CNI02480
C06    COLS 67-71: RKAPPA(K,6)= (DISABLED)                              CNI02490
C06                (F5.3)                                               CNI02500
C-----------------------------------------------------------------------CNI02502
C DATA CARD TYPE 7: PATCHED RUN (IPIECE.GT.0) (READ BY DIPOLE)          CNI02504
C07    COLS 01-25: DIPM(1)=  X-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02506
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02508
C07    COLS 01-25: DMCH(1)=  X-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02510
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02512
C07    COLS 01-25: DIPM(2)=  Y-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02514
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02516
C07    COLS 01-25: DMCH(2)=  Y-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02518
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02520
C07    COLS 01-25: DIPM(3)=  Z-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02522
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02524
C07    COLS 01-25: DMCH(3)=  Z-COMPONENT OF DIPOLE MOMENT (DEBYES)      CNI02526
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02528
C07    COLS 01-25: ATLCHF(1,1)=CHARGE PART OF X POLARIZABILITY ATOM 1   CNI02530
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02532
C07    COLS 01-25: ATLCHG(1,1)=HYBRID PART OF X POLARIZABILITY ATOM 1   CNI02534
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02536
C07    COLS 01-25: ATLCHF(1,2)=CHARGE PART OF Y POLARIZABILITY ATOM 1   CNI02538
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02540
C07    COLS 01-25: ATLCHG(1,2)=HYBRID PART OF X POLARIZABILITY ATOM 1   CNI02542
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02544
C07    COLS 01-25: ATLCHF(1,3)=CHARGE PART OF Z POLARIZABILITY ATOM 1   CNI02546
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02548
C07    COLS 01-25: ATLCHG(1,3)=HYBRID PART OF Z POLARIZABILITY ATOM 1   CNI02550
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02552
C07    COLS 01-25: ATLCHF(2,1)=CHARGE PART OF X POLARIZABILITY ATOM 2   CNI02554
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02556
C07    COLS 01-25: ATLCHG(2,1)=HYBRID PART OF X POLARIZABILITY ATOM 2   CNI02558
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI25560
C07    COLS 01-25: ATLCHF(2,2)=CHARGE PART OF Y POLARIZABILITY ATOM 2   CNI02562
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02564
C07    COLS 01-25: ATLCHG(2,2)=HYBRID PART OF X POLARIZABILITY ATOM 2   CNI02566
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02568
C07    COLS 01-25: ATLCHF(2,3)=CHARGE PART OF Z POLARIZABILITY ATOM 2   CNI02570
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02572
C07    COLS 01-25: ATLCHG(2,3)=HYBRID PART OF Z POLARIZABILITY ATOM 2   CNI02574
C07                (D25.16)  (IF IPIECE.GE.11)                          CNI02576
C07    ...AND SO ON, UNTIL:                                             CNI02578
C07    COLS 01-25: ATLCHG(NATOMS,3)=HYBRID PART OF Z POLARIZABILITY FOR CNI02580
C07                (D25.16)   ATOM NUMBER NATOMS (IF IPIECE.GE.11)      CNI02582
C07--------AND SO ON, SEE READ STATEMENTS BELOW:                        CNI02584
C07   11 FORMAT (D25.16)                                                CNI02586
C07      IF (IPIECE.GE.12) READ (LPIECE,11)                             CNI02588
C07    1(ATLCHF(J,1),(ALMUEF(J,1,K),K=1,3),J=1,NATOMS),                 CNI02590
C07     2(ALFSUM(1,K),ALFACH(1,K),K=1,3)                                CNI02592
C07      IF (IPIECE.EQ.13) READ (LPIECE,11)                             CNI02594
C07     1(ATLCHF(J,2),(ALMUEF(J,2,K),K=1,3),J=1,NATOMS),                CNI02596
C07     2(ALFSUM(2,K),ALFACH(2,K),K=1,3)                                CNI02598
C-----------------------------------------------------------------------CNI02600
C DATA CARD TYPE 8: RETURN DA CAPO CARD (READ BY MAIN PROGRAM)          CNI02602
C08    FORMAT (I1)                                                      CNI02604
C08    COL      1: IDACAP=0: DO NOT RETURN TO START NEW JOB.            CNI02606
C08                (I1)      END OF PRESENT JOB.                        CNI02608
C08                      =1: RETURN DA CAPO, AND START WITH NEW         CNI02610
C08                          DATA CARD TYPE 1 FOR NEXT JOB.             CNI02620
C-----------------------------------------------------------------------CNI02580
C     FORTRAN LOGICAL FILES ARE ASSIGNED IN CFILES                      CNI02590
C-----------------------------------------------------------------------CNI02610
C     FUNDAMENTAL CONSTANTS ARE SET IN CUNITS                           CNI02620
C-----------------------------------------------------------------------CNI02630
      RETURN                                                            CNI02640
CE.01 END OF SUBROUTINE INSTRU (PAGE 1)                                 CNI02660
      END                                                               CNI02670
      SUBROUTINE CINDEX                                                 CNI02680
CB.02 LAST CHANGE 26 FEB 1988 (CNDOP).                                  CNI02690
C     CALLED BY: NONE (DUMMY)                                           CNI02700
C     CALLS    : NONE (DUMMY)                                           CNI02710
C-----INDEX OF SUBROUTINES AND THEIR CALLING SEQUENCES                  CNI02720
C------------------------------------------------------------------     CNI02730
C     FIRST, THE UNCONNECTED DUMMY SUBROUTINES:                         CNI02740
C     -------                                                           CNI02750
C     INSTRU              PAGE 01    INPUT INSTRUCTIONS. (UNC)          CNI02760
C     CINDEX                   02    THIS PAGE...        (UNC)          CNI02770
C     SSHASE                   38    MULLIKEN-RIEKE-ORLOFF AUX.FCN.,    CNI02780
C                                    HASE AND SCHWEIG ALGORITHM (UNC)   CNI02790
C     ...COEFF                 39    PART OF DITTO     (UNC)            CNI02800
C     ...COEFFS                40    PART OF DITTO     (UNC)            CNI02810
C     ......BINOM              41    PART OF DITTO     (UNC)            CNI02820
C     -------------------------------------------------------           CNI02830
C     MAIN PROGRAM             03                                       CNI02840
C     BLOCK DATA          PAGE 05                                       CNI02850
C     MAIN                     03    MAIN PROGRAM                       CNI02860
C     ...CFILES                30    COMPUTER-DEPENDENT ASSIGNMENTS     CNI02870
C     ...CUNITS                31    FUNDAMENTAL PHYSICAL CONSTANTS     CNI02880
C     ...READIN                04    READ IN ATOMS AND SET UP ORBS.     CNI02890
C     ...ATDATA                37    SET SEMIEMPIRICAL ATOM PARAMETERS  CNI02900
C     ...INTGRL                08    INTERATOMIC DIST. AND INTEGRALS    CNI02910
C     ......MATPRS             44    SHORT MATRIX PRINTING              CNI02920
C     ......RELVEC             11    INTERATOMIC VECTOR CALC.           CNI02930
C     ......FACT               12    FACTORIAL N....                    CNI02940
C     ......HARMTR             10    EULERIAN ANGLE ROTATION            CNI02950
C     ......SS                 09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI02960
C     .........AINTGS          14                                       CNI02970
C     .........BINTGS          15                                       CNI02980
C     .........Y               06                                       CNI02990
C     .........Z               06    ENTRY IN Y FUNCTION ROUTINE        CNI03000
C     ............FIND         08    LOCATOR OF Y AND Z ENTRIES         CNI03010
C     ......MATPRT             36    OUTPUT MATRIX TO LINE PRINTER      CNI03020
C     ......REPUL              42    COULOMB REPULSION INTEGRALS        CNI03030
C     .........COULJE          43    EILERS COULOMB INTEGRALS           CNI03040
C     ............FACT         12    FACTORIAL                          CNI03050
C     .........SS              09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI03060
C     ............AINTGS       14                                       CNI03070
C     ............BINTGS       15                                       CNI03080
C     ............Y            06                                       CNI03090
C     ............Z            06    ENTRY IN Y FUNCTION ROUTINE        CNI03100
C     ...............FIND      07    LOCATOR OF Y AND Z ENTRIES         CNI03110
C     ...HUCKCL                15    1ST SCF CLOSED-SHELL HUECKEL GUESS CNI03120
C     ......SCFOUT             23    OUTPUT OF SCF MATRIX               CNI03130
C     .........EIGOUT          24    OUTPUT OF EIGENVALUES              CNI03140
C     ......EIGN               22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03150
C     ...SCFCLO                16    CLOSED-SHELL SCF CYCLE             CNI03160
C     ......SOLPUL             40    SOLVE PULAY DIIS EQUATIONS         CNI03170
C     .........DETPUL          41    EVALUATE PULAY  DETERINANT         CNI03180
C     ......RANNUM             25    RANDOM-NUMBER GENERATOR            CNI03190
C     ......SCFOUT             23    SCF MATRIX OUTPUT                  CNI03200
C     .........EIGOUT          24    OUTPUT OF EIGENVALUES              CNI03210
C     ......EIGN               22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03220
C     ......ON                 39    HOFFMAN OVERLAP-NORMALIZED MATRIX  CNI03310
C     .........INTGRL          08    INTERATOMIC DIST. AND INTEGRALS    CNI02910
C     ............MATPRS       44    SHORT MATRIX PRINTING              CNI02920
C     ............RELVEC       11    INTERATOMIC VECTOR CALC.           CNI02930
C     ............FACT         12    FACTORIAL N....                    CNI02940
C     ............HARMTR       10    EULERIAN ANGLE ROTATION            CNI02950
C     ............SS           09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI02960
C     ...............AINTGS    14                                       CNI02970
C     ...............BINTGS    15                                       CNI02980
C     ...............Y         06                                       CNI02990
C     ...............Z         06    ENTRY IN Y FUNCTION ROUTINE        CNI03000
C     ..................FIND   08    LOCATOR OF Y AND Z ENTRIES         CNI03010
C     ............MATPRT       36    OUTPUT MATRIX TO LINE PRINTER      CNI03020
C     ............REPUL        42    COULOMB REPULSION INTEGRALS        CNI03030
C     ...............COULJE    43    EILERS COULOMB INTEGRALS           CNI03040
C     ..................FACT   12    FACTORIAL                          CNI03050
C     ...............SS        09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI03060
C     ..................AINTGS 14                                       CNI03070
C     ..................BINTGS 15                                       CNI03080
C     ..................Y      06                                       CNI03090
C     ..................Z      06    ENTRY IN Y FUNCTION ROUTINE        CNI03100
C     .....................FIND07    LOCATOR OF Y AND Z ENTRIES         CNI03110
C     .........EIGN            22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03220
C     ......SCFOUT             23    OUTPUT OF SCF MATRIX               CNI03130
C     ...CPRINT                17    CLOSED-SHELL LINE PRINTER OUTPUT   CNI03230
C     ......SCFOUT             23    SCF MATRIX OUTPUT                  CNI03240
C     .........EIGOUT          24    EIGENVALUE OUTPUT                  CNI03250
C     ...ORLOC                 28    RUEDENBERG LOCALIZED ORBITALS      CNI03260
C     ...DIPOLE                18    DIPOLE MOMENT AND POLARIZABILITY   CNI03270
C     ......EIG3               27    3*3 DIAGONALIZATION (ORTEP)        CNI03280
C     .........AXEQB           26    3*3 LINEAR MX EQN (ORTEP)          CNI03290
C     ......WACOS              38    DOUBLE PRECISION ARC COSINE        CNI03300
C     ...HUCKOP                19    1ST OPEN-SHELL HUECKEL SCF GUESS   CNI03330
C     ......SCFOUT             23    SCF MATRIX OUTPUT                  CNI03340
C     .........EIGOUT          24    EIGENVALUE OUTPUT                  CNI03350
C     ......EIGN               22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03360
C     ...SCFOPN                20    OPEN-SHELL SCF CYCLES              CNI03370
C     ......SOLPUL             40    SOLVE PULAY DIIS EQUATIONS         CNI03380
C     .........DETPUL          41    EVALUATE PULAY DETERMINANT         CNI03390
C     ......RANNUM             25    RANDOM-NUMBER GENERATOR            CNI03400
C     ......SCFOUT             23    SCF MATRIX LINE PRINTER OUTPUT     CNI03410
C     .........EIGOUT          24    EIGENVALUE OUTPUT                  CNI03420
C     ......EIGN               22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03430
C     ......ON                 39    HOFFMAN OVERLAP-NORMALIZED MATRIX  CNI03310
C     .........INTGRL          08    INTERATOMIC DIST. AND INTEGRALS    CNI02910
C     ............MATPRS       44    SHORT MATRIX PRINTING              CNI02920
C     ............RELVEC       11    INTERATOMIC VECTOR CALC.           CNI02930
C     ............FACT         12    FACTORIAL N....                    CNI02940
C     ............HARMTR       10    EULERIAN ANGLE ROTATION            CNI02950
C     ............SS           09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI02960
C     ...............AINTGS    14                                       CNI02970
C     ...............BINTGS    15                                       CNI02980
C     ...............Y         06                                       CNI02990
C     ...............Z         06    ENTRY IN Y FUNCTION ROUTINE        CNI03000
C     ..................FIND   08    LOCATOR OF Y AND Z ENTRIES         CNI03010
C     ............MATPRT       36    OUTPUT MATRIX TO LINE PRINTER      CNI03020
C     ............REPUL        42    COULOMB REPULSION INTEGRALS        CNI03030
C     ...............COULJE    43    EILERS COULOMB INTEGRALS           CNI03040
C     ..................FACT   12    FACTORIAL                          CNI03050
C     ...............SS        09    MULLIKEN-RIEKE-ORLOFF AUX.FCN.     CNI03060
C     ..................AINTGS 14                                       CNI03070
C     ..................BINTGS 15                                       CNI03080
C     ..................Y      06                                       CNI03090
C     ..................Z      06    ENTRY IN Y FUNCTION ROUTINE        CNI03100
C     .....................FIND07    LOCATOR OF Y AND Z ENTRIES         CNI03110
C     .........EIGN            22    GIVENS-HOUSEHOLDER DIAGONALIZATION CNI03220
C     ......SCFOUT             23    OUTPUT OF SCF MATRIX               CNI03130
C     ...OPRINT                21    OPEN-SHELL SCF LINE PRINTER OUTPUT CNI03440
C     ......SCFOUT             23    SCF LINE PRINTER OUTPUT            CNI03450
C     .........EIGOUT          24    EIGENVALUE OUTPUT                  CNI03460
C---------------------------------------------------------------------  CNI03470
C  ALPHABETIC INDEX                                                     CNI03950
C     NAME  (PAGE)   CALLED BY:    CALLS:                               CNI03970
C     -----------    ------------  -------------------------------------CNI03980
C     AINTGS(14)     SS    (09)    ---                                  CNI03990
C     ATDATA(37)     MAIN  (03)    ---                                  CNI04000
C     AXEQB (26)     EIG3  (27)    ---                                  CNI04010
C     BINOM (35)     COEFF (33),   FACT  (12)                           CNI04020
C                    COEFFS(34)                                         CNI04025
C     BINTGS(13)     SS    (09)    FACT  (12)                           CNI04030
C     BLOCK DATA(05) MAIN  (03)    ---                                  CNI04040
C     CFILES(30)     MAIN  (03)    ---                                  CNI04060
C     CINDEX(02)     (UNC)         ---                                  CNI04050
C     COEFF (33)     SSHASE(32)    BINOM (35)                           CNI04090
C     COEFFS(34)     SSHASE(32)    BINOM (35)                           CNI04100
C     COULJE(43)     REPUL (42)    FACT  (12)                           CNI04110
C     CPRINT(17)     MAIN  (03)    SCFOUT(23)                           CNI04120
C     CUNITS(31)     MAIN  (03)    ---                                  CNI04080
C     DETPUL(41)     SOLPUL(40)    ---                                  CNI04130
C     DIAGON(29)     DIPOLE(18)    EIG3  (27),WACOS (38)                CNI04140
C     DIPOLE(18)     MAIN  (03)    DIAGON(29),EIG3  (27),WACOS (38)     CNI04150
C     EIGN  (22)     HUCKCL(15),   ---                                  CNI04160
C                    HUCKOP(19),                                        CNI04162
C                    SCFCLO(16),                                        CNI04165
C                    SCFOPN(20),                                        CNI04170
C                    ON    (39)                                         CNI04180
C     EIG3  (27)     DIPOLE(18)    AXEQB (26)                           CNI04190
C     EIGOUT(24)     SCFOUT(23)    ---                                  CNI04200
C     FACT  (12)     BINOM (35),    ---                                 CNI04210
C                    BINTGS(13),                                        CNI04215
C                    COULJE(43),                                        CNI04220
C                    SS    (09),                                        CNI04225
C                    INTGRL(08)                                         CNI04230
C     FIND  (07)     Y     (06),   ---                                  CNI04240
C                    Z     (06)                                         CNI04145
C     HARMTR(10)     INTGRL(08)    ---                                  CNI04250
C     HUCKCL(15)     MAIN  (03)    EIGN  (22),SCFOUT(23)                CNI04260
C     HUCKOP(19)     MAIN  (03)    EIGN  (22),SCFOUT(23)                CNI04270
C     INSTRU(01)     (UNC)         ---                                  CNI04070
C     INTGRL(08)     MAIN  (03),   MATPRS(44),RELVEC(11),FACT  (12),    CNI04280
C                    ON    (39)    SS    (09),HARMTR(10),REPUL (42),    CNI04280
C                                  SCFOUT(23),MATPRT(36)                CNI04290
C     MAIN  (03)     ---           CFILES(30),CUNITS(31),READIN(04),    CNI04300
C                                  ATDATA(37),INTGRL(08),HUCKCL(15),    CNI04300
C                                  SCFCLO(16),CPRINT(17),ORLOC (28),    CNI04310
C                                  DIPOLE(18),HUCKOP(19),SCFOPN(20),    CNI04310
C                                  OPRINT(28)                           CNI04320
C     MATPRS(44)     INTGRL(08)    ---                                  CNI04330
C     MATPRT(36)     INTGRL(08)    ---                                  CNI04340
C     ON    (39)     SCFCLO(16),   INTGRL(08),EIGN  (22),SCFOUT(23)     CNI04350
C                    SCFOPN(20)                                         CNI04355
C     OPRINT(21)     MAIN  (03)    SCFOUT(23)                           CNI04360
C     ORLOC (28)     MAIN  (03)    ---                                  CNI04370
C     RANNUM(25)     SCFCLO(16),   ---                                  CNI04380
C                    SCFOPN(20)                                         CNI04385
C     READIN(04)     MAIN  (03)    ---                                  CNI04390
C     RELVEC(11)     INTGRL(08)    ---                                  CNI04400
C     REPUL (42)     INTGRL(08)    SS    (09),FACT  (12),COULJE(43)     CNI04410
C     SCFCLO(16)     MAIN  (03)    RANNUM(25),SOLPUL(40),SCFOUT(23),    CNI04420
C                                  EIGN  (22),ON    (39)                CNI04420
C     SCFOPN(20)     MAIN  (03)    RANNUM(25),SOLPUL(40),SCFOUT(23),    CNI04430
C                                  EIGN  (22),ON    (39)                CNI04430
C     SCFOUT(23)     SCFCLO(16),   EIGOUT(24)                           CNI04440
C                    SCFOPN(20)                                         CNI04445
C     SOLPUL(40)     SCFCLO(16),   DETPUL(41)                           CNI04450
C                    SCFOPN(20)                                         CNI04455
C     SS    (09)     INTGRL(08)    AINTGS(14),BINTGS(13),Y     (06),    CNI04460
C                                  Z     (06),FACT  (12)                CNI04460
C     SSHASE(32)     (UNC)         AINTGS(14),BINTGS(13),COEFFS(34),    CNI04470
C                                  COEFF (33),FACT  (12)                CNI04470
C     WACOS (38)     DIPOLE(18),   ---                                  CNI04480
C                    DIAGON(29)                                         CNI04485
C     Y     (06)     SS    (09)    FIND  (07)                           CNI04490
C     Z     (06)     SS    (09)    FIND  (07)                           CNI04500
C-----------------------------------------------------------------------CNI04510
      RETURN                                                            CNI04520
CE.02 END OF SUBROUTINE CINDEX (CNDOP)----------------------------------CNI04530
      END                                                               CNI04540
C-----MAIN PROGRAM                                                      CNI04550
CB.03 LAST CHANGE 16 NOV 2020 (CNDOP)-----------------------------------CNI04560
C     CALLS:     CFILES(30),CUNITS(31),READIN(04),ATDATA(37),INTGRL(08),CNI04300
C                HUCKCL(15),SCFCLO(16),CPRINT(17),ORLOC (28),DIPOLE(18),CNI04300
C                HUCKOP(19),SCFOPN(20),OPRINT(28)                       CNI04310
C-----MAIN PROGRAM: CNDO/2-FPPI AND INDO/FP-----------------------------CNI04600
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI04610
      REAL FILD                                                         CNI04620
      CHARACTER*4 ITITOL,CA,EL                                          CNI04625
      INTEGER OPTION,OPNCLO,CNDO,OPENS,LBL(3)                           CNI04620
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI04640
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI04650
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI04660
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI04670
      COMMON/INFOX/NATOMS,NCHARG,MULTIP,N,IC1(3),LIMG,IPREC             CNI04690
      COMMON/CHOICE/OPTION,OPNCLO,IC2(1),CNDO,IC3(2),OPENS              CNI04700
      COMMON/ORBITS/II1(9)                                              CNI04710
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/AUXINT/XX1(34)                                             CNI04730
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI04740
     1RKAPPA(35,6)                                                      CNI04750
C-----MAXIMUM DYNAMIC ARRAY STORAGE IS SET TO:                          CNI04790
C     IIII INTEGER  *4 WORDS: DIMENSION IA(IIII),                       CNI04800
C     IIII CHARACTER*4 WORDS: DIMENSION CA(IIII)                        CNI04805
C     AND THESE ARE EQUIVALENCED TO                                     CNI04810
C     JJJJ DOUBLE PRECISION WORDS: DIMENSION AA(JJJJ).                  CNI04820
C     THUS SET JJJJ=IIII/IPREC, AND SET NTOTAL=IIII.                    CNI04830
C     FOR IPREC, SEE SUBROUTINE CFILES                                  CNI04835
C     IF PROGRAM DOES NOT ACCOMODATE MOLECULE AT HAND,                  CNI04840
C-----RECOMPILE AT LEAST THE MAIN PROGRAM INCREASING IIII AND JJJJ------CNI04850
      DIMENSION AA(400000)                                              CNI04870
      DIMENSION IA(800000)                                              CNI04860
      DIMENSION CA(800000)                                              CNI04870
      EQUIVALENCE (IA(1),AA(1)),(CA(1),AA(1))                           CNI04880
      DATA LBL/4H X  ,4H Y  ,4H Z  /                                    CNI04890
      NTOTAL=800000                                                     CNI04900
C-----IN THIS VERSION NTOTAL IS SET EQUAL TO 50000 SINGLE-PRECISION     CNI04910
C     OR INTEGER (IBM 360 AND 370: -BYTE) WORDS.                        CNI04920
C *** SET UP FORTRAN LOGICAL NUMBERS, INTEGER WORD LENGTH,UNDERFLOW TRAPCNI04930
      CALL CFILES                                                       CNI04950
C *** SET UP FUNDAMENTAL CONSTANTS--------------------------------------CNI04960
      CALL CUNITS                                                       CNI04970
C-----TO TEST CNDO/ON PROCEDURE OF ROALD HOFFMAN, AS QUOTED IN----------CNI04980
C     J.F. JAN, F.A.MOMANY, R.HOFFMANN, AND H.A.SCHERAGA,               CNI04990
C     J.PHYS.CHEM.74,420(1970) YOU MUST SET IHOFMN=1                    CNI05000
C     OTHERWISE STANDARD CNDO/2 AND INDO (POPLE-STYLE)                  CNI05010
C-----ORBITAL POPULATION ANALYSIS IS DONE ------------------------------CNI05020
      IHOFMN=0                                                          CNI05030
C01---READ IN DATA CARD TYPE 1: TITLE CARD (20A4)                       CNI05040
   01 READ  (LINPUT,02) (ITITOL(I),I=1,20)                              CNI05050
   02 FORMAT (20A4)                                                     CNI05060
      WRITE (LOUTPT,03) (ITITOL(I),I=1,20)                              CNI05070
   03 FORMAT ('1',20A4)                                                 CNI05080
C02---READ IN DATA CARD TYPE 2: FIRST CONTROL CARD----------------------CNI05090
      READ (LINPUT,04) OPTION,OPNCLO,IPIECE,IPLFCN,BONDMX,IBRIEF,       CNI05100
     1SHIFTR,IRN,IDM,IPUL                                               CNI05110
   04 FORMAT (A4,1X,A4,7X,I2,7X,I1,7X,F4.0,7X,I1,7X,F4.0,4X,I1,         CNI05120
     14X,I1,5X,I1)                                                      CNI05130
      WRITE (LOUTPT,05) OPTION,OPNCLO                                   CNI05140
   05 FORMAT (/' ',5X,A4,1X,A4)                                         CNI05150
      INODEE=0                                                          CNI05160
      IFIELD=0                                                          CNI05170
      ICONVR=0                                                          CNI05180
      INUPAR=0                                                          CNI05190
      ISHORT=0                                                          CNI05200
      ISHIFT=0                                                          CNI05210
      IF (DABS(SHIFTR).GT.0.1D-05) ISHIFT=1                             CNI05220
      IF (DABS(BONDMX).LE.0.0001D0) BONDMX=1.60D0                       CNI05230
C03---READ IN DATA CARD TYPE 3: SIZE,EL.FIELD  CARD---------------------CNI05240
      READ (LINPUT,06) NATOMS,NCHARG,MULTIP,INODEE,INUPAR,ICONVR,       CNI05250
     1NLOCIT,IPOLAR,FILD                                                CNI05260
   06 FORMAT (3I4,2(7X,I1),7X,I3,7X,I4,7X,I1,7X,F8.0)                   CNI05270
      WRITE (LOUTPT,07) NATOMS,NCHARG,MULTIP                            CNI05280
   07 FORMAT (/5X,I4,' ATOMS   CHARGE  =',I4,'  MULTIPLICITY  =',I4/)   CNI05290
      IF (IPLFCN.EQ.1) INODEE=0                                         CNI05300
C-----THE SIZE VARIABLES FOR THE DYNAMIC ARRAYS ARE NATOMS AND N.-------CNI05310
C     IN ORDER TO GENERATE N FROM NATOMS IN SUBROUTINE READIN, THE      CNI05320
C     ADDRESSES FOR THE FIRST FIVE DYNAMIC ARRAYS MUST BE ASSIGNED.     CNI05330
C     ADDRESSES BEGINNING WITH II ARE FOR INTEGER ARRAY IA,             CNI05340
C     AND THOSE BEGINNING WITH IR ARE FOR REAL*8  ARRAY AA.             CNI05350
C-----FIRST OF THREE PARTS OF DYNAMIC ADDRESSES BEGINS------------------CNI05360
      II01=1                                                            CNI05370
C-----II01    IATNO(NATOMS): ATOMIC NUMBER OF ATOM                      CNI05380
      IR04=(II01+NATOMS)/IPREC+1                                        CNI05390
C-----IR04    C(NATOMS,3): CARTESIAN COORDINATES OF ATOM                CNI05400
      II02=(IR04+NATOMS*3-1)*IPREC+1                                    CNI05410
C-----II02    ICORE(NATOMS): CORE CHARGE= NUCLEUS-CORE ELECTRONS        CNI05420
      II04=II02+NATOMS                                                  CNI05430
C-----II04    LIMU(NATOMS): LIMU(I)=HIGHEST A.O. FOR ATOM I             CNI05440
      II05=II04+NATOMS                                                  CNI05450
C-----II05    LIML(NATOMS): LIML(I)=LOWEST  A.O. FOR ATOM I             CNI05460
      IC01=II05+NATOMS                                                  CNI05470
C-----IC01    ITITLE(NATOMS): ALPHANUMERIC TITLE FOR ATOM..CA(IC01)     CNI05480
      II07=IC01+NATOMS                                                  CNI05490
C-----II07    IBOND(NATOMS)                                             CNI05500
      II08=II07+NATOMS                                                  CNI05510
C-----II08    ISYMOP(NATOMS) CELMAP SPACE GROUP SYMM. OPR.              CNI05520
      II09=II08+NATOMS                                                  CNI05530
C-----II09    IGOOP(NATOMS)                                             CNI05540
C-----FIRST OF THREE PARTS OF DYNAMIC ADDRESSES ENDS--------------------CNI05360
      LIMG=2*NATOMS                                                     CNI05550
C *** READ IN CONTROL CARDS AND DEFINE SIZE OF JOB                      CNI05560
      CALL READIN      (AA(IR04),IA(II01),IA(II02),IA(II04),IA(II05),   CNI05565
     1IA(II08),IA(II09),CA(IC01))                                       CNI05570
      FIELD=FILD                                                        CNI05580
      AFIELD=FIELD/BOHR**2                                              CNI05590
C-----CONVERT INPUT ELECTRIC FIELD FROM ELECTRONS/ANGSTROMS**2----------CNI05600
C-----TO ELECTRONS/BOHRS**2 (ATOMIC UNITS)------------------------------CNI05610
      IF (IPOLAR.EQ.1) WRITE (LOUTPT,08) FIELD,AFIELD                   CNI05630
   08 FORMAT (/'0STATIC ELECTRIC DIPOLE POLARIZABILITY ',               CNI05640
     2' WILL BE CALCULATED.'/                                           CNI05650
     3' FIELD INTENSITY=',D17.6,' ELECTRONS/ANGSTROMS**2'/              CNI05660
     4' FIELD INTENSITY=',D17.6,' ATOMIC UNITS (ELECTRONS/BOHR**2)')    CNI05670
      IF (IPOLAR.GT.0.AND.FIELD.EQ.0.D0) GO TO 999                      CNI05680
      IF (IPOLAR.EQ.2) FIELD =0.01D0*BOHR**2                            CNI05690
      IF (IPOLAR.EQ.2) AFIELD=0.01D0                                    CNI05700
      IF (IPOLAR.EQ.2) WRITE (LOUTPT,9)                                 CNI05710
    9 FORMAT (/' HYPERPOLARIZABILITY TENSOR CALCULATION')               CNI05720
      IF (IPOLAR.EQ.2) WRITE (LOUTPT,08) AFIELD,FIELD                   CNI05730
      IF (IPOLAR.EQ.2) ITURNO=1                                         CNI05740
      WRITE (LOUTPT,10) BONDMX                                          CNI05750
   10 FORMAT (/' THE MAXIMUM ACCEPTABLE COVALENT BOND DISTANCE IS ',    CNI05760
     1D15.7,' ANGSTROMS')                                               CNI05770
      IF (ISHIFT.EQ.1) WRITE (LOUTPT,11) SHIFTR                         CNI05780
   11 FORMAT (/' TO FACILITATE CONVERGENCE, THE VIRTUAL ENERGIES WILL', CNI05790
     1' BE SHIFTED BY '/' ',D15.5,' HARTREES UPWARDS DURING SCF CYCLES')CNI05800
      IF (IDM.EQ.1) WRITE (LOUTPT,121)                                  CNI05810
  121 FORMAT (/' DENSITY MATRIX WILL BE AVERAGED BETWEEN SCF CYCLES')   CNI05820
      IF (IRN.EQ.1) WRITE (LOUTPT,122)                                  CNI05830
  122 FORMAT (' FOCK MATRIX WILL BE TICKLED BY RANDOM NUMBERS')         CNI05840
C-----SAFETY REWINDS TO REMIND USER TO INITIALIZE LAUXOU & LPIECE       CNI05850
      IF (IPOLAR.GE.1) REWIND LAUXOU                                    CNI05870
      IF (IPIECE.GT.0) REWIND LPIECE                                    CNI05880
      IF (IPOLAR.EQ.2) REWIND LPIECE                                    CNI05890
      IF (IPOLAR.GE.1) WRITE (LAUXOU,03) (ITITOL(I),I=1,20)             CNI05900
      IF (INUPAR.EQ.5) INODEE=1                                         CNI05910
      IF (INODEE.EQ.1) WRITE (LOUTPT,12)                                CNI05920
   12 FORMAT (/' THE D ORBITALS WILL BE IGNORED.')                      CNI05930
      IF (INUPAR.EQ.1) WRITE (LOUTPT,13)                                CNI05940
   13 FORMAT (/' THE CNDO/2 PARAMETRIZATION OF SANTRY,SABIN,AND',       CNI05950
     1' WEISS J.AM.CHEM.SOC.94,6651(1972);IBID.90,3309(1968))'/         CNI05960
     2' WILL BE USED FOR NA,MG,AL,SI,P,S,CL')                           CNI05970
      IF (INUPAR.EQ.2) WRITE (LOUTPT,14)                                CNI05980
   14 FORMAT (/' THE CNDO-S NON-CI PARAMETRIZATION OF DEL BENE, JAFFE', CNI05990
     1' MIYAZAKI AND SHINODA'/' J.CHEM.PHYS. 48,1807,4058(1968),',      CNI06000
     2' BULL.CHEM.SOC.JAPAN 46,1216(1973) WILL BE USED '/               CNI06010
     3' FOR POLARIZABILITY CALCULATIONS ')                              CNI06020
      IF (INUPAR.EQ.3) WRITE (LOUTPT,15)                                CNI06030
   15 FORMAT (/' THE CNDO/S NON-CI PARAMETRIZATION OF DEL BENE AND ',   CNI06040
     1'JAFFE'/' J.CHEM.PHYS. 48,1807,4058(1968) WILL BE USED')          CNI06050
      IF (INUPAR.EQ.4) WRITE (LOUTPT,16)                                CNI06060
   16 FORMAT (/' THE INDO/S NON-CI PARAMETRIZATION OF KROGH-JESPERSEN', CNI06070
     1' AND RATNER, J.CHEM.PHYS. 65,1305(1976)'/' AND THEOR.CHIM.ACTA', CNI06080
     2', 47,283(1978) WILL BE USED.')                                   CNI06090
      IF (INUPAR.EQ.5) WRITE (LOUTPT,17)                                CNI06100
   17 FORMAT (' THE INDO PARAMETRIZATION'/' OF GORDON, BJORKE,',        CNI06110
     1' MARSH, AND KORTH, J.AM.CHEM.SOC.100,2670(1978)'/                CNI06120
     2' WILL BE USED FOR NA,MG,AL,SI,P,S,CL'/                           CNI06130
     3' THE D ORBITALS MUST BE IGNORED.')                               CNI06140
      IF (IPOLAR.EQ.0) NCYCLE=125                                       CNI06150
      IF (IPOLAR.GE.1) NCYCLE=600                                       CNI06160
      IF (ICONVR.EQ.0.AND.IPOLAR.EQ.0) CONVRG=1.D-06                    CNI06170
      IF (ICONVR.EQ.0.AND.IPOLAR.GT.0) CONVRG=1.D-14                    CNI06180
      IF (ICONVR.GT.0) CONVRG=10.D0**(-ICONVR)                          CNI06190
      RHO=0.1D-01*CONVRG                                                CNI06200
      IF (IPOLAR.EQ.0) WRITE (LOUTPT,18) NCYCLE,CONVRG                  CNI06210
   18 FORMAT (/' NORMAL RUN: AT MOST  ',I5,' SCF CONVERGENCE CYCLES ',  CNI06220
     1' ARE ALLOWED.'//'  ENERGY CONVERGENCE TO ',D20.6,' A.U.')        CNI06230
      IF (IPOLAR.EQ.1) WRITE (LOUTPT,19) NCYCLE,CONVRG                  CNI06240
   19 FORMAT (/' AT MOST ',I5,' SCF CONVERGENCE CYCLES',                CNI06250
     1' ARE ALLOWED.'//' DENSITY MATRIX CONVERGENCE TO',D20.6)          CNI06260
      IF (ISHORT.EQ.1.AND.IPOLAR.EQ.1) WRITE (LOUTPT,20)                CNI06270
   20 FORMAT (/' SHORTENED RECYCLES WILL BE USED')                      CNI06280
C-----SECOND OF THREE PARTS OF THE ADDRESSES FOR DYNAMIC ARRAYS BEGINS--CNI06290
      II03=II09+NATOMS                                                  CNI06300
C-----II03    IOR2AT(N)                                                 CNI06310
      II10=II03+N                                                       CNI06320
C-----II10    IGAM  (N): INTGRL,HUCKCL,SCFCLO,CPRINT,HUCKOP,SCFOPN,     CNI06330
C                        OPRINT                                         CNI06340
      II06=II10+N                                                       CNI06341
C-----II06    IPOSV (N): HUCKCL,SCFCLO,HUCKOP,ON,EIGN                   CNI06342
      II11=II06+N                                                       CNI06343
C-----II11    IVPOS (N): HUCKCL,SCFCLO,HUCKOP,ON,EIGN                   CNI06344
      II12=II11+N                                                       CNI06345
C-----II12    IORD  (N) : HUCKCL,SCFCLO,HUCKOP,ON,EIGN                  CNI06346
      II13=II12+N                                                       CNI06347
C-----II13    ITABLE(NATOMS,NATOMS) : DIPOLE                            CNI06348
      II14=II13+NATOMS*NATOMS                                           CNI06349
C-----II14    IRD(NATOMS*NATOMS) :    DIPOLE                            CNI06350
      IR05=(II14+NATOMS*NATOMS)/IPREC+1                                 CNI06351
C-----IR05    XXX(NATOMS):INTRGL,CPRINT,DIPOLE,OPRINT                   CNI06352
      IR06=IR05+NATOMS                                                  CNI06353
C-----IR06    XXX   (N):SCFCLO,GAMMA(N):EIGN                            CNI06360
      IR07=IR06+N                                                       CNI06370
C-----IR07    XX6   (N):SCFCLO, BETA(N)                                 CNI06380
      IR08=IR07+N                                                       CNI06390
C-----IR08    XX7   (N):HUCKCL,SCFCLO,HUCKOP,SCFOPN,                    CNI06400
      IR09=IR08+N                                                       CNI06410
C-----IR09    EIGVAL(N):HUCKCL,SCFCLO,HUCKOP,ON,EIGN                    CNI06420
      IR10=IR09+N                                                       CNI06430
C-----IR10    XX9   (N):HUCKCL,SCFCLO,HUCKOP,SCFOPN,EIGN                CNI06440
      IR11=IR10+N                                                       CNI06450
C-----IR11    GAMMA (LIMG,LIMG), G(LIMG,LIMG):SCFCLO                    CNI06460
      IR12=IR11+4*NATOMS*NATOMS                                         CNI06470
C-----IR12    Q     (N):SCFCLO, FDIAG(N)                                CNI06480
      IR13=IR12+N                                                       CNI06490
C-----IR13    PDIAG (N)                                                 CNI06500
      IR01=IR13+N                                                       CNI06510
C-----IR01    S     (N,N), A(N,N), A(N,N,3)                             CNI06520
      IR02=IR01+N*N                                                     CNI06530
C-----IR02    P     (N,N), B(N,N), VEC(N,N)                             CNI06540
      IR03=IR02+N*N                                                     CNI06550
C-----IR03    D     (N,N), Q(N,N), QQ(N,N)                              CNI06560
      IR14=IR03+N*N                                                     CNI06570
C-----IR14    BOLD  (N,N):SCFCLO                                        CNI06580
      IR15=IR14+N*N                                                     CNI06590
C-----IR15    ATLCHG(NATOMS,3)                                          CNI06600
      IR16=IR15+NATOMS*3                                                CNI06610
C-----IR16    ATLMUF(NATOMS,3,3):SCFCLO, ALPH2F(NATOMS,3,3)             CNI06620
      IR17=IR16+NATOMS*9                                                CNI06640
C-----IR17    ATLCHF(NATOMS,3):SCFCLO,ALPH20(NATOMS,3):                 CNI06650
      IR18=IR17+NATOMS*3                                                CNI06670
C-----IR18    M(NATOMS)                                                 CNI06680
      IR19=IR18+NATOMS                                                  CNI06690
C-----IR19    HYBSAV(NATOMS,3,3)                                        CNI06700
      IR24=IR19+NATOMS*9                                                CNI06705
C-----IR24    XXY   (N):HUCKCL,SCFCLO,HUCKOP,SCFOPN,EIGN,ON             CNI06710
      IR25=IR24+N                                                       CNI06720
C-----IR25    XXZ   (N):HUCKCL,SCFCLO,HUCKOP,SCFOPN,EIGN,ON             CNI06730
C-----SECOND OF THREE PARTS OF THE ADDRESSES FOR DYNAMIC ARRAYS ENDS----CNI06732
C     NPULAY=1: NO PULAY AVERAGING                                      CNI06734
C-----NPULAY=N: DO PULAY AVERAGING OF LAST N FOCK MATRICES--------------CNI06736
      NPULAY=1                                                          CNI06740
      IF (IPUL.EQ.1) NPULAY=N                                           CNI06750
      IF (NPULAY.GT.1) WRITE (LOUTPT,101) NPULAY                        CNI06760
  101 FORMAT (' DO PETER PULAYS DIRECT INVERSION IN THE ITERATIVE',     CNI06770
     1' SUBSPACE (DIIS) J.COMP.CHEM.3:556(1982)'/' NPULAY=',I5)         CNI06790
C-----THIRD OF THREE-PART ASSIGNMENT OF DYNAMIC ARRAYS BEGINS-----------CNI06800
      IR20=IR25+N                                                       CNI06810
C-----IR20    FOLD(NPULAY,NPULAY,5)                                     CNI06820
      IR21=IR20+NPULAY*NPULAY*5                                         CNI06830
C-----IR21    PULERR(NPULAY,NPULAY,5)                                   CNI06840
      IR22=IR21+NPULAY*NPULAY*5                                         CNI06850
C-----IR22    FOLDB(NPULAY,5):SCFOPN                                    CNI06860
      IR23=IR22+NPULAY*5                                                CNI06870
C-----IR23    PULERB(NPULAY,5):SCFOPN                                   CNI06880
      II15=IR23+NPULAY*5                                                CNI06882
C-----II15    ITSDUN(NATOMS)  : DIPOLE                                  CNI06885
      II16=II15+NATOMS                                                  CNI06886
C     II16    ICLOSD(NATOMS)  : DIPOLE                                  CNI06887
C-----THIRD OF THREE PARTS OF DYNAMIC ARRAY ADDRESSES ENDS--------------CNI06890
      ITOTAL=(II16+NATOMS)*IPREC                                        CNI06900
      WRITE (LOUTPT,21) NTOTAL,ITOTAL                                   CNI06910
   21 FORMAT(/' MAXIMUM NUMBER OF FULL WORDS ALLOCATED TO DYNAMIC',     CNI06920
     1' STORAGE: ',I9/                                                  CNI06930
     2' NUMBER OF FULL WORDS PRESENTLY NEEDED  IN DYNAMIC STORAGE: ',I9)CNI06940
      IF (ITOTAL.GT.NTOTAL) GO TO 901                                   CNI06960
C *** SET ATOMIC INTEGRAL DATA AND CNDO/INDO PARAMETERS-----------------CNI06970
      CALL ATDATA                                                       CNI06980
C-----FINITE-FIELD PERTURBATION CALCULATION OF ELECTRIC DIPOLE          CNI06990
C     POLARIZABILITY: FIRST, DO RUN IN ZERO FIELD (IFIELD=0);           CNI07000
C     THEN APPLY FIELD IN POSITIVE X-DIRECTION (IFIELD=1),              CNI07010
C     THEN IN POSITIVE Y-DIRECTION (IFIELD=2), THEN IN POSITIVE         CNI07020
C-----Z-DIRECTION (IFIELD=3)                                            CNI07030
      IF (IPOLAR.EQ.1) IFIELD=0                                         CNI07040
      IF (IPOLAR.EQ.1.AND.IPIECE.GT.0) IFIELD=IPIECE-10                 CNI07050
   22 IF (IPOLAR.EQ.2) ITURNO=ITURNO+1                                  CNI07060
      IF (IPOLAR.EQ.2) IFIELD=MOD(ITURNO-1,3)+1                         CNI07070
      IF (IPOLAR.EQ.2.AND.ITURNO.EQ.4) FIELD=-FIELD                     CNI07080
      IF (IPOLAR.EQ.2.AND.ITURNO.EQ.8) FIELD=0.000001*BOHR**2           CNI07090
      IF (IFIELD.GE.1) WRITE (LOUTPT,23) FIELD,LBL(IFIELD)              CNI07100
   23 FORMAT (' ',70('=')/' PARTIAL RUN. FIELD',D15.5,' A.U. ALONG',    CNI07105
     1A4,'DIRECTION')                                                   CNI07110
C *** COMPUTE 2-CENTER INTEGRALS                                        CNI07120
      CALL INTGRL      (AA(IR01),AA(IR04),AA(IR05),AA(IR09),AA(IR11),   CNI07130
     1AA(IR16),AA(IR17),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),   CNI07135
     2IA(II10))                                                         CNI07140
C-----RESET IHOFMN=1 TO IHOFMN=2 NOW THAT INTGRL IS DONE...             CNI07150
      IF (IHOFMN.EQ.1) IHOFMN=2                                         CNI07160
      IF (OPNCLO.EQ.OPENS) GO TO 25                                     CNI07170
C *** CLOSED-SHELL CALCULATIONS - HUECKEL INITIATION--------------------CNI07180
   24 CALL HUCKCL      (AA(IR01),AA(IR02),AA(IR06),AA(IR07),AA(IR08),   CNI07200
     1AA(IR09),AA(IR10),AA(IR11),AA(IR12),AA(IR04),AA(IR24),AA(IR25),   CNI07202
     2IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),IA(II10),IA(II06),   CNI07205
     3IA(II11),IA(II12))                                                CNI07210
C *** CLOSED-SHELL SELF-CONSISTENT FIELD CYCLES-------------------------CNI07220
      CALL SCFCLO      (AA(IR01),AA(IR02),AA(IR03),AA(IR04),AA(IR06),   CNI07230
     1AA(IR07),AA(IR08),AA(IR09),AA(IR10),AA(IR11),AA(IR12),AA(IR14),   CNI07240
     2AA(IR16),AA(IR17),AA(IR20),AA(IR21),AA(IR24),AA(IR25),IA(II01),   CNI07242
     2IA(II02),IA(II03),IA(II04),IA(II05),IA(II10),IA(II06),IA(II11),   CNI07245
     3IA(II12),ENERGY)                                                  CNI07250
C *** PRINT CLOSED-SHELL SCF MATRIX                                     CNI07260
      CALL CPRINT      (AA(IR01),AA(IR02),AA(IR04),AA(IR05),AA(IR09),   CNI07270
     1IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),CA(IC01),ENERGY)     CNI07280
C *** DO LOCALIZED MO TRANSFORMATION                                    CNI07290
      IF (NLOCIT.GT.0) CALL ORLOC        (AA(IR01),AA(IR02),AA(IR03),   CNI07300
     1AA(IR11),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05))            CNI07310
C *** COMPUTE DIPOLE MOMENTS AND POLARIZABILITIES-----------------------CNI07320
      CALL DIPOLE      (AA(IR01),AA(IR02),AA(IR03),AA(IR04),AA(IR05),   CNI07330
     1AA(IR09),AA(IR13),AA(IR15),AA(IR16),AA(IR17),AA(IR18),AA(IR19),   CNI07335
     2IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),IA(II07),IA(II08),   CNI07340
     3CA(IC01),IA(II09),IA(II10),IA(II13),IA(II14),IA(II15),IA(II16),   CNI07345
     4ENERGY)                                                           CNI07350
      IF (IPIECE.GT.0) GO TO 26                                         CNI07360
      IF (IPOLAR.EQ.1) IFIELD=IFIELD+1                                  CNI07370
      IF (IPOLAR.EQ.1.AND.IFIELD.LT.4.AND.ISHORT.EQ.1) GO TO 24         CNI07380
      IF (IPOLAR.EQ.1.AND.IFIELD.LT.4.AND.ISHORT.EQ.0) GO TO 22         CNI07390
      IF (IPOLAR.EQ.2.AND.ITURNO.LE.9) GO TO 22                         CNI07400
      GO TO 26                                                          CNI07410
C *** OPEN-SHELL CALCULATIONS - HUECKEL INITIATION----------------------CNI07420
   25 CALL HUCKOP      (AA(IR01),AA(IR02),AA(IR03),AA(IR06),AA(IR07),   CNI07440
     1AA(IR08),AA(IR09),AA(IR10),AA(IR11),AA(IR13),AA(IR04),AA(IR24),   CNI07442
     2AA(IR25),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),IA(II10),   CNI07445
     2IA(II06),IA(II11),IA(II12))                                       CNI07450
C *** OPEN-SHELL SELF-CONSISTENT FIELD CYCLES---------------------------CNI07460
      CALL SCFOPN      (AA(IR01),AA(IR02),AA(IR03),AA(IR04),AA(IR06),   CNI07470
     1AA(IR07),AA(IR08),AA(IR09),AA(IR10),AA(IR11),AA(IR12),AA(IR13),   CNI07480
     2AA(IR14),AA(IR16),AA(IR17),AA(IR20),AA(IR21),AA(IR22),AA(IR23),   CNI07490
     3AA(IR24),AA(IR25),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),   CNI07495
     4IA(II10),IA(II06),IA(II11),IA(II12),CA(IC01),ENERGY)              CNI07500
C *** PRINT OPEN-SHELL SCF MATRICES-------------------------------------CNI07510
      CALL OPRINT      (AA(IR01),AA(IR02),AA(IR04),AA(IR05),AA(IR09),   CNI07520
     1AA(IR13),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),CA(IC01),   CNI07525
     2ENERGY)                                                           CNI07530
C *** DO LOCALIZED MO TRANSFORMATION                                    CNI07540
      IF (NLOCIT.GT.0)        CALL ORLOC (AA(IR01),AA(IR02),AA(IR03),   CNI07550
     1AA(IR11),IA(II01),IA(II02),IA(II03),IA(II04),IA(II05))            CNI07560
C *** COIMPUTE DIPOLE MOMENTS AND POLARIZABILITIES                      CNI07570
      CALL DIPOLE      (AA(IR01),AA(IR02),AA(IR03),AA(IR04),AA(IR05),   CNI07580
     1AA(IR09),AA(IR13),AA(IR15),AA(IR16),AA(IR17),AA(IR18),AA(IR19),   CNI07585
     2IA(II01),IA(II02),IA(II03),IA(II04),IA(II05),IA(II07),IA(II08),   CNI07590
     3CA(IC01),IA(II09),IA(II10),IA(II13),IA(II14),IA(II15),IA(II16),   CNI07595
     4ENERGY)                                                           CNI07600
C-----GET SET TO LOOP BACK IF IFIELD.GT.0-------------------------------CNI07605
      IF (IPIECE.GT.0) GO TO 26                                         CNI07610
      IF (IPOLAR.EQ.1) IFIELD=IFIELD+1                                  CNI07620
      IF (IPOLAR.EQ.1.AND.IFIELD.LT.4.AND.ISHORT.EQ.1) GO TO 25         CNI07630
      IF (IPOLAR.EQ.1.AND.IFIELD.LT.4.AND.ISHORT.EQ.0) GO TO 22         CNI07640
      IF (IPOLAR.EQ.2.AND.ITURNO.LT.9) GO TO 22                         CNI07650
   26 CONTINUE                                                          CNI07660
C08---READ DATA CARD TYPE 8: RETURN DA CAPO CARD.-----------------------CNI07670
      READ (LINPUT,27,ERR=999) IDACAP                                   CNI07680
   27 FORMAT (I1)                                                       CNI07690
      IF (IDACAP.EQ.1) GO TO 01                                         CNI07700
      GO TO 999                                                         CNI07710
C-----DIAGNOSTIC ERROR MESSAGES SECTION BEGINS--------------------------CNI07720
  901 WRITE (LOUTPT,902)                                                CNI07730
  902 FORMAT (////1X,' MAXIMUM STORAGE EXCEEDED. JOB ABORTED.')         CNI07740
  999 STOP                                                              CNI07750
      STOP                                                              CNI07760
CE.03 END-OF-MAIN-PROGRAM (CNDOP)---------------------------------------CNI07770
      END                                                               CNI07780
      SUBROUTINE READIN (C,IATNO,ICORE,LIMU,LIML,ISYMOP,IGOOP,ITITLE)   CNI07790
CB.04 LAST CHANGE 13 MAY 1985 (CNDOP)                                   CNI07800
C     CALLED BY: MAIN  (03)                                             CNI07810
C     CALLS    : NONE                                                   CNI07820
C-----READ IN ATOM COORDINATES                                          CNI07830
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI07840
      CHARACTER*4 ITITOL,ITITLE,EL                                      CNI07845
      INTEGER OPTION,OPNCLO,CNDO,OPENS,LBL(3)                           CNI07842
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI07850
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI07860
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI07870
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI07880
      COMMON/INFOX/NATOMS,NCHARG,MULTIP,N,NELECS,NOCCA,NOCCB,LIMG,IPREC CNI07900
      COMMON/CHOICE/OPTION,OPNCLO,II3,CNDO,II4(2),OPENS                 CNI07910
      COMMON/ORBITS/II1(9)                                              CNI04710
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/AUXINT/XX1(34)                                             CNI04730
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI07930
     1RKAPPA(35,6)                                                      CNI07940
      DIMENSION C(NATOMS,3),IATNO(NATOMS),ICORE(NATOMS),LIMU(NATOMS),   CNI07950
     1LIML(NATOMS),ISYMOP(NATOMS),IGOOP(NATOMS),ITITLE(NATOMS)          CNI07960
      DO 40 I=1,NATOMS                                                  CNI07980
C04------READ IN DATA CARDS TYPE 4: ATOMIC NUMBERS, ATOM COORDINATES.   CNI07990
         READ (LINPUT,10) IATNO(I),C(I,1),C(I,2),C(I,3),ITITLE(I),      CNI08000
     1   ISYMOP(I)                                                      CNI08010
   10    FORMAT (I4,3(3X,F12.7),2X,A4,I2)                               CNI08020
         WRITE(LOUTPT,20) I,IATNO(I),C(I,1),C(I,2),C(I,3),ITITLE(I),    CNI08030
     1   EL(IATNO(I)),ISYMOP(I)                                         CNI08040
   20    FORMAT (I3,I4,3(3X,F12.7),4X,A4,4X,A4,I10)                     CNI08050
C--------CONVERT COORDINATES FROM ANGSTROMS TO ATOMIC UNITS             CNI08060
         DO 30 J=1,3                                                    CNI08070
   30    C(I,J)=C(I,J)/BOHR                                             CNI08080
   40 CONTINUE                                                          CNI08090
      IF (OPTION.EQ.CNDO) GO TO 70                                      CNI08100
   50 DO 60 I=1,NATOMS                                                  CNI08110
         IF (IATNO(I).GT.9.AND.INUPAR.NE.5) GO TO 901                   CNI08120
   60 CONTINUE                                                          CNI08130
   70 DO 80 I=1,NATOMS                                                  CNI08140
         IF (IATNO(I).GT.35) GO TO 903                                  CNI08150
   80 CONTINUE                                                          CNI08160
      IF (IPOLAR.GE.1) WRITE (LOUTPT,90) BONDMX                         CNI08170
   90 FORMAT (/' THE MAXIMUM COVALENT BOND DISTANCE IS',D15.6,          CNI08180
     1' ANGSTROMS')                                                     CNI08190
      IF (IPLFCN.EQ.0) GO TO 170                                        CNI08200
      DO 160 II=1,35                                                    CNI08210
         DO 150 I=1,NATOMS                                              CNI08220
            IF (IATNO(I).NE.II) GO TO 150                               CNI08230
            GO TO 160                                                   CNI08240
  150    CONTINUE                                                       CNI08250
  160 CONTINUE                                                          CNI08260
C-----DETERMINE:--------------------------------------------------------CNI08270
C     N     =NUMBER OF ATOMIC ORBITALS (SIZE OF AO BASIS)               CNI08280
C     ICORE =CORE CHARGE                                                CNI08290
C     NELECS=NUMBER OF VALENCE ELECTRONS                                CNI08300
C     NOCCA =NUMBER OF PAIRS OF VALENCE ELECTRONS IN DOUBLY OCCUPIED MOSCNI08310
C            (CLOSED-SHELL CALCULATION)                                 CNI08320
C     NOCCA =NUMBER OF VALENCE ELECTRONS IN MOS WITH SPIN ALPHA (OPEN)  CNI08330
C-----NOCCB =NUMBER OF VALENCE ELECTRONS IN MOS WITH SPIN BETA  (OPEN)  CNI08340
  170 N=0                                                               CNI08350
      NELECS=0                                                          CNI08360
      IF (IPLFCN.EQ.1) WRITE (LOUTPT,171)                               CNI08362
  171 FORMAT (/' POLARIZATION FUNCTIONS WILL BE USED')                  CNI08365
      DO 230 I=1,NATOMS                                                 CNI08370
         LIML(I)=N+1                                                    CNI08380
         IF (IATNO(I).LT.18) GO TO 180                                  CNI08400
C--------THIRD ROW: GERMANIUM,ARSENIC,SELENIUM,BROMINE: 3S,3P,4D--------CNI08410
         N=N+9                                                          CNI08420
C--------THIRD ROW: INODEE=0: SKIP THE 4D WAVEFUNCTIONS: 3S, 3P ONLY----CNI08425
         IF (INODEE.EQ.1) N=N-5                                         CNI08430
         ICORE(I)=IATNO(I)-28                                           CNI08440
         GO TO 220                                                      CNI08450
  180    IF (IATNO(I).LT.11) GO TO 190                                  CNI08460
C--------SECOND ROW: NA,MG,AL,SI,P,S,CL: 2S, 2P,3D ---------------------CNI08470
         N=N+9                                                          CNI08490
C--------SECOND ROW: INODEE=1: IGNORE THE 3D ORBITALS: 2S, 2P ONLY------CNI08500
         IF (INODEE.EQ.1) N=N-5                                         CNI08510
         ICORE(I)=IATNO(I)-10                                           CNI08520
         GO TO 220                                                      CNI08530
  190    IF (IATNO(I).LT.3) GO TO 210                                   CNI08540
C--------FIRST ROW: LI,BE,B,C,N,O,F: 2S, 2P ----------------------------CNI08550
  200    N=N+4                                                          CNI08560
C--------FIRST ROW: ADD 3D POLARIZATION FUNCTIONS-----------------------CNI08565
         IF (IPLFCN.EQ.1) N=N+5                                         CNI08570
         ICORE(I)=IATNO(I)-2                                            CNI08580
         GO TO 220                                                      CNI08590
C--------ZEROTH ROW: H,HE: 1S ------------------------------------------CNI08600
  210    N=N+1                                                          CNI08610
         ICORE(I)=IATNO(I)                                              CNI08620
C--------ZEROTH ROW: ADD 2P FOR POLARIZATION FUNCTIONS------------------CNI08625
         IF (IPLFCN.EQ.1) N=N+3                                         CNI08630
  220    CONTINUE                                                       CNI08640
         LIMU(I)=N                                                      CNI08650
         NELECS=NELECS+ICORE(I)                                         CNI08660
  230 CONTINUE                                                          CNI08670
      NELECS=NELECS-NCHARG                                              CNI08680
      IF (OPNCLO.NE.OPENS.AND.NELECS.GT.1) NOCCA=NELECS/2               CNI08690
      IF (OPNCLO.NE.OPENS.AND.NELECS.EQ.1) NOCCA=1                      CNI08695
      IF (OPNCLO.NE.OPENS) NOCCB=0                                      CNI08700
      IF (OPNCLO.EQ.OPENS) NOCCA=(NELECS+MULTIP-1)/2                    CNI08710
      IF (OPNCLO.EQ.OPENS) NOCCB=(NELECS-MULTIP+1)/2                    CNI08720
      NHOMO=NOCCA+NOCCB                                                 CNI08730
      NLUMO=NHOMO+1                                                     CNI08740
      IF (OPNCLO.NE.OPENS.AND.MOD(NELECS,2).EQ.1) NLUMO=NHOMO           CNI08750
      IF (OPNCLO.EQ.OPENS) NHOMO=NOCCA                                  CNI08760
      IF (OPNCLO.EQ.OPENS) NLUMO=NOCCB+1                                CNI08770
      IF (OPNCLO.NE.OPENS) WRITE (LOUTPT,240) NELECS,N,NHOMO,NLUMO      CNI08780
  240 FORMAT (/' THERE ARE ',I5,' VALENCE ELECTRONS.'/                  CNI08790
     1' THERE ARE ',I5,' DOUBLE-OCCUPANCY MOLECULAR ORBITALS'/          CNI08800
     2' THE HOMO (HIGHEST OCCUPIED  MOLECULAR ORBITAL) IS NO.',I5/      CNI08810
     3' THE LUMO (LOWEST UNOCCUPIED MOLECULAR ORBITAL) IS NO.',I5)      CNI08820
      IF (OPNCLO.EQ.OPENS) WRITE (LOUTPT,250) NELECS,N,N,NHOMO,NLUMO    CNI08830
  250 FORMAT (/' THERE ARE ',I5,' VALENCE ELECTRONS.'/' THERE ARE ',I5, CNI08840
     1' SINGLE OCCUPANCY ALPHA AND ',I5,' BETA  MOLECULAR ORBITALS'/    CNI08850
     2' THE HOMO (HIGHEST OCCUPIED MOLECULAR ORBITAL) IS ALPHA NO.',I5/ CNI08860
     3' THE LUMO (LOWEST UNOCCUPIED MOLECULAR ORBITAL) IS BETA NO.',I5) CNI08870
      GO TO 999                                                         CNI08880
C-----DIAGNOSTIC ERROR MESSAGES SECTION BEGINS--------------------------CNI08890
  901 WRITE (LOUTPT,902)                                                CNI08900
  902 FORMAT (/5X,' THIS PROGRAM DOES NOT DO INDO CALCULATIONS',        CNI08910
     1' FOR MOLECULES CONTAINING ELEMENTS HIGHER THAN FLUORINE'/        CNI08920
     2' EXCEPT IF YOU USE INUPAR=5 (GORDON ET AL. PARAMETERS)')         CNI08930
      STOP                                                              CNI08940
  903 WRITE (LOUTPT,904)                                                CNI08950
  904 FORMAT (/5X,' SORRY. THIS PROGRAM DOES NOT DO CNDO',              CNI08960
     1' CALCULATIONS FOR ELEMENTS BEYOND THIRD ROW'/                    CNI08970
     2' EXCEPT FOR GE, AS, SE, AND BR.')                                CNI08980
      STOP                                                              CNI08990
C-----DIAGNOSTIC ERROR MESSAGES SECTION ENDS----------------------------CNI08890
  999 RETURN                                                            CNI09000
CE.04 END OF READIN (CNDOP)---------------------------------------------CNI09010
      END                                                               CNI09020
      BLOCK DATA                                                        CNI09030
CB.05 LAST CHANGE 03 APR 1985 (CNDOP)-----------------------------------CNI09040
      INTEGER CNDO,INDO,OPENS,CLOSED,ORB                                CNI09045
      CHARACTER*4 EL
      COMMON/CHOICE/II1(3),CNDO,INDO,CLOSED,OPENS                       CNI09050
      COMMON/ORBITS/ORB(9)                                              CNI09060
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      DATA CNDO/4HCNDO/                                                 CNI09090
      DATA INDO/4HINDO/                                                 CNI09100
      DATA OPENS/4HOPEN/                                                CNI09110
      DATA CLOSED/4HCLSD/                                               CNI09120
      DATA ORB/4H   S,4H  PX,4H  PY,4H  PZ,4H DZ2,4H DXZ,4H DYZ,4HDX-Y, CNI09130
     1  4H DXY/                                                         CNI09140
      DATA EL/4H   H,4H  HE,4H  LI,4H  BE,4H   B,4H   C,4H   N,4H   O,  CNI09150
     1 4H   F,4H  NE,4H  NA,4H  MG,4H  AL,4H  SI,4H   P,4H   S,4H  CL,  CNI09160
     2 4H  AR,4H   K,4H  CA,4H  SC,4H  TI,4H   V,4H  CR,4H  MN,4H  FE,  CNI09170
     3 4H  CO,4H  NI,4H  CU,4H  ZN,4H  GA,4H  GE,4H  AS,4H  SE,4H  BR/  CNI09180
CE.05 END-OF-BLOCK-DATA (CNDOP)---------------------------------------- CNI09190
      END                                                               CNI09200
      FUNCTION Y(I,J,K)                                                 CNI09210
CB.06 LAST CHANGE 03 APR 1985 (CNDOP)-----------------------------------CNI09220
C     CALLED BY: SS    (09)                                             CNI09230
C     CALLS    : FIND  (07)                                             CNI09240
C-----PART OF OVERLAP INTEGRAL ROUTINES, E.A.FISER, MIAMI UNIV.,OHIO----CNI09250
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI09260
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI09261
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI09262
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI09263
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI09264
      DIMENSION YNEW(734),ZNEW(207)                                     CNI09270
C-----SUBSCRIPT ARRAYS CORRESPONDING TO THE Y AN Z ARRAYS (LINEAR)------CNI09280
      DIMENSION IY(734),IZ(207)                                         CNI09290
C-----YNEW1 AND YNEW2 ARE USED ONLY TO INITIALIZE THE ENTIRE YNEW ARRAY CNI09300
C-----AND ALSO YNEW3,YNEW4,YNEW5,YNEW6,AND YNEW7 (F.M.WIYGUL)-----------CNI09310
      DIMENSION YNEW1(95),YNEW2(95),YNEW3(95),YNEW4(95),YNEW5(95),      CNI09320
     1YNEW6(95),YNEW7(74)                                               CNI09330
      EQUIVALENCE                                                       CNI09340
     1 (YNEW( 91),YNEW1(1)),(YNEW(186),YNEW2(1)),                       CNI09350
     2 (YNEW(281),YNEW3(1)),(YNEW(376),YNEW4(1)),                       CNI09360
     3 (YNEW(471),YNEW5(1)),(YNEW(566),YNEW6(1)),                       CNI09370
     4 (YNEW(661),YNEW7(1))                                             CNI09380
C-----IY1,IY2,IY3 INITIALIZE THE ENTIRE IY ARRAY (F.M.WIYGUL)-----------CNI09390
      DIMENSION IY1(228),IY2(228),IY3(62)                               CNI09400
      EQUIVALENCE (IY(217),IY1(1)),(IY(445),IY2(1)),(IY(673),IY3(1))    CNI09410
C-----SAME THING FOR ZNEW1 AND ZNEW2 (F.M.WIYGUL)-----------------------CNI09420
      DIMENSION ZNEW1(95),ZNEW2(22)                                     CNI09430
      EQUIVALENCE (ZNEW(91),ZNEW1(1)),(ZNEW(186),ZNEW2(1))              CNI09440
C-----SIZES OF THE Y AND Z ARRAYS---------------------------------------CNI09450
      DATA MY/734/,MZ/207/                                              CNI09460
C-----INITIALIZE IZ,ZNEW,IY,YNEW ARRAYS---------------------------------CNI09470
      DATA IZ/                                                          CNI09480
     1   35,  37,  39,  41,  43,  45,  47,  49,  69,  70,  71,  72,     CNI09490
     2   73,  74,  75,  76,  77,  78,  79,  80,  81,  82, 120, 121,     CNI09500
     3  122, 123, 124, 125, 127, 128, 129, 130, 131, 132, 137, 138,     CNI09510
     4  139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 154, 156,     CNI09520
     5  158, 160, 162, 164, 188, 189, 190, 191, 192, 193, 194, 195,     CNI09530
     6  196, 197, 198, 199, 222, 223, 224, 225, 226, 227, 228, 229,     CNI09570
     7  230, 231, 239, 241, 243, 245, 247, 273, 274, 275, 276, 277,     CNI09550
     8  279, 280, 281, 282, 283, 290, 291, 293, 294, 295, 296, 298,     CNI09560
     9  299, 307, 308, 309, 310, 312, 313, 314, 315, 324, 325, 326,     CNI09570
     A  327, 328, 329, 330, 331, 341, 343, 345, 347, 375, 376, 377,     CNI09580
     B  379, 380, 382, 383, 384, 409, 410, 411, 412, 413, 414, 415,     CNI09590
     C  416, 426, 427, 428, 429, 430, 431, 432, 443, 444, 445, 446,     CNI09600
     D  447, 448, 460, 462, 464, 494, 495, 496, 497, 499, 500, 501,     CNI09610
     E  502, 511, 512, 513, 514, 515, 516, 517, 518, 528, 529, 530,     CNI09620
     F  532, 533, 534, 545, 546, 547, 548, 549, 550, 562, 563, 565,     CNI09630
     G  566, 579, 580, 581, 582, 596, 598, 630, 631, 632, 633, 634,     CNI09640
     H  635, 636, 637, 664, 665, 666, 667, 668, 669, 698, 699, 700,     CNI09650
     I  701, 732, 733/                                                  CNI09660
C--Define ZNEW1 and ZNEW2 first: then Intel compiler finds non-0 data   CNI09662
      DATA ZNEW1/                                                       CNI09662
     1  -0.300D 01,  0.800D 01, -0.600D 01, -0.600D 01,  0.800D 01,     CNI09664
     2  -0.300D 01,  0.100D 01, -0.100D 01,  0.200D 01,  0.200D 01,     CNI09666
     3  -0.600D 01,  0.600D 01, -0.200D 01, -0.200D 01,  0.100D 01,     CNI09668
     4   0.100D 01, -0.100D 01, -0.300D 01,  0.300D 01,  0.300D 01,     CNI09670
     5  -0.300D 01, -0.100D 01,  0.100D 01, -0.100D 01,  0.300D 01,     CNI09672
     6  -0.300D 01,  0.100D 01, -0.100D 01,  0.500D 01, -0.800D 01,     CNI09674
     7   0.140D 02, -0.140D 02,  0.800D 01, -0.500D 01,  0.100D 01,     CNI09676
     8  -0.100D 01,  0.300D 01, -0.100D 01, -0.500D 01,  0.500D 01,     CNI09678
     9   0.100D 01, -0.300D 01,  0.100D 01,  0.100D 01, -0.200D 01,     CNI09680
     A  -0.100D 01,  0.400D 01, -0.100D 01, -0.200D 01,  0.100D 01,     CNI09682
     B  -0.100D 01,  0.100D 01,  0.200D 01, -0.200D 01, -0.100D 01,     CNI09684
     C   0.100D 01,  0.100D 01, -0.200D 01,  0.100D 01, -0.100D 01,     CNI09686
     D   0.600D 01, -0.140D 02,  0.140D 02, -0.140D 02,  0.140D 02,     CNI09688
     E  -0.600D 01,  0.100D 01,  0.100D 01, -0.500D 01,  0.900D 01,     CNI09690
     F  -0.500D 01, -0.500D 01,  0.900D 01, -0.500D 01,  0.100D 01,     CNI09692
     G  -0.100D 01,  0.400D 01, -0.500D 01,  0.500D 01, -0.400D 01,     CNI09694
     H   0.100D 01,  0.100D 01, -0.300D 01,  0.200D 01,  0.200D 01,     CNI09696
     I  -0.300D 01,  0.100D 01, -0.100D 01,  0.200D 01, -0.200D 01,     CNI09698
     J   0.100D 01,  0.100D 01, -0.100D 01, -0.100D 01,  0.100D 01/     CNI09700
      DATA ZNEW2/                                                       CNI09702
     1  -0.100D 01,  0.100D 01, -0.100D 01,  0.700D 01, -0.210D 02,     CNI09704
     2   0.350D 02, -0.350D 02,  0.210D 02, -0.700D 01,  0.100D 01,     CNI09706
     3  -0.100D 01,  0.500D 01, -0.100D 02,  0.100D 02, -0.500D 01,     CNI09708
     4   0.100D 01, -0.100D 01,  0.300D 01, -0.300D 01,  0.100D 01,     CNI09710
     5  -0.100D 01,  0.100D 01/                                         CNI09720
c-----define ZNEW1 and ZNEW2 first: then Intel compiler finds non-0 dataCNI09722
      DATA ZNEW/                                                        CNI09724
     1  -0.100D 01,  0.700D 01, -0.210D 02,  0.350D 02, -0.350D 02,     CNI09726
     2   0.210D 02, -0.700D 01,  0.100D 01, -0.100D 01,  0.100D 01,     CNI09690
     3   0.600D 01, -0.600D 01, -0.150D 02,  0.150D 02,  0.200D 02,     CNI09700
     4  -0.200D 02, -0.150D 02,  0.150D 02,  0.600D 01, -0.600D 01,     CNI09710
     5  -0.100D 01,  0.100D 01, -0.100D 01,  0.200D 01,  0.400D 01,     CNI09720
     6  -0.100D 02, -0.500D 01,  0.200D 02, -0.200D 02,  0.500D 01,     CNI09730
     7   0.100D 02, -0.400D 01, -0.200D 01,  0.100D 01,  0.100D 01,     CNI09740
     8  -0.100D 01, -0.500D 01,  0.500D 01,  0.100D 02, -0.100D 02,     CNI09750
     9  -0.100D 02,  0.100D 02,  0.500D 01, -0.500D 01, -0.100D 01,     CNI09760
     A   0.100D 01, -0.100D 01,  0.500D 01, -0.100D 02,  0.100D 02,     CNI09770
     B  -0.500D 01,  0.100D 01, -0.100D 01,  0.300D 01,  0.100D 01,     CNI09780
     C  -0.110D 02,  0.600D 01,  0.140D 02, -0.140D 02, -0.600D 01,     CNI09790
     D   0.110D 02, -0.100D 01, -0.300D 01,  0.100D 01, -0.100D 01,     CNI09800
     E   0.100D 01,  0.400D 01, -0.400D 01, -0.600D 01,  0.600D 01,     CNI09810
     F   0.400D 01, -0.400D 01, -0.100D 01,  0.100D 01,  0.100D 01,     CNI09820
     G  -0.400D 01,  0.600D 01, -0.400D 01,  0.100D 01, -0.100D 01,     CNI09830
     H   0.400D 01, -0.300D 01, -0.800D 01,  0.140D 02, -0.140D 02,     CNI09840
     I   0.800D 01,  0.300D 01, -0.400D 01,  0.100D 01,  0.100D 01,     CNI09850
     J 117*0.0D 00/                                                     CNI09860
c-----define IY1, IY2, IY3 first: then Intel compiler finds non-0 data--CNI09868
      DATA IY1/                                                         CNI09870
     1 2858,2863,2865,3018,3019,3021,3022,3025,3026,3027,3028,3029,     CNI09872
     2 3031,3034,3037,3038,3039,3044,3046,3063,3064,3065,3066,3070,     CNI09874
     3 3071,3074,3075,3079,3080,3081,3082,3154,3155,3156,3157,3161,     CNI09876
     4 3164,3165,3166,3169,3170,3171,3172,3178,3180,3198,3199,3200,     CNI09878
     5 3201,3205,3206,3209,3210,3214,3215,3216,3217,3243,3245,3250,     CNI09880
     6 3254,3259,3261,4145,4147,4149,4152,4154,4156,4158,4159,4161,     CNI09882
     7 4163,4165,4167,4168,4170,4172,4174,4177,4179,4181,4323,4324,     CNI09884
     8 4325,4326,4327,4328,4330,4331,4334,4335,4336,4337,4339,4340,     CNI09886
     9 4341,4342,4345,4346,4348,4349,4350,4351,4352,4353,4368,4370,     CNI09888
     A 4372,4375,4379,4381,4384,4386,4390,4393,4395,4397,4820,4821,     CNI09880
     B 4822,4823,4824,4827,4828,4829,4832,4833,4834,4835,4837,4838,     CNI
     C 4839,4840,4841,4843,4844,4845,4847,4848,4853,4855,4864,4865,     CNI
     D 4866,4867,4868,4871,4874,4875,4876,4877,4879,4880,4881,4882,     CNI
     E 4885,4888,4889,4890,4891,4892,4957,4964,4968,4971,4975,4978,     CNI
     F 4982,4989,5135,5136,5137,5138,5142,5143,5144,5145,5146,5147,     CNI
     G 5149,5150,5151,5152,5153,5154,5158,5159,5160,5161,5178,5179,     CNI
     H 5180,5181,5182,5185,5186,5187,5188,5189,5190,5191,5194,5195,     CNI
     I 5196,5197,5198,5199,5204,5206,5270,5271,5277,5278,5281,5282,     CNI
     J 5284,5285,5288,5289,5295,5296,5315,5322,5326,5329,5333,5340/     CNI
      DATA IY2/                                                         CNI
     1 5493,5494,5496,5497,5500,5501,5502,5503,5504,5506,5509,5512,     CNI
     2 5513,5514,5519,5521,5538,5539,5540,5541,5545,5546,5549,5550,     CNI
     3 5554,5555,5556,5557,5629,5630,5636,5640,5641,5644,5647,5655,     CNI
     4 5673,5674,5680,5681,5684,5685,5691,5692,5718,5725,5729,5736,     CNI
     5 6351,6352,6353,6354,6358,6359,6360,6361,6362,6363,6365,6366,     CNI
     6 6367,6368,6369,6370,6373,6374,6375,6376,6377,6382,6384,6395,     CNI
     7 6396,6397,6398,6402,6403,6404,6405,6406,6407,6409,6410,6411,     CNI
     8 6412,6413,6414,6418,6419,6420,6421,6487,6488,6489,6494,6495,     CNI
     9 6496,6497,6501,6502,6503,6504,6508,6509,6510,6511,6518,6531,     CNI
     A 6532,6533,6538,6539,6540,6541,6545,6546,6547,6548,6553,6554,     CNI
     B 6555,6575,6576,6577,6582,6583,6584,6585,6589,6590,6591,6592,     CNI
     C 6599,6845,6846,6847,6848,6852,6853,6854,6855,6856,6857,6859,     CNI
     D 6860,6861,6862,6863,6864,6868,6869,6870,6871,6889,6890,6891,     CNI
     E 6892,6896,6899,6900,6901,6904,6905,6906,6907,6913,6915,6982,     CNI
     F 6983,6989,6990,6996,6997,7003,7004,7025,7026,7027,7032,7033,     CNI
     G 7034,7035,7039,7040,7041,7042,7049,7069,7070,7071,7076,7079,     CNI
     H 7084,7085,7086,7385,7386,7387,7392,7393,7394,7396,7399,7400,     CNI
     I 7401,7403,7408,7410,7428,7429,7430,7431,7435,7436,7437,7438,     CNI
     J 7439,7440,7444,7445,7446,7447,7520,7521,7522,7527,7528,7529/     CNI
      DATA IY3/                                                         CNI
     1 7530,7534,7535,7536,7537,7544,7565,7566,7572,7573,7579,7580,     CNI
     2 7608,7609,7610,7615,7616,7617,7618,7625,7968,7969,7970,7971,     CNI
     3 7975,7976,7977,7978,7979,7980,7984,7985,7986,7987,8013,8014,     CNI
     4 8015,8020,8021,8024,8029,8031,8104,8105,8106,8111,8114,8119,     CNI
     5 8120,8121,8148,8149,8150,8155,8156,8157,8158,8165,8193,8194,     CNI
     6 8200,8201/                                                       CNI
c-----define IY1, IY2, IY3 first: then Intel compiler finds zon-0 data--
      DATA IY/                                                          CNI10130
     1  725, 727, 729, 732, 734, 736, 738, 739, 741, 743, 745, 747,     CNI10140
     2  748, 750, 752, 754, 757, 759, 761, 903, 904, 905, 906, 907,     CNI10150
     3  908, 910, 911, 914, 915, 916, 917, 919, 920, 921, 922, 925,     CNI10160
     4  926, 928, 929, 930, 931, 932, 933, 948, 950, 952, 955, 959,     CNI10170
     5  961, 964, 966, 970, 973, 975, 977,1670,1672,1677,1679,1683,     CNI10180
     6 1684,1686,1690,1692,1693,1697,1699,1704,1706,1848,1849,1850,     CNI10190
     7 1851,1855,1856,1861,1862,1864,1865,1870,1871,1875,1876,1877,     CNI10200
     8 1878,1893,1895,1900,1906,1909,1915,1920,1922,2345,2346,2347,     CNI10210
     9 2348,2349,2352,2353,2354,2357,2358,2359,2360,2362,2363,2364,     CNI10220
     A 2365,2366,2368,2369,2370,2372,2373,2378,2380,2389,2390,2391,     CNI10230
     B 2392,2393,2396,2399,2400,2401,2402,2404,2405,2406,2407,2410,     CNI10240
     C 2413,2414,2415,2416,2417,2482,2484,2489,2491,2493,2496,2500,     CNI10250
     D 2503,2505,2507,2512,2514,2660,2661,2662,2663,2667,2668,2669,     CNI10260
     E 2670,2671,2672,2674,2675,2676,2677,2678,2679,2683,2684,2685,     CNI10270
     F 2686,2703,2704,2705,2706,2707,2710,2711,2712,2713,2714,2715,     CNI10280
     G 2716,2719,2720,2721,2722,2723,2724,2729,2731,2795,2796,2797,     CNI10290
     H 2798,2802,2803,2804,2805,2806,2807,2809,2810,2811,2812,2813,     CNI10300
     I 2814,2818,2819,2820,2821,2840,2842,2847,2849,2851,2854,2856,     CNI10310
     J 518*0/                                                           CNI10320
c-----define YNEW1 to YNEW7 first: so Intel compiler finds zon-0 data---
      DATA YNEW1/                                                       CNI
     1   0.144D 03,  0.144D 03, -0.144D 03, -0.480D 02, -0.480D 02,     CNI
     2   0.960D 02,  0.480D 02, -0.480D 02,  0.960D 02,  0.960D 02,     CNI
     3  -0.144D 03, -0.960D 02,  0.480D 02, -0.480D 02, -0.480D 02,     CNI
     4  -0.144D 03,  0.144D 03,  0.144D 03, -0.960D 02,  0.480D 02,     CNI
     5   0.480D 02,  0.960D 02, -0.960D 02,  0.480D 02, -0.960D 02,     CNI
     6  -0.480D 02,  0.480D 02, -0.960D 02, -0.480D 02,  0.144D 03,     CNI
     7   0.480D 02, -0.480D 02,  0.960D 02,  0.144D 03, -0.144D 03,     CNI
     8  -0.144D 03,  0.480D 02,  0.480D 02, -0.144D 03, -0.144D 03,     CNI
     9   0.144D 03,  0.960D 02, -0.480D 02,  0.480D 02,  0.144D 03,     CNI
     A  -0.480D 02, -0.960D 02, -0.160D 02,  0.160D 02,  0.480D 02,     CNI
     B  -0.320D 02, -0.160D 02, -0.480D 02,  0.480D 02,  0.160D 02,     CNI
     C   0.320D 02, -0.480D 02, -0.160D 02,  0.160D 02, -0.480D 02,     CNI
     D   0.480D 02,  0.480D 02, -0.480D 02,  0.960D 02, -0.960D 02,     CNI
     E  -0.480D 02,  0.480D 02, -0.480D 02,  0.480D 02, -0.480D 02,     CNI
     F   0.480D 02, -0.480D 02,  0.480D 02,  0.960D 02, -0.960D 02,     CNI
     G   0.480D 02, -0.480D 02, -0.480D 02,  0.480D 02, -0.480D 02,     CNI
     H  -0.480D 02,  0.960D 02,  0.480D 02, -0.480D 02,  0.480D 02,     CNI
     I   0.480D 02, -0.480D 02,  0.480D 02, -0.480D 02, -0.960D 02,     CNI
     J   0.480D 02, -0.480D 02, -0.960D 02,  0.960D 02,  0.480D 02/     CNI
      DATA YNEW2/                                                       CNI
     1  -0.480D 02,  0.480D 02,  0.480D 02, -0.480D 02,  0.160D 02,     CNI
     2  -0.160D 02, -0.160D 02,  0.160D 02, -0.320D 02,  0.320D 02,     CNI
     3   0.160D 02, -0.160D 02,  0.160D 02, -0.160D 02,  0.160D 02,     CNI
     4  -0.160D 02,  0.160D 02, -0.160D 02, -0.320D 02,  0.320D 02,     CNI
     5  -0.160D 02,  0.160D 02,  0.160D 02, -0.160D 02, -0.160D 02,     CNI
     6   0.160D 02,  0.320D 02, -0.160D 02, -0.160D 02, -0.160D 02,     CNI
     7  -0.160D 02,  0.320D 02,  0.160D 02, -0.160D 02,  0.480D 02,     CNI
     8  -0.480D 02,  0.480D 02, -0.480D 02, -0.480D 02,  0.480D 02,     CNI
     9  -0.480D 02, -0.480D 02,  0.480D 02,  0.480D 02,  0.480D 02,     CNI
     A   0.480D 02, -0.480D 02, -0.480D 02, -0.480D 02,  0.480D 02,     CNI
     B  -0.480D 02,  0.480D 02,  0.480D 02, -0.480D 02,  0.480D 02,     CNI
     C  -0.480D 02, -0.480D 02,  0.480D 02, -0.480D 02,  0.480D 02,     CNI
     D   0.480D 02, -0.480D 02,  0.320D 02, -0.160D 02, -0.320D 02,     CNI
     E   0.160D 02, -0.320D 02,  0.160D 02,  0.320D 02, -0.160D 02,     CNI
     F   0.160D 02,  0.320D 02, -0.160D 02, -0.320D 02, -0.160D 02,     CNI
     G   0.160D 02,  0.160D 02, -0.160D 02, -0.160D 02,  0.160D 02,     CNI
     H  -0.160D 02,  0.160D 02,  0.160D 02, -0.160D 02,  0.160D 02,     CNI
     I  -0.160D 02, -0.160D 02,  0.160D 02, -0.160D 02,  0.160D 02,     CNI
     J   0.160D 02, -0.160D 02, -0.160D 02,  0.160D 02,  0.144D 03/     CNI
      DATA YNEW3/                                                       CNI
     1  -0.960D 02,  0.160D 02, -0.288D 03,  0.960D 02,  0.320D 02,     CNI
     2  -0.960D 02,  0.144D 03,  0.960D 02, -0.960D 02,  0.960D 02,     CNI
     3   0.144D 03, -0.960D 02,  0.320D 02,  0.960D 02, -0.288D 03,     CNI
     4   0.160D 02, -0.960D 02,  0.144D 03, -0.144D 03,  0.144D 03,     CNI
     5   0.960D 02, -0.960D 02, -0.160D 02,  0.160D 02,  0.144D 03,     CNI
     6  -0.144D 03, -0.480D 02,  0.480D 02,  0.960D 02, -0.960D 02,     CNI
     7  -0.960D 02,  0.960D 02,  0.480D 02, -0.480D 02, -0.144D 03,     CNI
     8   0.144D 03,  0.160D 02, -0.160D 02, -0.960D 02,  0.960D 02,     CNI
     9   0.144D 03, -0.144D 03,  0.144D 03, -0.960D 02,  0.160D 02,     CNI
     A  -0.144D 03,  0.480D 02, -0.960D 02,  0.960D 02, -0.480D 02,     CNI
     B   0.144D 03, -0.160D 02,  0.960D 02, -0.144D 03,  0.960D 02,     CNI
     C   0.960D 02, -0.640D 02, -0.320D 02, -0.320D 02, -0.192D 03,     CNI
     D  -0.192D 03,  0.960D 02, -0.640D 02,  0.960D 02,  0.960D 02,     CNI
     E   0.960D 02,  0.960D 02,  0.960D 02,  0.960D 02, -0.192D 03,     CNI
     F   0.960D 02, -0.320D 02, -0.640D 02, -0.640D 02,  0.960D 02,     CNI
     G  -0.192D 03, -0.320D 02,  0.960D 02,  0.192D 03,  0.960D 02,     CNI
     H  -0.960D 02, -0.320D 02, -0.320D 02, -0.192D 03, -0.960D 02,     CNI
     I  -0.960D 02, -0.960D 02,  0.960D 02, -0.960D 02,  0.960D 02,     CNI
     J   0.960D 02,  0.960D 02,  0.192D 03,  0.320D 02,  0.320D 02/     CNI
      DATA YNEW4/                                                       CNI
     1   0.960D 02, -0.960D 02, -0.192D 03,  0.640D 02, -0.192D 03,     CNI
     2  -0.640D 02,  0.192D 03,  0.192D 03, -0.640D 02, -0.192D 03,     CNI
     3   0.640D 02,  0.960D 02, -0.320D 02, -0.320D 02, -0.320D 02,     CNI
     4  -0.192D 03,  0.640D 02,  0.320D 02,  0.320D 02, -0.320D 02,     CNI
     5   0.960D 02,  0.960D 02, -0.320D 02,  0.320D 02,  0.320D 02,     CNI
     6   0.640D 02, -0.192D 03, -0.320D 02, -0.320D 02, -0.320D 02,     CNI
     7   0.960D 02,  0.960D 02,  0.960D 02, -0.640D 02, -0.320D 02,     CNI
     8  -0.320D 02, -0.960D 02, -0.960D 02,  0.320D 02, -0.320D 02,     CNI
     9  -0.320D 02, -0.640D 02,  0.960D 02,  0.320D 02,  0.640D 02,     CNI
     A   0.640D 02,  0.320D 02, -0.960D 02,  0.960D 02,  0.320D 02,     CNI
     B  -0.960D 02, -0.640D 02,  0.640D 02,  0.128D 03, -0.128D 03,     CNI
     C   0.640D 02, -0.640D 02, -0.640D 02,  0.640D 02, -0.128D 03,     CNI
     D   0.128D 03,  0.640D 02, -0.640D 02,  0.640D 02, -0.128D 03,     CNI
     E  -0.640D 02,  0.640D 02,  0.128D 03, -0.640D 02, -0.960D 02,     CNI
     F   0.960D 02, -0.320D 02, -0.320D 02,  0.960D 02, -0.960D 02,     CNI
     G   0.320D 02,  0.320D 02,  0.320D 02,  0.960D 02, -0.320D 02,     CNI
     H   0.320D 02, -0.960D 02, -0.960D 02, -0.320D 02,  0.960D 02,     CNI
     I   0.960D 02, -0.320D 02, -0.320D 02, -0.320D 02, -0.960D 02,     CNI
     J   0.320D 02, -0.320D 02,  0.960D 02,  0.320D 02,  0.320D 02/     CNI
      DATA YNEW5/                                                       CNI
     1   0.320D 02, -0.960D 02, -0.128D 03,  0.640D 02,  0.128D 03,     CNI
     2   0.128D 03, -0.640D 02, -0.640D 02, -0.128D 03,  0.640D 02,     CNI
     3  -0.640D 02,  0.640D 02,  0.640D 02, -0.640D 02,  0.640D 02,     CNI
     4  -0.640D 02, -0.640D 02,  0.640D 02,  0.640D 02, -0.640D 02,     CNI
     5  -0.640D 02,  0.640D 02,  0.192D 03,  0.960D 02, -0.192D 03,     CNI
     6  -0.320D 02, -0.384D 03, -0.960D 02,  0.192D 03, -0.256D 03,     CNI
     7   0.192D 03,  0.960D 02,  0.192D 03, -0.960D 02,  0.192D 03,     CNI
     8   0.576D 03, -0.384D 03, -0.960D 02,  0.960D 02, -0.192D 03,     CNI
     9  -0.256D 03,  0.192D 03, -0.960D 02, -0.320D 02,  0.960D 02,     CNI
     A   0.288D 03,  0.960D 02, -0.224D 03, -0.320D 02, -0.192D 03,     CNI
     B   0.192D 03, -0.288D 03, -0.480D 03,  0.288D 03,  0.960D 02,     CNI
     C  -0.960D 02, -0.288D 03,  0.480D 03,  0.288D 03, -0.192D 03,     CNI
     D   0.192D 03,  0.320D 02,  0.224D 03, -0.960D 02, -0.288D 03,     CNI
     E   0.640D 02,  0.640D 02, -0.640D 02, -0.192D 03, -0.192D 03,     CNI
     F   0.192D 03, -0.640D 02,  0.192D 03,  0.192D 03, -0.192D 03,     CNI
     G   0.192D 03, -0.640D 02, -0.640D 02,  0.640D 02, -0.192D 03,     CNI
     H   0.640D 02,  0.128D 03,  0.640D 02, -0.640D 02, -0.256D 03,     CNI
     I  -0.640D 02,  0.640D 02, -0.128D 03,  0.128D 03, -0.640D 02,     CNI
     J   0.640D 02,  0.256D 03,  0.640D 02, -0.640D 02, -0.128D 03/     CNI
      DATA YNEW6/                                                       CNI
     1   0.192D 03,  0.640D 02, -0.640D 02, -0.128D 03,  0.128D 03,     CNI
     2  -0.128D 03, -0.192D 03, -0.640D 02, -0.192D 03,  0.192D 03,     CNI
     3   0.128D 03,  0.640D 02,  0.960D 02,  0.960D 02, -0.160D 03,     CNI
     4  -0.320D 02, -0.192D 03, -0.192D 03,  0.288D 03, -0.960D 02,     CNI
     5   0.960D 02,  0.960D 02,  0.960D 02,  0.960D 02, -0.960D 02,     CNI
     6   0.288D 03, -0.192D 03, -0.192D 03, -0.320D 02, -0.160D 03,     CNI
     7   0.960D 02,  0.960D 02,  0.192D 03,  0.960D 02, -0.192D 03,     CNI
     8  -0.320D 02, -0.192D 03, -0.288D 03,  0.192D 03,  0.960D 02,     CNI
     9  -0.960D 02,  0.192D 03,  0.288D 03, -0.192D 03,  0.320D 02,     CNI
     A  -0.960D 02,  0.640D 02, -0.640D 02, -0.192D 03,  0.192D 03,     CNI
     B   0.192D 03, -0.192D 03, -0.640D 02,  0.640D 02,  0.640D 02,     CNI
     C   0.640D 02, -0.640D 02, -0.128D 03, -0.128D 03,  0.128D 03,     CNI
     D  -0.640D 02,  0.640D 02,  0.640D 02, -0.640D 02,  0.128D 03,     CNI
     E  -0.640D 02,  0.128D 03,  0.640D 02, -0.640D 02, -0.128D 03,     CNI
     F  -0.128D 03, -0.640D 02,  0.640D 02,  0.128D 03,  0.960D 02,     CNI
     G  -0.128D 03, -0.320D 02, -0.192D 03,  0.256D 03,  0.320D 02,     CNI
     H   0.960D 02,  0.960D 02, -0.128D 03,  0.320D 02, -0.192D 03,     CNI
     I  -0.320D 02,  0.960D 02,  0.960D 02,  0.960D 02, -0.160D 03,     CNI
     J  -0.320D 02, -0.960D 02, -0.960D 02,  0.128D 03, -0.128D 03/     CNI
      DATA YNEW7/                                                       CNI
     1   0.960D 02,  0.960D 02,  0.320D 02,  0.160D 03, -0.960D 02,     CNI
     2  -0.960D 02, -0.640D 02,  0.640D 02, -0.640D 02,  0.128D 03,     CNI
     3  -0.128D 03,  0.128D 03,  0.640D 02, -0.640D 02,  0.640D 02,     CNI
     4  -0.640D 02, -0.128D 03,  0.640D 02,  0.640D 02, -0.640D 02,     CNI
     5  -0.128D 03,  0.128D 03,  0.640D 02, -0.640D 02,  0.640D 02,     CNI
     6   0.640D 02, -0.640D 02, -0.640D 02, -0.640D 02,  0.640D 02,     CNI
     7  -0.640D 02,  0.640D 02, -0.960D 02,  0.960D 02, -0.960D 02,     CNI
     8  -0.320D 02,  0.960D 02, -0.960D 02,  0.128D 03,  0.128D 03,     CNI
     9  -0.960D 02,  0.960D 02, -0.320D 02, -0.960D 02,  0.960D 02,     CNI
     A  -0.960D 02,  0.960D 02, -0.128D 03, -0.320D 02, -0.960D 02,     CNI
     B   0.128D 03,  0.960D 02,  0.320D 02, -0.960D 02, -0.128D 03,     CNI
     C   0.640D 02, -0.640D 02,  0.128D 03,  0.128D 03, -0.640D 02,     CNI
     D   0.640D 02, -0.128D 03, -0.640D 02,  0.640D 02, -0.640D 02,     CNI
     E   0.640D 02, -0.640D 02,  0.640D 02,  0.640D 02, -0.640D 02,     CNI
     F   0.640D 02, -0.640D 02, -0.640D 02,  0.640D 02/                 CNI
c-----define YNEW1 to YNEW7 first: so compiler finds zon-0 data---
      DATA YNEW/                                                        CNI10800
     1   0.160D 02, -0.320D 02,  0.160D 02, -0.320D 02,  0.320D 02,     CNI10810
     2   0.320D 02, -0.320D 02,  0.160D 02,  0.320D 02, -0.960D 02,     CNI10820
     3   0.320D 02,  0.160D 02, -0.320D 02,  0.320D 02,  0.320D 02,     CNI10830
     4  -0.320D 02,  0.160D 02, -0.320D 02,  0.160D 02, -0.160D 02,     CNI10840
     5   0.160D 02,  0.320D 02, -0.320D 02, -0.160D 02,  0.160D 02,     CNI10850
     6   0.160D 02, -0.160D 02, -0.480D 02,  0.480D 02,  0.320D 02,     CNI10860
     7  -0.320D 02, -0.320D 02,  0.320D 02,  0.480D 02, -0.480D 02,     CNI10870
     8  -0.160D 02,  0.160D 02,  0.160D 02, -0.160D 02, -0.320D 02,     CNI10880
     9   0.320D 02,  0.160D 02, -0.160D 02,  0.160D 02, -0.320D 02,     CNI10890
     A   0.160D 02, -0.160D 02,  0.480D 02, -0.320D 02,  0.320D 02,     CNI10900
     B  -0.480D 02,  0.160D 02, -0.160D 02,  0.320D 02, -0.160D 02,     CNI10910
     C  -0.144D 03,  0.144D 03,  0.288D 03, -0.144D 03, -0.144D 03,     CNI10920
     D  -0.144D 03, -0.144D 03,  0.144D 03,  0.144D 03,  0.144D 03,     CNI10930
     E   0.144D 03, -0.288D 03, -0.144D 03,  0.144D 03,  0.144D 03,     CNI10940
     F  -0.144D 03, -0.144D 03,  0.144D 03, -0.144D 03,  0.144D 03,     CNI10950
     G   0.144D 03, -0.144D 03,  0.144D 03, -0.144D 03, -0.144D 03,     CNI10960
     H   0.144D 03, -0.144D 03,  0.144D 03,  0.144D 03, -0.144D 03,     CNI10970
     I  -0.144D 03,  0.144D 03,  0.144D 03, -0.144D 03, -0.144D 03,     CNI10980
     J644*0.0 D 00/                                                     CNI10990
C-----CHANGE TO LINEAR ELEMENT SUBSCRIPT REFERENCE FROM (9,5,203) FORM  CNI12360
      LIY=(K-1)*45+(J-1)*9 + I                                          CNI12370
C *** SEEK THIS SUBSCRIPT  IN THE LIST OF NON-ZERO ELEMENTS-------------CNI12380
      CALL FIND (IY,MY,LIY,M)                                           CNI12400
C-----IF M=0 ON RETURN FROM FIND, THEN LIY IS A ZERO ELEMENT------------CNI12410
      Y=0.0D0                                                           CNI12420
      IF (M.EQ.0) GO TO 999                                             CNI12430
      Y=YNEW(M)                                                         CNI12440
      GO TO 999                                                         CNI12450
      ENTRY Z(I,J)                                                      CNI12460
C-----GET LINEAR ELEMENT SUBSCRIPT FORM FOR Z---------------------------CNI12470
      LIZ=(J-1)*17+I                                                    CNI12480
C *** SAME LOGIC AS FOR THE Y VALUE-------------------------------------CNI12490
      CALL FIND (IZ,MZ,LIZ,M)                                           CNI12510
      Z=0.0D0                                                           CNI12520
      IF (M.EQ.0) GO TO 999                                             CNI12530
      IF (M.GT.207) GO TO 901                                           CNI12535
      Z=ZNEW(M)                                                         CNI12540
      GO TO 999                                                         CNI12545
  901 WRITE (LOUTPT,902) M                                              CNI12546
  902 FORMAT (' ABNORMAL TERMINATION (ENTRY Z): MAXIMUM Z ARRAY SIZE (='CNI12548
     1,'207) IS EXCEEDED BY M=',I10)                                    CNI12550
      STOP                                                              CNI12560
  999 RETURN                                                            CNI12562
CE.06 END OF Y (WITH ENTRY Z) (CNDOP)-----------------------------------CNI12565
      END                                                               CNI12570
      SUBROUTINE FIND (X,LIMU,WHATX,M)                                  CNI12580
CB.07 LAST CHANGE 22 JUN 1998 (CNDOP)-----------------------------------CNI12590
C     CALLED BY: Y     (06),Z     (06)                                  CNI12600
C     CALLS    : NONE                                                   CNI12610
C-----PART OF OVERLAP INTEGRALS ROUTINES (E.A.FISER, MIAMI UNIV., OHIO) CNI12620
      INTEGER X(1),WHATX                                                CNI12630
      K1 =2147483646                                                    CNI12640
      M=0                                                               CNI12650
      I=LIMU+1                                                          CNI12660
      J=1                                                               CNI12670
    1 K=(I+J)/2                                                         CNI12680
      IF (K.EQ.K1) GO TO 5                                              CNI12690
      K1=K                                                              CNI12700
      IF (X(K) - WHATX ) 3,4,2                                          CNI12710
    2 I=K                                                               CNI12720
      GO TO 1                                                           CNI12730
    3 J=K                                                               CNI12740
      GO TO 1                                                           CNI12750
    4 M=K                                                               CNI12760
    5 RETURN                                                            CNI12770
CE.07 END OF FIND (CNDOP)-----------------------------------------------CNI12780
      END                                                               CNI12790
      SUBROUTINE INTGRL (S,C,XXX,EIGVAL,GAMMA,ALPH2F,ALPH20,IATNO,ICORE,CNI12800
     1IOR2AT,LIMU,LIML,IGAM)                                            CNI12810
CB.08 LAST CHANGE 17 JUL 1998 (CNDOP)-----------------------------------CNI12820
C     CALLED BY: MAIN  (03),ON    (39)                                  CNI12830
C     CALLS:     MATPRS(44),RELVEC(11),FACT  (12),SS    (09),HARMTR(10),CNI12831
C                REPUL (42),SCFOUT(23),MATPRT(36)                       CNI12832
C-----COMPUTES OVERLAP AND 1-CENTER COULOMB INTEGRALS-------------------CNI12833
C-----SEE POPLE AND BEVERIDGE BOOK APPENDIX B---------------------------CNI12834
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI12860
      CHARACTER*1 EXX,WHY,ZEE,ONOMA                                     CNI12670
      CHARACTER*4 ITITOL                                                CNI12880
      DOUBLE PRECISION NUM,K1,K2                                        CNI12882
      INTEGER ULK,ULL,ANK,ANL                                           CNI12884
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI12886
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI12890
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI12900
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI12910
      COMMON/INFOX/NATOMS,II1(2),N,II2(3),LIMG,IPREC                    CNI12930
      COMMON/AUXINT/A(17),B(17)                                         CNI12940
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI12950
     1RKAPPA(35,6)                                                      CNI12960
      DIMENSION S(N,N),C(NATOMS,3),XXX(NATOMS),EIGVAL(N),               CNI12970
     1GAMMA(LIMG,LIMG),ALPH2F(NATOMS,3,3),ALPH20(NATOMS,3),             CNI12980
     2IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),  CNI12990
     3IGAM(N)                                                           CNI13000
      DIMENSION T(9,9),PAIRS(9,9),TEMP(9,9),C1(3),C2(3)                 CNI13010
      DIMENSION NC(35,2),LC(9),MC(9),E(3)                               CNI13020
      DIMENSION OLD(3),DPM(3),DENSMX(4,4),DIPSP(3),DIPASY(3),DIPS(3)    CNI13030
      DIMENSION DIPCHG(3),DIPZER(3),ALFSUM(3,3)                         CNI13040
      DIMENSION GAMMAS(35)                                              CNI13050
      DIMENSION ONOMA(3)                                                CNI13090
      DATA EXX,WHY,ZEE/1HX,1HY,1HZ/                                     CNI13100
      ONOMA(1)=EXX                                                      CNI13110
      ONOMA(2)=WHY                                                      CNI13120
      ONOMA(3)=ZEE                                                      CNI13130
      FAC1=BOHR/DEBYE                                                   CNI13140
      FILD=FIELD/BOHR**2                                                CNI13150
      IF (IFIELD.NE.0) GO TO 10                                         CNI13160
      IF (IHOFMN.GE.2) GO TO 10                                         CNI13170
C-----PUT OUT INTERATOMIC DISTANCES IN GAMMA----------------------------CNI13180
      ISTOP=0                                                           CNI13190
      DO 4 I=1,NATOMS                                                   CNI13200
         DO 3 J=1,NATOMS                                                CNI13210
            IF (J.EQ.1) BOND=0.1D09                                     CNI13220
            GAMMA(I,J)=0.0D0                                            CNI13230
            IF (I.EQ.J) GO TO 3                                         CNI13240
            X=0.0D0                                                     CNI13250
            DO 1 L=1,3                                                  CNI13260
               X=X+(C(I,L)-C(J,L))**2                                   CNI13270
    1       CONTINUE                                                    CNI13280
            DIST=BOHR*DSQRT(X)                                          CNI13290
            GAMMA(I,J)=DIST                                             CNI13300
            IF (DIST.LT.BONMIN) ISTOP=1                                 CNI13310
            IF (DIST.LT.BOND) BOND=DIST                                 CNI13320
            ITROUB=I                                                    CNI13330
            IF (J.EQ.NATOMS.AND.BOND.GT.BONDMX.AND.IPOLAR.GE.1)         CNI13340
     1      ISTOP=2                                                     CNI13350
            IF (I.EQ.NATOMS.AND.J.EQ.NATOMS-1.AND.BOND.                 CNI13360
     1      GT.BONDMX.AND.IPOLAR.GE.1) ISTOP=2                          CNI13370
    3    CONTINUE                                                       CNI13390
    4 CONTINUE                                                          CNI13400
      WRITE (LOUTPT,5)                                                  CNI13410
    5 FORMAT (///' INTERATOMIC DISTANCES (ANGSTROMS)')                  CNI13420
C *** PRINT INTERATOMIC DISTANCES---------------------------------------CNI13430
      CALL MATPRS (NATOMS,GAMMA,LIMG)                                   CNI13440
C-----RESET THE COMPLETE GAMMA MATRIX TO ZERO FOR RE-USE ---------------CNI13445
      DO 7 I=1,LIMG                                                     CNI13450
         DO 6 J=1,LIMG                                                  CNI13460
            GAMMA(I,J)=0.0D0                                            CNI13470
    6    CONTINUE                                                       CNI13480
    7 CONTINUE                                                          CNI13490
      IF (ISTOP.EQ.1) GO TO 901                                         CNI13500
      IF (ISTOP.EQ.2) GO TO 903                                         CNI13510
C-----SPECIFY INTEGRALS USED--------------------------------------------CNI13520
   10 CONTINUE                                                          CNI13530
      DO 17 II=1,35                                                     CNI13540
         DO 16 I=1,NATOMS                                               CNI13550
            IF (IATNO(I).NE.II) GO TO 16                                CNI13560
C           IF (II.EQ.1.AND.IPLFCN.EQ.0) WRITE (LOUTPT,11)              CNI13570
C    1      II,BETA0(II),ENEG(1,1)                                      CNI13580
C  11       FORMAT (' ELEMENT NO.',I3,' BETA=',D14.6,' 0.5*(I+A)=',     CNI13590
C    1      3D13.6)                                                     CNI13600
C           IF ((II.EQ.1.AND.IPLFCN.EQ.1).OR.(II.GT.1.AND.II.LT.10.AND. CNI13610
C    1      IPLFCN.EQ.0)) WRITE (LOUTPT,11) II,BETA0(II),ENEG(II,1),    CNI13620
C    2      ENEG(II,2)                                                  CNI13630
C           IF ((II.GT.1.AND.II.LT.10.AND.IPLFCN.EQ.1).OR.II.GT.10)     CNI13640
C    1      WRITE (LOUTPT,11) II,BETA0(II),(ENEG(II,JJ),JJ=1,3)         CNI13650
            GO TO 17                                                    CNI13660
   16    CONTINUE                                                       CNI13670
   17 CONTINUE                                                          CNI13680
C-----INITIALIZE DIPOLE MOMENT ARRAYS-----------------------------------CNI13690
      DIP=0.0D0                                                         CNI13700
      DO 18 K=1,3                                                       CNI13710
         DIPCHG(K)=0.0D0                                                CNI13720
         DIPSP (K)=0.0D0                                                CNI13730
         DIPASY(K)=0.0D0                                                CNI13740
         DPM   (K)=0.0D0                                                CNI13750
   18 CONTINUE                                                          CNI13760
C-----FILL IOR2AT ARRAY---IOR2AT(J) IDENTIFIES THE ATOM TO WHICH ORBITALCNI13770
C-----J IS ATTACHED E.G. ORBITAL 32 ATTACHED TO  ATOM 7, ETC.-----------CNI13780
      DO 20 K=1,NATOMS                                                  CNI13790
         LLK=LIML(K)                                                    CNI13800
         ULK=LIMU(K)                                                    CNI13810
         LIM=ULK+1-LLK                                                  CNI13820
         DO 19 I=1,LIM                                                  CNI13830
            J=LLK+I-1                                                   CNI13840
            IOR2AT(J)=K                                                 CNI13850
   19    CONTINUE                                                       CNI13860
   20 CONTINUE                                                          CNI13870
CEIL--ASSIGN IGAM TO GUIDE GAMMA INTEGRAL ADDRESSES---------------------CNI13880
      DO 23 I=1,NATOMS                                                  CNI13890
         LIMLO=LIML(I)                                                  CNI13900
         LIMHI=LIMU(I)                                                  CNI13910
C--------FOR VALENCE ELECTRONS PUT ODD VALUES IN ARRAY IGAM-------------CNI13911
         DO 21 IJ=LIMLO,LIMHI                                           CNI13920
            IGAM(IJ)=2*(I-1)+1                                          CNI13930
   21    CONTINUE                                                       CNI13940
         IF (IPLFCN.EQ.0) GO TO 23                                      CNI13950
         IF (IATNO(I).EQ. 1                  ) LIMLO=LIML(I)+1          CNI13960
         IF (IATNO(I).GE. 3.AND.IATNO(I).LE.9) LIMLO=LIML(I)+4          CNI13970
         IF (IATNO(I).GE.11.AND.INODEE.EQ.0)   LIMLO=LIML(I)+4          CNI13980
         IF (IATNO(I).GE.11.AND.INODEE.EQ.1)   GO TO 23                 CNI13990
         DO 22 IJ=LIMLO,LIMHI                                           CNI14000
CEIL--------FOR POLARIZATION FUNCTIONS EVEN ADDRESSES IN IGAM (EILERS)--CNI14001
CEIL--------EILERS IGAM(IJ)=2*I, METZGER 10FEB1989 IGAM(IJ)=2*(I-1)+1---CNI14002
            IGAM(IJ)=2*(I-1)+1                                          CNI14010
   22    CONTINUE                                                       CNI14020
   23 CONTINUE                                                          CNI14030

C-----POLARIZATION FUNCTIONS: ASSIGN NC---------------------------------CNI14370
      IF (IPLFCN.EQ.0) GO TO 28                                         CNI14380
      DO 27 I=1,17                                                      CNI14390
         IF (I.LE.9) NC(I,2)=NC(I,1)+1                                  CNI14400
         IF (I.GT.9) NC(I,2)=NC(I,1)                                    CNI14410
   27 CONTINUE                                                          CNI14420
C-----ASSIGNMENT OF ANGULAR MOMENTUM QUANTUM NOS. TO ATOMIC ORBITALS----CNI14440
   28 LC(1)=0                                                           CNI14450
      LC(2)=1                                                           CNI14460
      LC(3)=1                                                           CNI14470
      LC(4)=1                                                           CNI14480
      LC(5)=2                                                           CNI14490
      LC(6)=2                                                           CNI14500
      LC(7)=2                                                           CNI14510
      LC(8)=2                                                           CNI14520
      LC(9)=2                                                           CNI14530
C-----S FCNS.                                                           CNI14540
      MC(1)=0                                                           CNI14550
C-----P FCNS.                                                           CNI14560
      MC(2)=1                                                           CNI14570
      MC(3)=-1                                                          CNI14580
      MC(4)=0                                                           CNI14590
C-----D FCNS.                                                           CNI14600
      MC(5)=0                                                           CNI14610
      MC(6)=1                                                           CNI14620
      MC(7)=-1                                                          CNI14630
      MC(8)=2                                                           CNI14640
      MC(9)=-2                                                          CNI14650
      IF (INUPAR.LT.2) GO TO 30                                         CNI14660
      IF (INUPAR.EQ.4) GO TO 29                                         CNI14670
C-----INUPAR=2 AND INUPAR=3 CASE:---------------------------------------CNI14680
C     DEL BENE AND JAFFE CNDOP-S SETTING OF ONE-CENTER                  CNI14690
C     REPULSION INTEGRALS FOR H, C, N, O                                CNI14700
C     JANET DEL BENE AND H.H.JAFFE,J.CHEM.PHYS.48,1807,4050(1968);      CNI14710
C     T. MIYAZAKI AND H.SHINODA, BULL.CHEM.SOC.JAPAN 46,1216(1973)      CNI14720
C-----R.L.ELLIS,G.KUEHNLENZ,AND H.H.JAFFE, THEOR.CHIM.ACTA 26,131(1972)-CNI14730
      GAMMAS(1)=12.85  D0                                               CNI14740
      GAMMAS(6)=10.93  D0                                               CNI14750
      GAMMAS(7)=11.83  D0                                               CNI14760
      GAMMAS(8)=15.13  D0                                               CNI14770
      GO TO 30                                                          CNI14780
C-----KROGH-JESPERSEN AND RATNER PARAMETRIZATION:-----------------------CNI14790
C-----USE SICHEL AND WHITEHEAD THEOR.CHIM.ACTA 7,32(1967)---------------CNI14800
   29 GAMMAS( 1)=12.848  D0                                             CNI14810
      GAMMAS( 3)= 3.469  D0                                             CNI14820
      GAMMAS( 4)= 5.935  D0                                             CNI14830
      GAMMAS( 5)= 8.000  D0                                             CNI14840
      GAMMAS( 6)=10.207  D0                                             CNI14850
      GAMMAS( 7)=11.052  D0                                             CNI14860
C-----BUT NOTE KROGH-JESPERSEN&RATNER VALUES J.CHEM.PHYS.65,1305(1976): CNI14980
C     GAMMAS( 1)=12.484  D0                                             CNI15000
C     GAMMAS( 6)=10.333  D0                                             CNI15010
C-----GAMMAS( 7)=11.308  D0---------------------------------------------CNI15020
      GAMMAS( 8)=13.625  D0                                             CNI14870
      GAMMAS( 9)=15.054  D0                                             CNI14880
      GAMMAS(11)= 2.982  D0                                             CNI14890
      GAMMAS(12)= 4.623  D0                                             CNI14900
      GAMMAS(13)= 5.682  D0                                             CNI14910
      GAMMAS(14)= 6.964  D0                                             CNI14920
      GAMMAS(15)= 9.878  D0                                             CNI14930
      GAMMAS(16)= 9.205  D0                                             CNI14940
      GAMMAS(17)=10.292  D0                                             CNI14950
      GAMMAS(19)= 3.702  D0                                             CNI14960
      GAMMAS(20)= 3.977  D0                                             CNI14970
      GAMMAS(31)= 5.936  D0                                             CNI15030
      GAMMAS(32)= 6.608  D0                                             CNI15040
      GAMMAS(33)= 8.399  D0                                             CNI15050
      GAMMAS(34)= 9.121  D0                                             CNI15060
      GAMMAS(35)= 8.823  D0                                             CNI15070
C-----STEP THRU PAIRS OF ATOMS------------------------------------------CNI15260
   30 DO 65 K=1,NATOMS                                                  CNI15270
         LLK=LIML(K)                                                    CNI15280
         ULK=LIMU(K)                                                    CNI15290
         NORBK=ULK-LLK+1                                                CNI15300
         ANK=IATNO(K)                                                   CNI15310
         KSWTCH=0                                                       CNI15320
         IF (ANK.LE.2) KSWTCH=2                                         CNI15330
         IF (ANK.GT.2.AND.ANK.LE.35) KSWTCH=5                           CNI15340
         DO 64 L=K,NATOMS                                               CNI15350
            DO 36 I=1,3                                                 CNI15360
               C1(I)=C(K,I)                                             CNI15370
               C2(I)=C(L,I)                                             CNI15380
   36       CONTINUE                                                    CNI15385
C *** ------GET E=UNIT VECTOR BETWEEN ATOMS K,L, R=INTERATOMIC DISTANCE-CNI15390
            CALL RELVEC (R,E,C1,C2)                                     CNI15400
            LLL=LIML(L)                                                 CNI15410
            ULL=LIMU(L)                                                 CNI15420
            NORBL=ULL-LLL+1                                             CNI15430
            ANL=IATNO(L)                                                CNI15440
            LSWTCH=0                                                    CNI15450
            IF (ANL.LE.2) LSWTCH=2                                      CNI15460
            IF (ANL.GT.2.AND.ANL.LE.35) LSWTCH=5                        CNI15470
            UMK=ZSLATR(ANK,1)                                           CNI15480
            NCK=NC(ANK,1)                                               CNI15490
            OLD(1)=0.0D0                                                CNI15500
            OLD(2)=0.0D0                                                CNI15510
            OLD(3)=0.0D0                                                CNI15520
C-----------LOOP THRU PAIRS OF BASIS FUNCTIONS, ONE ON EACH ATOM--------CNI15530
            DO 50 I=1,NORBK                                             CNI15540
               LCI=LC(I)                                                CNI15550
               MCI=MC(I)                                                CNI15560
               IF (IPLFCN.EQ.0) GO TO 37                                CNI15570
               IF (I.LT.KSWTCH) GO TO 37                                CNI15580
               UMK=ZSLATR(ANK,2)                                        CNI15590
               NCK=NC(ANK,2)                                            CNI15600
   37          UML=ZSLATR(ANL,1)                                        CNI15610
               NCL=NC(ANL,1)                                            CNI15620
C--------------STANDARD OVERLAP INTEGRAL: RK=1.0D0----------------------CNI15630
C              MODIFIED OVERLAP INTEGRAL (DEL BENE-JAFFE CNDO/S ETC):   CNI15640
C              K=0.585 FOR LOCALIZED PI INTERACTIONS                    CNI15650
C              K.W.SCHULTE AND A.SCHWEIG, THEOR.CHIM.ACTA 33,19(1974):  CNI15660
C--------------K=0.300 FOR ANY D INTERACTIONS---------------------------CNI15670
               RK=1.0D0                                                 CNI15680
               DO 49 J=1,NORBL                                          CNI15690
                  LCJ=LC(J)                                             CNI15700
                  MCJ=MC(J)                                             CNI15710
                  IF (INUPAR.LE.1) GO TO 38                             CNI15720
                  IF (I.EQ.2.AND.J.EQ.2) RK=0.585D0                     CNI15730
                  IF (I.EQ.3.AND.J.EQ.3) RK=0.585D0                     CNI15740
                  IF (I.EQ.4.AND.J.EQ.4) RK=0.585D0                     CNI15750
                  IF (I.GE.5.OR .J.GE.5) RK=0.300D0                     CNI15760
   38             IF (IPLFCN.EQ.0)  GO TO 39                            CNI15770
                  RKI=1.D0                                              CNI15780
                  RKJ=1.D0                                              CNI15790
                  IF (I.GE.KSWTCH.AND.I.EQ.2) RKI=RKAPPA(ANK,2)         CNI15800
                  IF (I.GE.KSWTCH.AND.I.EQ.3) RKI=RKAPPA(ANK,2)         CNI15810
                  IF (I.GE.KSWTCH.AND.I.EQ.4) RKI=RKAPPA(ANK,1)         CNI15820
                  IF (I.GE.KSWTCH.AND.I.EQ.5) RKI=RKAPPA(ANK,1)         CNI15830
                  IF (I.GE.KSWTCH.AND.I.EQ.6) RKI=RKAPPA(ANK,2)         CNI15840
                  IF (I.GE.KSWTCH.AND.I.EQ.7) RKI=RKAPPA(ANK,2)         CNI15850
                  IF (I.GE.KSWTCH.AND.I.EQ.8) RKI=RKAPPA(ANK,3)         CNI15860
                  IF (I.GE.KSWTCH.AND.I.EQ.9) RKI=RKAPPA(ANK,2)         CNI15870
                  IF (J.GE.LSWTCH.AND.J.EQ.2) RKJ=RKAPPA(ANL,2)         CNI15880
                  IF (J.GE.LSWTCH.AND.J.EQ.3) RKJ=RKAPPA(ANL,2)         CNI15890
                  IF (J.GE.LSWTCH.AND.J.EQ.4) RKJ=RKAPPA(ANL,1)         CNI15900
                  IF (J.GE.LSWTCH.AND.J.EQ.5) RKJ=RKAPPA(ANL,1)         CNI15910
                  IF (J.GE.LSWTCH.AND.J.EQ.6) RKJ=RKAPPA(ANL,2)         CNI15920
                  IF (J.GE.LSWTCH.AND.J.EQ.7) RKJ=RKAPPA(ANL,2)         CNI15930
                  IF (J.GE.LSWTCH.AND.J.EQ.8) RKJ=RKAPPA(ANL,3)         CNI15940
                  IF (J.GE.LSWTCH.AND.J.EQ.9) RKJ=RKAPPA(ANL,2)         CNI15950
                  IF (I.GE.KSWTCH.AND.J.GE.LSWTCH) RK=(RKI+RKJ)/2.D0    CNI15960
                  IF (I.LT.KSWTCH.AND.J.GE.LSWTCH) RK=0.D0              CNI15970
                  IF (I.GE.KSWTCH.AND.J.LT.LSWTCH) RK=0.D0              CNI15980
                  IF (IHOFMN.GT.2) RK=1.D0                              CNI15990
                  IF (J.LT.LSWTCH) GO TO 39                             CNI16000
                  UML=ZSLATR(ANL,2)                                     CNI16010
                  NCL=NC(ANL,2)                                         CNI16020
   39             IF (K.EQ.L) GO TO 45                                  CNI16030
   40             IF (MCI.NE.MCJ) GO TO 44                              CNI16040
   41             IF (MCI.LT.0) GO TO 43                                CNI16050
   42             CONTINUE                                              CNI16055
                  PAIRS(I,J)=RK*DSQRT((UMK*R)**(2*NCK+1)*               CNI16060
     1            (UML*R)**(2*NCL+1)/(FACT(2*NCK)*                      CNI16070
     2            FACT(2*NCL)))*(-1.D0)**(LCJ+MCJ)                      CNI16080
     3            *SS(NCK,LCI,MCI,NCL,LCJ,UMK*R,UML*R)                  CNI16090
                  GO TO 48                                              CNI16100
   43             PAIRS(I,J)=PAIRS(I-1,J-1)                             CNI16110
                  GO TO 48                                              CNI16120
   44             PAIRS(I,J)=0.0D0                                      CNI16130
                  GO TO 48                                              CNI16140
   45             IF (I.EQ.J) GO TO 47                                  CNI16150
   46             PAIRS(I,J)=0.0D0                                      CNI16160
                  GO TO 48                                              CNI16170
   47             PAIRS(I,I)=1.0D0                                      CNI16180
   48             CONTINUE                                              CNI16190
   49          CONTINUE                                                 CNI16200
   50       CONTINUE                                                    CNI16210
            LCULK=LC(NORBK)                                             CNI16220
            LCULL=LC(NORBL)                                             CNI16230
            MAXL=MAX0(LCULK,LCULL)                                      CNI16240
            IF (R.LT.0.000001D0) GO TO 59                               CNI16250
C-----------ROTATE OVERLAP INTEGRALS FROM DIATOMIC BASIS (LOCAL---------CNI16260
C           COORDINATE SYSTEM) TO MOLECULAR BASIS                       CNI16270
C *** ------FIRST, COMPUTE ROTATION MATRIX, T.--------------------------CNI16280
   51       CALL HARMTR(T,MAXL,E)                                       CNI16290
C-----------NOW PERFORM SIMILARITY TRANSFORMATION ON OVERLAP INTEGRAL S-CNI16300
            DO 54 I=1,NORBK                                             CNI16310
               DO 53 J=1,NORBL                                          CNI16320
                  TEMP(I,J)=0.D0                                        CNI16330
                  DO 52 KK=1,NORBL                                      CNI16340
                     TEMP(I,J)=TEMP(I,J)+T(J,KK)*PAIRS(I,KK)            CNI16350
   52             CONTINUE                                              CNI16352
   53          CONTINUE                                                 CNI16355
   54       CONTINUE                                                    CNI16360
            DO 57 I=1,NORBK                                             CNI16370
               DO 56 J=1,NORBL                                          CNI16380
                  PAIRS(I,J)=0.D0                                       CNI16390
                  DO 55 KK=1,NORBK                                      CNI16400
                     PAIRS(I,J)=PAIRS(I,J)+T(I,KK)*TEMP(KK,J)           CNI16410
   55             CONTINUE                                              CNI16412
   56          CONTINUE                                                 CNI16415
   57       CONTINUE                                                    CNI16420
C-----------FILL S MATRIX-----------------------------------------------CNI16430
   59       DO 61 I=1,NORBK                                             CNI16440
               LLKP=LLK+I-1                                             CNI16450
               DO 60 J=1,NORBL                                          CNI16460
                  LLLP=LLL+J-1                                          CNI16470
                  S(LLKP,LLLP)=PAIRS(I,J)                               CNI16480
   60            CONTINUE                                               CNI16482
   61       CONTINUE                                                    CNI16490
CEIL--------COMPUTE COULOMB INTEGRALS OVER SLATER S FUNCTIONS-----------CNI16500
            LOOP=1                                                      CNI16510
C-----------LOOP=2 FOR POLARIZATION FUNCTIONS (EILERS)------------------CNI16512
C-----------LOOP=1 FOR POLARIZATION FUNCTIONS (METZGER 10 FEB 1989)-----CNI16515
            IF (IPLFCN.NE.0) LOOP=1                                     CNI16520
            DO 63 IK=1,LOOP                                             CNI16530
               N1=NC(ANK,IK)                                            CNI16540
               K1=ZSLATR(ANK,IK)                                        CNI16550
               DO 62 IL=1,LOOP                                          CNI16560
                  N2=NC(ANL,IL)                                         CNI16570
                  K2=ZSLATR(ANL,IL)                                     CNI16580
C *** ------------COMPUTE COULOMB REPULSION INTEGRALS (EILERS FIX)------CNI16590
                  CALL REPUL (R,K,ANK,L,ANL,N1,K1,N2,K2,GAMMAS,COUL)    CNI16600
                  KADDR=2*(K-1)+IK                                      CNI16610
                  LADDR=2*(L-1)+IL                                      CNI16620
                  GAMMA(KADDR,LADDR)=COUL                               CNI16630
   62          CONTINUE                                                 CNI16640
   63       CONTINUE                                                    CNI16650
   64    CONTINUE                                                       CNI16660
   65 CONTINUE                                                          CNI16670
C-----SYMMETRIZE OVERLAP MATRIX S---------------------------------------CNI16680
      DO 67 I=1,N                                                       CNI16690
         DO 66 J=I,N                                                    CNI16700
            S(J,I)=S(I,J)                                               CNI16710
   66    CONTINUE                                                       CNI16720
   67 CONTINUE                                                          CNI16730
C-----SYMMETRIZE COULOMB MATRIX GAMMA-----------------------------------CNI16735
      DO 69 I=1,LIMG                                                    CNI16740
         DO 68 J=I,LIMG                                                 CNI16750
            GAMMA(J,I)=GAMMA(I,J)                                       CNI16760
   68    CONTINUE                                                       CNI16770
   69 CONTINUE                                                          CNI16780
      IF (IFIELD.EQ.0) WRITE (LOUTPT,70)                                CNI16790
   70 FORMAT(' OVERLAP INTEGRAL MATRIX')                                CNI16800
      IF (IHOFMN.GE.2) GO TO 999                                        CNI16810
C *** PRINT OVERLAP INTEGRAL MATRIX S-----------------------------------CNI16820
      IF (IFIELD.EQ.0.AND.IBRIEF.EQ.0) CALL SCFOUT (0,S,EIGVAL,IATNO,   CNI16825
     1IOR2AT,LIMU,LIML)                                                 CNI16830
      IF (IFIELD.EQ.0) WRITE (LOUTPT,71)                                CNI16840
   71 FORMAT(' COULOMB INTEGRAL MATRIX')                                CNI16850
C *** PRINT COULOMB INTEGRAL MATRIX GAMMA-------------------------------CNI16860
      IF (IFIELD.EQ.0.AND.IBRIEF.EQ.0) CALL MATPRT (LIMG,GAMMA)         CNI16870
      GO TO 999                                                         CNI16880
      IF (IFIELD.GT.0) WRITE (LOUTPT,72) FILD,ONOMA(IFIELD),            CNI17260
     1ONOMA(IFIELD),ALFSUM(IFIELD,1),                                   CNI17270
     2ONOMA(IFIELD),ALFSUM(IFIELD,2),                                   CNI17280
     3ONOMA(IFIELD),ALFSUM(IFIELD,3)                                    CNI17290
   72 FORMAT (' IF THE TOTAL MOLECULAR',                                CNI17300
     1' STATIC ELECTRIC DIPOLE POLARIZABILITY'/                         CNI17310
     2' IS THE RATIO OF THE DIPOLE MOMENT'/                             CNI17320
     3' DIVIDED BY THE APPLIED ELECTRIC FIELD:',D16.9/                  CNI17330
     4' ELECTRONS/ANGSTROMS**2',                                        CNI17340
     5' IN THE POSITIVE ',A1,' DIRECTION'/                              CNI17350
     6' THEN IT IS (UNITS OF ANGSTROMS**3):'/                           CNI17360
     7' TOT. MOL. ALPHA(',A1,'X)=',D16.9/                               CNI17370
     8' TOT. MOL. ALPHA(',A1,'Y)=',D16.9/                               CNI17380
     9' TOT. MOL. ALPHA(',A1,'Z)=',D16.9//)                             CNI17390
      GO TO 999                                                         CNI17400
C-----ABNORMAL TERMINATION DIAGNOSTICS BEGIN----------------------------CNI17410
  901 WRITE (LOUTPT,902)                                                CNI17420
  902 FORMAT (' RUN ABORTED (INTGRL). THERE IS AT LEAST ONE',           CNI17430
     1' ABNORMALLY SHORT INTERATOMIC DISTANCE.')                        CNI17440
      STOP                                                              CNI17460
  903 WRITE (LOUTPT,904) BONDMX,ITROUB                                  CNI17470
  904 FORMAT (' RUN ABORTED (INTGRL).'/                                 CNI17480
     1' AT LEAST ONE ATOM HAD A MINIMUM BOND DISTANCE EXCEEDING',       CNI17490
     2D20.10,' ANGSTROMS.'/' OFFENDING ATOM I=',I5)                     CNI17500
      STOP                                                              CNI17510
C-----ABNORMAL TERMINATION DIAGNOSTIC MESSAGES END----------------------CNI17515
  999 RETURN                                                            CNI17520
CE.08 END OF INTGRL (CNDOP)---------------------------------------------CNI17530
      END                                                               CNI17540
      FUNCTION SS (NN1,LL1,MM,NN2,LL2,ALPHA,BETA)                       CNI17550
CB.09 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI17560
C     CALLED BY: INTGRL(08)                                             CNI17570
C     CALLS    : AINTGS(14),BINTGS(13),Y     (06),                      CNI04460
C                Z     (06),FACT  (12)                                  CNI04460
C-----PART OF OVERLAP AND 1-CENTER COULOMB INTEGRALS PACKAGE------------CNI17590
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI17600
      CHARACTER*4 ITITOL                                                CNI17605
C-----PROCEDURE FOR CALCULATING REDUCED OVERLAP INTEGRALS---------------CNI17610
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI17620
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI17630
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI17640
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI17650
      COMMON/INFOX/II1(3),NN,II2(3),LIMG,IPREC                          CNI17670
      COMMON/AUXINT/A(17),B(17)                                         CNI17680
      DO 2 I=1,17                                                       CNI17690
         A(I)=0.0D0                                                     CNI17700
         B(I)=0.0D0                                                     CNI17710
    2 CONTINUE                                                          CNI17720
      N1=NN1                                                            CNI17730
      L1=LL1                                                            CNI17740
      M=MM                                                              CNI17750
      N2=NN2                                                            CNI17760
      L2=LL2                                                            CNI17770
      P =(ALPHA + BETA)/2.D0                                            CNI17780
      PT=(ALPHA - BETA)/2.D0                                            CNI17790
      X = 0.D0                                                          CNI17800
      M=IABS(M)                                                         CNI17810
C-----REVERSE QUANTUM NUMBERS IF NECESSARY------------------------------CNI17820
      IF ((L2.LT.L1).OR.((L2.EQ.L1).AND.(N2.LT.N1))) GO TO 20           CNI17830
   10 GO TO 30                                                          CNI17840
   20 K = N1                                                            CNI17850
      N1= N2                                                            CNI17860
      N2= K                                                             CNI17870
      K= L1                                                             CNI17880
      L1= L2                                                            CNI17890
      L2= K                                                             CNI17900
      PT=-PT                                                            CNI17910
   30 CONTINUE                                                          CNI17920
      K = MOD((N1+N2-L1-L2),2)                                          CNI17930
      NFILL=N1+N2                                                       CNI17940
C *** FIND A AND B INTEGRALS (AND FILL A,B MATRICES)--------------------CNI17950
C-----NOTE THAT IF P=0, THEN AINTGS BLOWS UP----------------------------CNI17955
      CALL AINTGS (P ,NFILL)                                            CNI17960
C ***                                                                   CNI17970
      CALL BINTGS (PT,NFILL)                                            CNI17980
      IF ((L1.GT.0).OR.(L2.GT.0)) GO TO 60                              CNI17990
C-----OVERLAP INTEGRALS INVOLVING S FUNCTIONS: FIND Z TABLE NUMBER L....CNI18000
   40 L=(90-17*N1+N1**2-2*N2)/2                                         CNI18010
      LIMU=N1+N2+1                                                      CNI18020
      LIML=1                                                            CNI18030
      DO 50 I=LIML,LIMU                                                 CNI18040
         II=I                                                           CNI18050
         NNI1=N1+N2-I+2                                                 CNI18060
C ***    FETCH Z(I,J) VALUE FROM INSIDE FUNCTION Y(I,J,K)...............CNI18061
         X=X+Z(II,L)*A(II)*B(NNI1)/2.D0                                 CNI18070
   50 CONTINUE                                                          CNI18080
      SS=X                                                              CNI18090
      GO TO 80                                                          CNI18100
C-----OVERLAPS INVOLVING NON-S FUNCTIONS: FIND Y TABLE NUMBER L.........CNI18110
   60 L=(5-M)*(24-10*M+M**2)*(83-30*M+3*M**2)/120+                      CNI18120
     1  (30-9*L1+L1**2-2*N1)*(28-9*L1+L1**2-2*N1)/8+                    CNI18130
     2  (30-9*L2+L2**2-2*N2)/2                                          CNI18140
      LIML = 1                                                          CNI18150
      DO 70 I=LIML,9                                                    CNI18160
         II=I                                                           CNI18170
         LIMU=5-MOD(K+I-1,2)                                            CNI18180
         DO 70 J=LIML,LIMU                                              CNI18190
            IIII=2*J+MOD(K+I-1,2)-1                                     CNI18200
            JJ=J                                                        CNI18210
C ***       FETCH Y VALUE...............................................CNI18211
            X=X+Y(II,JJ,L)*A(II)*B(IIII)                                CNI18220
   70 CONTINUE                                                          CNI18230
CIBM  SS = X*(FACT(M+1)/8.D0)**2*DSQRT(DFLOAT(2*L1+1)*                  CNI18240
CIBM 1 FACT(L1-M)*DFLOAT(2*L2+1)*FACT(L2-M)/(4.D0*                      CNI18250
CIBM 2 FACT(L1+M)*FACT(L2+M)))                                          CNI18250
      SS = X*(FACT(M+1)/8.D0)**2*DSQRT(DBLE(FLOAT(2*L1+1))*             CNI18240
     1 FACT(L1-M)*DBLE(FLOAT(2*L2+1))*FACT(L2-M)/(4.D0*                 CNI18250
     2 FACT(L1+M)*FACT(L2+M)))                                          CNI18250
   80 CONTINUE                                                          CNI18260
      RETURN                                                            CNI18270
CE.09 END OF SS (CNDOP)-------------------------------------------------CNI18280
      END                                                               CNI18290
      SUBROUTINE HARMTR (T,MAXL,E)                                      CNI18300
CB.10 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI18310
C     CALLED BY: INTGRL(08)                                             CNI18320
C     CALLS    : NONE                                                   CNI18330
C-----EULERIAN ROTATION ROUTINE ----------------------------------------CNI18340
C     THETA=CO-LATITUDE                                                 CNI18350
C     PHI  =LONGITUDE                                                   CNI18360
C     IN A (R,THETA,PHI) RIGHT-HANDED SPHERICAL POLAR COORD.SYSTEM      CNI18370
C     COST=COS(THETA)=(Z(I)-Z(J))/R(IJ)                                 CNI18380
C     COSP=COS(PHI  )=(X(I)-X(J))/(R(IJ)*SIN(THETA))                    CNI18390
C-----SINP=SIN(PHI  )=(Y(I)-Y(J))/(R(IJ)*SIN(THETA))--------------------CNI18400
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI18410
      DIMENSION T(9,9),E(3)                                             CNI18420
      COST=E(3)                                                         CNI18430
      IF ((1.D0-COST**2).GT.0.1D-09) GO TO 1                            CNI18440
      SINT=0.D0                                                         CNI18450
      GO TO 2                                                           CNI18460
    1 SINT=DSQRT(1.D0-COST**2)                                          CNI18470
    2 IF (SINT.GT.0.1D-05) GO TO 3                                      CNI18490
      COSP=1.D0                                                         CNI18500
      SINP=0.D0                                                         CNI18510
      GO TO 4                                                           CNI18520
    3 COSP=E(1)/SINT                                                    CNI18530
      SINP=E(2)/SINT                                                    CNI18540
    4 DO 6 I=1,9                                                        CNI18560
         DO 5 J=1,9                                                     CNI18570
            T(I,J)=0.D0                                                 CNI18580
    5    CONTINUE                                                       CNI18582
    6 CONTINUE                                                          CNI18585
      T(1,1)=1.D0                                                       CNI18590
      IF (MAXL.GT.1) GO TO 7                                            CNI18600
      IF (MAXL.GT.0) GO TO 8                                            CNI18610
      GO TO 999                                                         CNI18620
    7 COS2T=COST**2-SINT**2                                             CNI18630
      SIN2T=2.D0*SINT*COST                                              CNI18640
      COS2P=COSP**2-SINP**2                                             CNI18650
      SIN2P=2.D0*SINP*COSP                                              CNI18660
C-----TRANSFORMATION MATRIX ELEMENTS FOR D FUNCTIONS--------------------CNI18670
      SQRT3=DSQRT(3.D0)                                                 CNI18680
      T(5,5)= (3.D0*COST**2-1.D0)/2.D0                                  CNI18690
      T(5,6)=-SQRT3*SIN2T/2.D0                                          CNI18700
      T(5,8)= SQRT3*SINT**2/2.D0                                        CNI18710
      T(6,5)= SQRT3*SIN2T*COSP/2.D0                                     CNI18720
      T(6,6)= COS2T*COSP                                                CNI18730
      T(6,7)=-COST*SINP                                                 CNI18740
      T(6,8)=-T(6,5)/SQRT3                                              CNI18750
      T(6,9)= SINT*SINP                                                 CNI18760
      T(7,5)= SQRT3*SIN2T*SINP/2.D0                                     CNI18770
      T(7,6)= COS2T*SINP                                                CNI18780
      T(7,7)= COST*COSP                                                 CNI18790
      T(7,8)=-T(7,5)/SQRT3                                              CNI18800
      T(7,9)=-SINT*COSP                                                 CNI18810
      T(8,5)= SQRT3*SINT**2*COS2P/2.D0                                  CNI18820
      T(8,6)= SIN2T*COS2P/2.D0                                          CNI18830
      T(8,7)=-SINT*SIN2P                                                CNI18840
      T(8,8)= (1.D0+COST**2)*COS2P/2.D0                                 CNI18850
      T(8,9)=-COST*SIN2P                                                CNI18860
      T(9,5)= SQRT3*SINT**2*SIN2P/2.D0                                  CNI18870
      T(9,6)= SIN2T*SIN2P/2.D0                                          CNI18880
      T(9,7)= SINT*COS2P                                                CNI18890
      T(9,8)= (1.D0+COST**2)*SIN2P/2.D0                                 CNI18900
      T(9,9)= COST*COS2P                                                CNI18910
C-----TRANSFORMATION MATRIX ELEMENTS FOR P FUNCTIONS--------------------CNI18930
C     T(1,1)=1      T(1,2)=0         T(1,3)=0      T(1,4)=0             CNI18940
C     T(2,1)=0      T(2,2)=COST*COSP T(2,3)=-SINP  T(2,4)=SINT*COSP     CNI18950
C     T(3,1)=0      T(3,2)=COST*SINP T(3,3)=COSP   T(3,4)=SINT*SINP     CNI18960
C     T(4,1)=0      T(4,2)=-SINT     T(4,3)=0      T(4,4)=COST          CNI18970
C                                                                       CNI18980
C     (T(2,2)  T(2,3)  T(2,4))     (COSP -SINP  0) (COST  0 SINT)       CNI18990
C     (T(3,2)  T(3,3)  T(3,4))  =  (SINP  COSP  0) (0     1 0   )       CNI19000
C-----(T(4,2)  T(4,3)  T(4,4))     (0     0     1) (-SINT 0 COST)-------CNI19010
    8 T(2,2)= COST*COSP                                                 CNI19020
      T(2,3)=-SINP                                                      CNI19030
      T(2,4)= SINT*COSP                                                 CNI19040
      T(3,2)= COST*SINP                                                 CNI19050
      T(3,3)= COSP                                                      CNI19060
      T(3,4)= SINT*SINP                                                 CNI19070
      T(4,2)=-SINT                                                      CNI19080
      T(4,4)= COST                                                      CNI19090
  999 RETURN                                                            CNI19110
CE.10 END OF HARMTR (CNDOP)---------------------------------------------CNI19120
      END                                                               CNI19130
      SUBROUTINE RELVEC (R,E,C1,C2)                                     CNI19140
CB.11 LAST CHANGE 13 JUN 1984 (CNDOP)                                   CNI19150
C     CALLED BY: INTGRL(08)                                             CNI19160
C     CALLS    : NONE                                                   CNI19170
C-----COMPUTE INTERATOMIC VECTOR AND DIRECTION COSINES                  CNI19180
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI19190
      DIMENSION E(3),C1(3),C2(3)                                        CNI19200
      X=0.D0                                                            CNI19210
      DO 1 I=1,3                                                        CNI19220
         E(I)=C2(I)-C1(I)                                               CNI19230
         X=X+E(I)**2                                                    CNI19240
    1 CONTINUE                                                          CNI19250
      R=DSQRT(X)                                                        CNI19260
      IF (R.LT.0.1D-5) GO TO 999                                        CNI19270
      DO 2 I=1,3                                                        CNI19280
         E(I)=E(I)/R                                                    CNI19290
    2 CONTINUE                                                          CNI19300
  999 RETURN                                                            CNI19310
CE.11 END OF RELVEC (CNDOP)---------------------------------------------CNI19320
      END                                                               CNI19330
      FUNCTION FACT(N)                                                  CNI19340
CB.12 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI19350
C     CALLED BY: BINOM (35),BINTGS(13),COULJE(43),SS    (09),INTGRL(08) CNI19360
C     CALLS    : NONE                                                   CNI19370
C-----COMPUTES FACTORIAL N----------------------------------------------CNI19380
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI19390
      PRODT = 1.D0                                                      CNI19400
      IF (N.EQ.0) GO TO 2                                               CNI19410
      DO 1 I=1,N                                                        CNI19420
         PRODT=PRODT*I                                                  CNI19430
    1 CONTINUE                                                          CNI19435
    2 FACT=PRODT                                                        CNI19440
      RETURN                                                            CNI19450
CE.12 END OF FACT (CNDOP)-----------------------------------------------CNI19460
      END                                                               CNI19470
      SUBROUTINE BINTGS(X,K)                                            CNI19480
CB.13 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI19490
C     CALLED BY: SS    (09)                                             CNI19500
C     CALLS    : FACT  (12)                                             CNI19510
C-----PART OF OVERLAP INTEGRALS-----------------------------------------CNI19520
C-----FILLS ARRAY OF B-INTEGRALS. NOTE THAT B(I) IS B(I-1) IN THE       CNI19540
C     USUAL NOTATION                                                    CNI19550
C     FOR X.GT.3                    EXPONENTIAL FORMULA IS USED         CNI19560
C     FOR 2.LT.X.LE.3 AND K.LE.10   EXPONENTIAL FORMULA IS USED         CNI19570
C     FOR 2.LT.X.LE.3 AND K.GT.10   15 TERM SERIES IS USED              CNI19580
C     FOR 1.LT.X .E.2 AND K.LE.7    EXPONENTIAL FORMULA IS USED         CNI19590
C     FOR 1.LT.X.LE.2 AND K.GT.7    12 TERM SERIES IS USED              CNI19600
C     FOR .5.LT.X.LE.1 AND K.LE.5   EXPONENTIAL FORMULA IS USED         CNI19610
C     FOR .5.LT.X.LE.1 AND K.GT.5    7 TERM SERIES IS USED              CNI19620
C-----FOR X.LE..5                    6 TERM SERIES IS USED--------------CNI19630
C-----DOBOSH  HAD I0=0 IN HIS CNDOP PROGRAM. THIS IS NOT OK FORTRAN-----CNI19650
C-----METZGER FIXUP: SET I0=1 AND INCREASE K, LAST BY 1-----------------CNI19660
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI19530
      COMMON/AUXINT/A(17),B(17)                                         CNI19640
      I0=1                                                              CNI19670
      ABSX=DABS(X)                                                      CNI19680
      IF(ABSX.GT.3.D0     ) GO TO 5                                     CNI19690
      IF(ABSX.GT.2.D0     ) GO TO 4                                     CNI19700
      IF(ABSX.GT.1.D0     ) GO TO 3                                     CNI19710
      IF(ABSX.GT..5D0     ) GO TO 2                                     CNI19720
      IF(ABSX.GT..000001D0) GO TO 1                                     CNI19730
      GO TO 10                                                          CNI19740
    1 LAST=6                                                            CNI19750
      GO TO 7                                                           CNI19760
    2 IF(K.LE. 5) GO TO 5                                               CNI19770
      LAST=7                                                            CNI19780
      GO TO 7                                                           CNI19790
    3 IF(K.LE. 7) GO TO 5                                               CNI19800
      LAST=12                                                           CNI19810
      GO TO 7                                                           CNI19820
    4 IF(K.LE.10) GO TO 5                                               CNI19830
      LAST=15                                                           CNI19840
      GO TO 7                                                           CNI19850
C-----EXPONENTIAL FORMULA FOLLOWS                                       CNI19860
    5 EXPX=DEXP(X)                                                      CNI19870
      EXPMX=1.D0/EXPX                                                   CNI19880
      B(1)=(EXPX-EXPMX)/X                                               CNI19890
      DO 6 I=1,K                                                        CNI19900
         B(I+1)=(DBLE(FLOAT(I))*B(I)+(-1.D0)**I*EXPX-EXPMX)/X           CNI19910
    6 CONTINUE                                                          CNI19915
      GO TO 999                                                         CNI19920
C-----SERIES FORMULA FOLLOWS--------------------------------------------CNI19930
    7 KK=K+1                                                            CNI19940
      LAST=LAST+1                                                       CNI19950
      DO 9 II=I0,KK                                                     CNI19960
         I=II-1                                                         CNI19970
         Y=0.D0                                                         CNI19980
         DO 8 MM=I0,LAST                                                CNI19990
             M=MM-1                                                     CNI20000
             Y=Y+(-X)**M*(1.D0-(-1.D0)**(M+I+1))/(FACT(M)*              CNI20010
     1       DBLE(FLOAT(M+I+1)))                                        CNI20010
    8    CONTINUE                                                       CNI20015
         B(I+1)=Y                                                       CNI20020
    9 CONTINUE                                                          CNI20025
      GO TO 999                                                         CNI20030
   10 KK=K+1                                                            CNI20040
      DO 11 I=I0,KK                                                     CNI20050
         B(I)=(1.D0-(-1.D0)**I)/DBLE(FLOAT(I))                          CNI20060
   11 CONTINUE                                                          CNI20070
  999 RETURN                                                            CNI20080
CE.13 END OF BINTGS (CNDOP)---------------------------------------------CNI20090
      END                                                               CNI20100
      SUBROUTINE AINTGS(X,K)                                            CNI20110
CB.14 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI20120
C     CALLED BY: SS    (09)                                             CNI20130
C     CALLS    : NONE                                                   CNI20140
C-----PART OF INTEGRALS  EVALUATION ------------------------------------CNI20150
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI20160
      COMMON/AUXINT/A(17),B(17)                                         CNI20170
      A(1)=DEXP(-X)/X                                                   CNI20180
      DO 1 I=1,K                                                        CNI20190
         A(I+1) =(A(I)*DBLE(FLOAT(I))+DEXP(-X))/X                       CNI20200
    1 CONTINUE                                                          CNI20205
      RETURN                                                            CNI20210
CE.14 END OF AINTGS (CNDOP)---------------------------------------------CNI20220
      END                                                               CNI20230
      SUBROUTINE HUCKCL (A,B,XXX,XX6,XX7,EIGVAL,XX9,G,Q,C,XXY,XXZ,IATNO,CNI20240
     1ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,IVPOS,IORD)                     CNI20250
CB.15 LAST CHANGE 17 JUL 1998 (CNDOP)-----------------------------------CNI20260
C     CALLED BY: MAIN  (03)                                             CNI20270
C     CALLS    : EIGN  (22),SCFOUT(23)                                  CNI20280
C---- EXTENDED HUCKEL THEORY FOR CLOSED SHELLS--------------------------CNI20290
C     DOBOSH. MODIFIED BY METZGER, RHEE, EILERS                         CNI20300
C---- OVERLAPS ARE IN MATRIX A, COULOMB INTEGRALS (GAMMA) ARE IN MATRIX CNI20310
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI20320
      CHARACTER*4 ITITOL,CA                                             CNI20325
      INTEGER OPTION,OPNCLO,CNDO,UL,ANI                                 CNI20330
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI20340
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI20350
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI20360
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI20370
      COMMON/INFOX/NATOMS,NCHARG,II1(1),N,NELECS,NOCCA,II2(1),LIMG,IPRECCNI20390
      COMMON/CHOICE/OPTION,II3(2),CNDO,II4(3)                           CNI20400
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI20410
     1RKAPPA(35,6)                                                      CNI20420
      DIMENSION A(N,N),B(N,N),XXX(N),XX6(N),XX7(N),EIGVAL(N),XX9(N),    CNI20430
     1G(LIMG,LIMG),Q(N),C(NATOMS,3),XXY(N),XXZ(N),IATNO(NATOMS),        CNI20440
     2ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),IGAM(N),        CNI20460
     3IPOSV(N),IVPOS(N),IORD(N)                                         CNI20465
      IRETUR=0                                                          CNI20470
      IF (IPOLAR.GE.1.AND.IFIELD.EQ.1.AND.ISHORT.EQ.1) GO TO 10         CNI20480
      IF (IFIELD.GE.2.AND.ISHORT.EQ.1) IRETUR=1                         CNI20490
      IF (IFIELD.GE.2.AND.ISHORT.EQ.1) GO TO 10                         CNI20500
C---- FILL EXTENDED HUECKEL HAMILTONIAN (DIAGONAL) WITH (I+A)/2---------CNI20510
      DO 6 I=1,NATOMS                                                   CNI20520
         LL =LIML(I)                                                    CNI20530
         UL =LIMU(I)                                                    CNI20540
         ANI=IATNO(I)                                                   CNI20550
         L=0                                                            CNI20560
         DO 5 J=LL,UL                                                   CNI20570
            L=L+1                                                       CNI20580
            IF (L.EQ.1) GO TO 4                                         CNI20590
            IF (L.LT.5) GO TO 3                                         CNI20600
            A(J,J)=-ENEG(ANI,3)/HARTRE                                  CNI20610
            GO TO 5                                                     CNI20620
    3       A(J,J)=-ENEG(ANI,2)/HARTRE                                  CNI20630
            GO TO 5                                                     CNI20640
    4       A(J,J)=-ENEG(ANI,1)/HARTRE                                  CNI20650
    5    CONTINUE                                                       CNI20660
    6 CONTINUE                                                          CNI20670
C-----FORM HUECKEL HAMILTONIAN IN A (OFF-DIAGONAL TWO-CENTER TERMS)-----CNI20680
C-----FROM OVERLAP INTEGRAL---------------------------------------------CNI20690
      DO 9 I=2,N                                                        CNI20700
         K=IOR2AT(I)                                                    CNI20710
         L=IATNO(K)                                                     CNI20720
         UL=I-1                                                         CNI20730
         DO 8 J=1,UL                                                    CNI20740
            KK=IOR2AT(J)                                                CNI20750
            LL=IATNO(KK)                                                CNI20760
            IF ((L.GT.9).OR.(LL.GT.9)) GO TO 7                          CNI20770
            A(I,J)=A(I,J)*(BETA0(L)+BETA0(LL))/(2.D0*HARTRE)            CNI20780
            A(J,I)=A(I,J)                                               CNI20790
            GO TO 8                                                     CNI20800
    7       IF (INUPAR.EQ.0) A(I,J)=0.75D0*A(I,J)*(BETA0(L)+BETA0(LL))  CNI20810
     1      /(2.D0*HARTRE)                                              CNI20820
            IF (INUPAR.EQ.1) A(I,J)=A(I,J)*BETAD/HARTRE                 CNI20830
            IF (INUPAR.EQ.4) A(I,J)=A(I,J)*(BETA0(L)+BETA0(LL))         CNI20840
     1      /(2.D0*HARTRE)                                              CNI20850
            A(J,I)=A(I,J)                                               CNI20860
    8    CONTINUE                                                       CNI20870
    9 CONTINUE                                                          CNI20880
C---- ADD TO CORE HAMILTONIAN ONE-CENTER OFF-DIAGONAL HYBRIDIZ. TERM----CNI20890
   10 IF (IRETUR.GE.1.AND.ISHORT.EQ.1) FIELD=-FIELD                     CNI20900
      IF (IRETUR.GE.1.AND.ISHORT.EQ.1) IFIELD=IFIELD-1                  CNI20910
   11 ROOT3=DSQRT(3.0D0)                                                CNI20920
      IF (IFIELD.EQ.0) GO TO 31                                         CNI20930
      ROOT5=DSQRT(5.0D0)                                                CNI20940
      ROOT2=DSQRT(2.0D0)                                                CNI20950
      ROOT6=DSQRT(6.0D0)                                                CNI20960
      DO 25 I=2,N                                                       CNI20970
         KATOM =IOR2AT(I)                                               CNI20980
         LATMNO=IATNO(KATOM)                                            CNI20990
         L     =LIML(KATOM)                                             CNI21000
         LIMUPP=LIMU(KATOM)                                             CNI21010
         LRANGE=LIMUPP-L+1                                              CNI21020
         IF (LATMNO.GE.11.AND.LATMNO.LE.35.AND.INODEE.EQ.0) LRANGE=9    CNI21030
         ZETA  =ZSLATR(LATMNO,1)                                        CNI21040
         ZETA2 =ZSLATR(LATMNO,2)                                        CNI21050
         ZETAV =0.5D0*(ZETA+ZETA2)                                      CNI21060
         I1=I-1                                                         CNI21070
         IF (I.NE.LIMUPP) GO TO 25                                      CNI21080
         DO 24 J=1,I1                                                   CNI21090
            IF (J.NE.L) GO TO 24                                        CNI21100
            IF (IOR2AT(J).NE.KATOM) GO TO 24                            CNI21110
            IADDR=L+IFIELD                                              CNI21120
            IF (IPLFCN.EQ.0) GO TO 12                                   CNI21130
            IF (LATMNO.NE.1) GO TO 12                                   CNI21140
C-----------HYDROGEN POLARIZATION FUNCTIONS-----------------------------CNI21150
C           (1S/X/2PX) = ((ZETA**3)*(ZETA2**5))**0.5/ZETAV**5           CNI21160
C           (1S/Y/2PY) =   DITTO                                        CNI21170
C-----------(1S/Z/2PZ) =   DITTO ---------------------------------------CNI21180
            A(IADDR,L)=A(IADDR,L)-FIELD*(((ZETA**3)*                    CNI21190
     1      (ZETA2**5))**0.5D0)/ZETAV**5                                CNI21200
            GO TO 24                                                    CNI21210
   12       IF (LATMNO.LT.3.OR.LATMNO.GT.9) GO TO 16                    CNI21220
C-----------USING /2PX)=(ZETA**5/PI)**0.5*X*EXP(-ZETA*R)----------------CNI21230
C           LI,BE,B,C,N,O,F VALENCE FUNCTIONS:                          CNI21240
C           (2S/X/2PX)=2.5/(SQRT(3.)*ZETA)                              CNI21250
C           (2S/Y/2PY)=2.5/(SQRT(3.)*ZETA)                              CNI21260
C-----------(2S/Z/2PZ)=2.5/(SQRT(3.)*ZETA)------------------------------CNI21270
            A(IADDR,L)=A(IADDR,L)-2.5*FIELD/(ROOT3*ZETA)                CNI21280
            IF (IPLFCN.EQ.0) GO TO 24                                   CNI21290
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUNCTIONS --------------------CNI21300
            ZE=((ZETA**2.5)*(ZETA2**3.5))/(ZETAV**7)                    CNI21310
            IF (IFIELD-2) 13,14,15                                      CNI21320
C-----------LI,BE,B,C,N,O,F POLARIZATION FUNCTIONS: FIELD ALONG X:------CNI21330
C           (2PX/X/3DZ2)   =-SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/           CNI21340
C                           2*ZETAV**7                                  CNI21350
C           (2PX/X/3DX2-Y2)=SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21360
C                           2*ZETAV**7                                  CNI21370
C           (2PY/X/3DXY)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21380
C                           2*ZETAV**7                                  CNI21390
C           (2PZ/X/3DXZ)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21400
C-----------                2*ZETAV**7----------------------------------CNI21410
   13       A(L+4,L+1)=A(L+4,L+1)+FIELD*ROOT2*ZE/2.D0                   CNI21420
            A(L+7,L+1)=A(L+7,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI21430
            A(L+8,L+2)=A(L+8,L+2)-FIELD*ROOT6*ZE/2.D0                   CNI21440
            A(L+5,L+3)=A(L+5,L+3)-FIELD*ROOT6*ZE/2.D0                   CNI21450
            GO TO 24                                                    CNI21460
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUNCTION : FIELD ALONG Y------CNI21470
C           (2PX/Y/3DXY)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21480
C                           2*ZETAV**7                                  CNI21490
C           (2PY/Y/3DZ2)   =-SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/           CNI21500
C                           2*ZETAV**7                                  CNI21510
C           (2PY/Y/3DX2-Y2)=-SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI21520
C                           2*ZETAV**7                                  CNI21530
C           (2PZ/Y/3DXY)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21540
C-----------                2*ZETAV**7----------------------------------CNI21550
   14       A(L+8,L+1)=A(L+8,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI21560
            A(L+4,L+2)=A(L+4,L+2)+FIELD*ROOT2*ZE/2.D0                   CNI21570
            A(L+7,L+2)=A(L+7,L+2)+FIELD*ROOT6*ZE/2.D0                   CNI21580
            A(L+6,L+3)=A(L+6,L+3)-FIELD*ROOT6*ZE/2.D0                   CNI21590
            GO TO 24                                                    CNI21600
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUNCTION :FIELD ALONG Z-------CNI21610
C           (2PX/Z/3DXZ)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21620
C                           2*ZETAV**7                                  CNI21630
C           (2PY/Z/3DYZ)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI21640
C                           2*ZETAV**7                                  CNI21650
C           (2PZ/Z/3DZ2)   =SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/            CNI21660
C------------               ZETAV**7 -----------------------------------CNI21670
   15       A(L+5,L+1)=A(L+5,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI21680
            A(L+6,L+2)=A(L+6,L+2)-FIELD*ROOT6*ZE/2.D0                   CNI21690
            A(L+4,L+3)=A(L+4,L+3)-FIELD*ROOT2*ZE                        CNI21700
            GO TO 24                                                    CNI21710
   16       IF (LATMNO.LT.11.OR.LATMNO.GT.17) GO TO 20                  CNI21720
C-----------NA,MG,SI,P,S,CL: (3S/X/3PX), (3S/Y/3PY), (3S/Z/3PZ)---------CNI21730
            A(IADDR,L)=A(IADDR,L)-3.5*FIELD/(ROOT3*ZETA)                CNI21740
            IF (INODEE.EQ.1) GO TO 24                                   CNI21750
            IF (IPLFCN.EQ.0) ZE=ZETA                                    CNI21760
            IF (IPLFCN.EQ.1) ZE=ZETAV**8/((ZETA*ZETA2)**3.5)            CNI21770
            IF (IFIELD-2) 17,18,19                                      CNI21780
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI21790
C           (3PX/X/3DZ2)   =-3.5/(SQRT(15.)*ZETA)                       CNI21800
C           (3PX/X/3DX2-Y2)= 3.5/(SQRT( 5.)*ZETA)                       CNI21810
C           (3PY/X/3DXY)   = 3.5/(SQRT( 5.)*ZETA)                       CNI21820
C-----------(3PZ/X/3DXZ)   = 3.5/(SQRT( 5.)*ZETA)-----------------------CNI21830
   17       A(L+4,L+1)=A(L+4,L+1)+3.5*FIELD/(ROOT3*ROOT5*ZE)            CNI21840
            A(L+7,L+1)=A(L+7,L+1)-3.5*FIELD/(ROOT5*ZE)                  CNI21850
            A(L+8,L+2)=A(L+8,L+2)-3.5*FIELD/(ROOT5*ZE)                  CNI21860
            A(L+5,L+3)=A(L+5,L+3)-3.5*FIELD/(ROOT5*ZE)                  CNI21870
            GO TO 24                                                    CNI21880
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI21890
C           (3PY/Y/3DXY)   = 3.5/(SQRT( 5.)*ZETA)                       CNI21900
C           (3PY/Y/3DZ2)   =-3.5/(SQRT(15.)*ZETA)                       CNI21910
C           (3PY/Y/3DX2-Y2)=-3.5/(SQRT( 5.)*ZETA)                       CNI21920
C-----------(3PZ/Y/3DYZ)   = 3.5/(SQRT( 5.)*ZETA)-----------------------CNI21930
   18       A(L+8,L+1)=A(L+8,L+1)-3.5*FIELD/(ROOT5*ZE)                  CNI21940
            A(L+4,L+2)=A(L+4,L+2)+3.5*FIELD/(ROOT3*ROOT5*ZE)            CNI21950
            A(L+7,L+2)=A(L+7,L+2)+3.5*FIELD/(ROOT5*ZE)                  CNI21960
            A(L+6,L+3)=A(L+6,L+3)-3.5*FIELD/(ROOT5*ZE)                  CNI21970
            GO TO 24                                                    CNI21980
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI21990
C           (3PX/Z/3DXZ)   =3.5/(SQRT( 5.)*ZETA)                        CNI22000
C           (3PY/Z/3DYZ)   =3.5/(SQRT( 5.)*ZETA)                        CNI22010
C-----------(3PZ/Z/3DZ2)   =  7/(SQRT(15.)*ZETA)------------------------CNI22020
   19       A(L+5,L+1)=A(L+5,L+1)-3.5*FIELD/(ROOT5*ZE)                  CNI22030
            A(L+6,L+2)=A(L+6,L+2)-3.5*FIELD/(ROOT5*ZE)                  CNI22040
            A(L+4,L+3)=A(L+4,L+3)-7.0*FIELD/(ROOT3*ROOT5*ZE)            CNI22050
            GO TO 24                                                    CNI22060
   20       IF (LATMNO.LT.32.OR.LATMNO.GT.35) GO TO 24                  CNI22070
            IF (LATMNO.GE.19.AND.LATMNO.LE.35.AND.INODEE.EQ.0)          CNI22080
     1      LRANGE=9                                                    CNI22090
            ZETA =ZSLATR(LATMNO,1)                                      CNI22100
            ZETA2=ZSLATR(LATMNO,2)                                      CNI22110
            ZETAV=.5D0*(ZETA+ZETA2)                                     CNI22120
C-----------GE,AS,SE,BR: (4S/X/4PX),(4S/Y/4PY),(4S/Z/4PZ)---------------CNI22130
            A(IADDR,L)=A(IADDR,L)-4.5*FIELD/(ROOT3*ZETA)                CNI22140
            IF (INODEE.EQ.1) GO TO 24                                   CNI22150
            IF (IPLFCN.EQ.0) ZE=ZETA                                    CNI22160
            IF (IPLFCN.EQ.1) ZE=(ZETAV**10)/((ZETA*ZETA2)**4.5)         CNI22170
            IF (IFIELD-2) 21,22,23                                      CNI22180
C-----------GE,AS,SE,BR: -----------------------------------------------CNI22190
C           (4PX/X/4DZ2)   =-4.5/(SQRT(15.)*ZE)                         CNI22200
C           (4PX/X/4DX2-Y2)= 4.5/(SQRT( 5.)*ZE)                         CNI22210
C           (4PY/X/4DXY)   = 4.5/(SQRT( 5.)*ZE)                         CNI22220
C-----------(4PZ/X/4DXZ)   = 4.5/(SQRT( 5.)*ZE)-------------------------CNI22230
   21       A(L+4,L+1)=A(L+4,L+1)+4.5*FIELD/(ROOT3*ROOT5*ZE)            CNI22240
            A(L+7,L+1)=A(L+7,L+1)-4.5*FIELD/(ROOT5*ZE)                  CNI22250
            A(L+8,L+2)=A(L+8,L+2)-4.5*FIELD/(ROOT5*ZE)                  CNI22260
            A(L+5,L+3)=A(L+5,L+3)-4.5*FIELD/(ROOT5*ZE)                  CNI22270
            GO TO 24                                                    CNI22280
C-----------GE,AS,SE,BR: -----------------------------------------------CNI22290
C           (4PX/Y/4DXY)   = 4.5/(SQRT( 5.)*ZE)                         CNI22300
C           (4PY/Y/4DZ2)   =-4.5/(SQRT(15.)*ZE)                         CNI22310
C           (4PY/Y/4DX2-Y2)=-4.5/(SQRT( 5.)*ZE)                         CNI22320
C-----------(4PZ/Y/4DYZ)   = 4.5/(SQRT( 5.)*ZE)-------------------------CNI22330
   22       A(L+8,L+1)=A(L+8,L+1)-4.5D0*FIELD/(ROOT5*ZE)                CNI22340
            A(L+4,L+2)=A(L+4,L+2)+4.5D0*FIELD/(ROOT3*ROOT5*ZE)          CNI22350
            A(L+7,L+2)=A(L+7,L+2)+4.5D0*FIELD/(ROOT5*ZE)                CNI22360
            A(L+6,L+3)=A(L+6,L+3)-4.5D0*FIELD/(ROOT5*ZE)                CNI22370
            GO TO 24                                                    CNI22380
C-----------GE,AS,SE,BR: -----------------------------------------------CNI22390
C           (4PX/Z/4DXZ)=4.5/(SQRT(5.)*ZE)                              CNI22400
C           (4PY/Z/4DYZ)=4.5/(SQRT(5.)*ZE)                              CNI22410
C-----------(4PZ/Z/4DZ2)=9/(SQRT(15.)*ZE)                               CNI22420
   23       A(L+5,L+1)=A(L+5,L+1)-4.5D0*FIELD/(ROOT5*ZE)                CNI22430
            A(L+6,L+2)=A(L+6,L+2)-4.5D0*FIELD/(ROOT5*ZE)                CNI22440
            A(L+4,L+3)=A(L+4,L+3)-9.0D0*FIELD/(ROOT3*ROOT5*ZE)          CNI22450
   24    CONTINUE                                                       CNI22460
   25 CONTINUE                                                          CNI22470
      DO 27 I=2,N                                                       CNI22480
         I1=I-1                                                         CNI22490
         DO 26 J=1,I1                                                   CNI22500
            A(J,I)=A(I,J)                                               CNI22510
   26    CONTINUE                                                       CNI22520
   27 CONTINUE                                                          CNI22530
      IF (IRETUR.GE.1.AND.ISHORT.EQ.1) IRETUR=IRETUR+1                  CNI22540
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) IFIELD=IFIELD+1                  CNI22550
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) FIELD=-FIELD                     CNI22560
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) GO TO 11                         CNI22570
      IFIEL1=IFIELD-1                                                   CNI22580
C-----ADD TO CORE HAMILTONIAN ONE-CENTER DIAG. FINITE EL.FIELD PERTURB. CNI22590
      DO 30 I=1,NATOMS                                                  CNI22600
         LL=LIML(I)                                                     CNI22610
         UL=LIMU(I)                                                     CNI22620
         DO 29 J=LL,UL                                                  CNI22630
            IF (DABS(C(I,IFIELD)).LT.0.00000001D0) GO TO 29             CNI22640
            IF (IFIELD.LT.2.OR.ISHORT.EQ.0)        GO TO 28             CNI22650
            A(J,J)=A(J,J)+FIELD*C(I,IFIEL1)                             CNI22660
   28       A(J,J)=A(J,J)-FIELD*C(I,IFIELD)                             CNI22670
   29    CONTINUE                                                       CNI22680
   30 CONTINUE                                                          CNI22690
   31 CONTINUE                                                          CNI22700
      DO 105 I=1,N                                                      CNI22710
  105 Q(I)=A(I,I)                                                       CNI22720
      IF (IPOLAR.GE.1.AND.IFIELD.GT.0.AND.ISHORT.EQ.1) GO TO 311        CNI22730
      RHO=1.D-06                                                        CNI22740
C *** DIAGONALIZE                                                       CNI22750
      CALL EIGN (N,RHO,A,B,XXX,XX6,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,  CNI22751
     1IORD)                                                             CNI22760
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI16830
      RHO=0.1D-1*CONVRG                                                 CNI22770
C-----EIGENVECTORS (IN B) ARE CONVERTED INTO DENSITY MATRIX (IN B)------CNI22780
      DO 140 I=1,N                                                      CNI22790
         DO 120 J=I,N                                                   CNI22800
            XXX(J)=0.0D0                                                CNI22810
            DO 110 K=1,NOCCA                                            CNI22820
               XXX(J)= XXX(J)+2.D0*B(I,K)*B(J,K)                        CNI22830
  110       CONTINUE                                                    CNI22831
  120    CONTINUE                                                       CNI22840
         DO 130 J=I,N                                                   CNI22850
            B(I,J)= XXX(J)                                              CNI22860
  130    CONTINUE                                                       CNI22865
  140 CONTINUE                                                          CNI22870
      IERR=0                                                            CNI22880
      DO 150 I=1,N                                                      CNI22890
         DO 149 J=I,N                                                   CNI22900
            B(J,I)=B(I,J)                                               CNI22910
            IF (DABS(B(I,J)).GT.3.D0) IERR=1                            CNI22920
  149    CONTINUE                                                       CNI22930
  150 CONTINUE                                                          CNI22940
C-----ADD V(AB) TO HCORE--CNDO/2----------------------------------------CNI22950
      DO 170 I=1,N                                                      CNI22960
CEIL-----NOTE THAT GAMMA ADDRESSES ARE NO LONGER SIMPLE ATOM -----------CNI22970
C        ADDRESSES. ODD INDICES GET PRINCIPAL SHELL GAMMAS AT EACH      CNI22980
CEIL-----CENTER. EVEN INDICES GET POLARIZATTION SHELL GAMMAS            CNI22990
C--------METZGER (10 FEB 1989) LEFT INDICES ODD FOR ALL ----------------CNI22995
         J=IOR2AT(I)                                                    CNI23000
         IJ=IGAM(I)                                                     CNI23010
         IIJ=IJ                                                         CNI23020
CEIL-----IF TRUE POLARIZATION FUNCTION (I.E. NOT ENERGETICALLY----------CNI23030
C        DEGENERATE WITH AN OCCUPIED GROUND STATE OF THE ATOM)          CNI23040
C        THEN U(I,I)=-(I+A)/2 + 0.5*(GAMMA BETWEEN THIS FCN AND THE     CNI23050
C                    VALENCE FCNS)-(NUMBER OF VALENCE ELECTRONS)*       CNI23060
C                    (GAMMA INTEGRAL BETWEEN THE POLARIZATION FCN AND   CNI23070
C                    THE VALENCE FCNS)                                  CNI23080
C        IF FCN IS NORMAL VALENCE FCN,                                  CNI23090
C        THEN U(I,I)=-(I+A)/2 +0.5*GAMMA(I,I)-(NUMBER OF VALENCE        CNI23100
CEIL------------------ELECTRONS)*GAMMA(I,I)-----------------------------CNI23110
         IDIV=IJ/2                                                      CNI23120
         IIDIV=2*IDIV                                                   CNI23130
         IF ((IJ-IIDIV).GT.0) GO TO 1160                                CNI23140
         IIJ=IJ-1                                                       CNI23150
 1160    Q(I)=Q(I)+0.5D0*G(IJ,IIJ)                                      CNI23160
         Q(I)=Q(I)-DBLE(FLOAT(ICORE(J)))*G(IJ,IIJ)                      CNI23170
         DO 160 K=1,NATOMS                                              CNI23180
            IF (K.EQ.J) GO TO 160                                       CNI23190
            IK=2*K-1                                                    CNI23200
            IF (IJ-IIDIV.GT.0) GO TO 1601                               CNI23210
CEIL--------APPROXIMATE THE NUCLEAR ATTRACTION TO CORE OF ATOM K--------CNI23220
CEIL        BY -(REPULSION INTEGRAL BETWEEN I AND THE VALENCE           CNI23230
CEIL--------ELECTRONS OF K)---------------------------------------------CNI23240
 1601       Q(I)=Q(I)-DBLE(FLOAT(ICORE(K)))*G(IJ,IK)                    CNI23250
  160    CONTINUE                                                       CNI23260
  170 CONTINUE                                                          CNI23270
CEIL--CAVEAT: THE ABOVE CODE DOES NOT TREAT THE CASE--------------------CNI23280
CEIL  WHERE THE GROUND-STATE ATOM HAS OCCUPIED D ORBITALS WITH          CNI23290
CEIL  DIFFERENT EXPONENTS OR PRINCIPAL QUANTUM NUMBERS THAN             CNI23300
CEIL  THE OCCUPIED S AND P SHELLS                                       CNI23310
CEIL  FOR SUCH AN S(L) P(M) D(N) GROUND-STATE CONFIGURATION:            CNI23320
CEIL  U(S,S)=-0.5*(I+A)+0.5*GAMMA(S,S)-L*GAMMA(S,S)-N*GAMMA(S,D)        CNI23330
CEIL                                  -M*GAMMA(S,P)                     CNI23340
CEIL  U(P,P)=-0.5*(I+A)+0.5*GAMMA(P,P)-M*GAMMA(P,P)-L*GAMMA(S,P)        CNI23350
CEIL                                  -N*GAMMA(P,D)                     CNI23360
CEIL  U(D,D)=-0.5*(I+A)+0.5*GAMMA(D,D)-N*GAMMA(D,D)-L*GAMMA(S,D)        CNI23370
CEIL                                  -M*GAMMA(P,D)                     CNI23380
CEIL  THE INDIRECT ADDRESSING SHOULD WORK: JUST TAKE CARE TO LOOK UP    CNI23390
CEIL  THE RIGHT GAMMA, AND DETERMINE THE OCCUPATION NUMBERS             CNI23400
C-----EXIT SEGMENT IF ONLY CNDO APPROXIMATIONS ARE DESIRED--------------CNI23410
      IF (OPTION.EQ.CNDO) GO TO 290                                     CNI23420
C-----INDO MODIFICATION (CORRECTION TO U(I,I))--------------------------CNI23430
  180 DO 280 I=1,NATOMS                                                 CNI23440
         K=IATNO(I)                                                     CNI23450
         J=LIML(I)                                                      CNI23460
         IF ((K.GT.1).AND.(K.LT.10)) GO TO 190                          CNI23470
         GO TO 280                                                      CNI23480
  190    IF (K.LE.3) GO TO 210                                          CNI23490
  200    Q(J)=Q(J)+(DBLE(FLOAT(ICORE(I)))-1.5D0)*G1(K)/6.D0             CNI23500
  210    IF (K.EQ.3) GO TO 220                                          CNI23510
  230    IF (K.EQ.4) GO TO 240                                          CNI23520
  250    TEMP=G1(K)/3.D0+(DBLE(FLOAT(ICORE(I)))-2.5D0)*2.D0*            CNI23530
     1   F2(K)/25.D0                                                    CNI23530
         GO TO 260                                                      CNI23540
  240    TEMP=G1(K)/4.D0                                                CNI23550
         GO TO 260                                                      CNI23560
  220    TEMP=G1(K)/12.D0                                               CNI23570
  260    CONTINUE                                                       CNI23580
         DO 270 L=1,3                                                   CNI23590
  270    Q(J+L)=Q(J+L)+TEMP                                             CNI23600
  280 CONTINUE                                                          CNI23610
  290 CONTINUE                                                          CNI23620
      DO 310 I=1,N                                                      CNI23630
         DO 300 J=I,N                                                   CNI23640
  300    A(J,I)=A(I,J)                                                  CNI23650
  310 A(I,I)=Q(I)                                                       CNI23660
  311 CONTINUE                                                          CNI23670
      IF (IFIELD.GT.0) GO TO 999                                        CNI23680
      WRITE (LOUTPT,320)                                                CNI23690
  320 FORMAT(1X,18H CORE HAMILTONIAN /)                                 CNI23700
C *** PRINT CORE HAMILTONIAN--------------------------------------------CNI23710
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI23720
      WRITE (LOUTPT,330)                                                CNI23740
  330 FORMAT (' INITIAL DENSITY MATRIX.')                               CNI23750
C *** PRINT INITIAL DENSITY MATRIX--------------------------------------CNI23730
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI23760
      IF (IERR.EQ.1) GO TO 901                                          CNI23770
      GO TO 999                                                         CNI23780
C-----DIAGNOSTIC ERROR MESSAGES SECTION BEGINS--------------------------CNI23790
  901 WRITE (LOUTPT,902)                                                CNI23800
  902 FORMAT (' RUN ABORTED. DENSITY MATRIX BLEW UP')                   CNI23810
      STOP                                                              CNI23820
C-----DIAGNOSTIC ERROR MESSAGES SECTION ENDS----------------------------CNI23825
  999 RETURN                                                            CNI23830
CE.15 END OF HUCKCL (CNDOP)---------------------------------------------CNI23840
      END                                                               CNI23850
      SUBROUTINE SCFCLO (A,B,QQ,C,XXX,XX6,XX7,EIGVAL,XX9,G,Q,BOLD,      CNI23860
     1ALPH2F,ATLCHF,FOLD,PULERR,XXY,XXZ,IATNO,ICORE,IOR2AT,LIMU,LIML,   CNI23870
     2IGAM,IPOSV,IVPOS,IORD,ENERGY)                                     CNI23880
CB.16 LAST CHANGE 25 AUG 2014 (CNDOP)-----------------------------------CNI23890
C     CALLED BY: MAIN  (03)                                             CNI23900
C     CALLS    : RANNUM(25),SOLPUL(40),SCFOUT(23),EIGN  (22),ON    (39) CNI04420
C-----CLOSED-SHELL SCF CYCLES; WRITTEN BY PAUL DOBOSH ------------------CNI23920
C     PULAY TRICK ADDED BY  R.E.SCHMIEG; CORRECTIONS BY JAMES E.EILERS  CNI23930
C     GAMMA MATRIX CONTAINED IN G, CORE HAMILTONIAN CONTAINED IN Q AND  CNI23970
C-----UPPER TRIANGLE OF A, AND INITIAL DENSITY MATRIX CONTAINED IN B----CNI23980
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI23950
      CHARACTER*4 ITITOL,CA,EL                                          CNI23955
      REAL*4 EXX,WHY,ZEE,ACKACK                                         CNI23960
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI23990
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI24000
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI24010
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI24020
      COMMON/INFOX/NATOMS,II1(2),N,II2(1),NOCCA,II3(1),LIMG,IPREC       CNI24040
      COMMON/CHOICE/OPTION,II4(2),CNDO,II5(3)                           CNI24050
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/AUXINT/XX1(34)                                             CNI04730
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI04740
     1RKAPPA(35,6)                                                      CNI24130
      INTEGER OPTION,CNDO                                               CNI24220
      DIMENSION A(N,N),B(N,N),QQ(N,N),C(NATOMS,3),XXX(N),XX6(N),        CNI24060
     1XX7(N),EIGVAL(N),XX9(N),G(LIMG,LIMG),Q(N),BOLD(N,N),              CNI24070
     2ALPH2F(NATOMS,3,3),ATLCHF(NATOMS,3),                              CNI24080
     3FOLD(NPULAY,NPULAY,5),PULERR(NPULAY,NPULAY,5),XXY(N),XXZ(N),      CNI24090
     4IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),  CNI24100
     5IGAM(N),IPOSV(N),IVPOS(N),IORD(N)                                 CNI24110
C-----THE PULAY TRICK: DECLARATION -------------------------------------CNI24140
C     PULERR = LAST 4 + CURRENT ERROR MATRICES                          CNI24150
C     FOLD   = LAST 4 + CURRENT FOCK MATRICES                           CNI24160
C     PULAY  = PULAY ERROR TRACES MATRIX                                CNI24170
C     PLAM   = COEFFICIENT MATRIX FOR FINAL STAGE OF PULAY TRICK        CNI24180
C-----IDIS   = CIRCULAR POINTER STACK-----------------------------------CNI24190
      DIMENSION PULAY(6,6),PLAM(6),IDIS(5)                              CNI24200
C-----END DECLARATION FOR PULAY TRICK-----------------------------------CNI24210
      DATA EXX/1HX/,WHY/1HY/,ZEE/1HZ/                                   CNI24230
C-----IX IS INITIALIZER FOR PSEUDO-RANDOM-NUMBER GENERATOR RANNUM.------CNI24240
      IX=536870911                                                      CNI24250
      IF (IFIELD.EQ.1) ACKACK=EXX                                       CNI24260
      IF (IFIELD.EQ.2) ACKACK=WHY                                       CNI24270
      IF (IFIELD.EQ.3) ACKACK=ZEE                                       CNI24280
      ICYCLE=0                                                          CNI24290
      IDMOK =0                                                          CNI24300
      OLDENG=0.0D0                                                      CNI24310
      DO  3 I=1,N                                                       CNI24320
         DO  2 J=1,N                                                    CNI24330
            BOLD(I,J)=B(I,J)                                            CNI24340
    2    CONTINUE                                                       CNI24350
    3 CONTINUE                                                          CNI24360
C-----CHECK IF USER WANTS TO RUN PULAY TRICK----------------------------CNI24370
      IF (NPULAY.LE.1) GO TO 10                                         CNI24380
      DO 6 K=1,5                                                        CNI24390
        IDIS(K)=K                                                       CNI24400
        DO 5 J=1,NPULAY                                                 CNI24410
          DO 4 I=1,NPULAY                                               CNI24420
            PULERR(I,J,K)=0.0D0                                         CNI24430
    4    CONTINUE                                                       CNI24440
    5 CONTINUE                                                          CNI24450
    6 CONTINUE                                                          CNI24460
      PULAY(1,1)=0.0D0                                                  CNI24470
      DO 8 I=2,6                                                        CNI24480
        PULAY(I,1)=-1.0D0                                               CNI24490
        PULAY(1,I)=-1.0D0                                               CNI24500
        DO 7 J=2,6                                                      CNI24510
          PULAY(I,J)=0.0D0                                              CNI24520
    7   CONTINUE                                                        CNI24530
    8 CONTINUE                                                          CNI24540
C-----PULAY TRICK: FINISHED INITIALIZING--------------------------------CNI24550
   10 ICYCLE=ICYCLE+1                                                   CNI24570
      IF (NPULAY.GT.1) KPUL=IDIS(5)                                     CNI24580
      ENERGY = 0.D0                                                     CNI24590
      IF (IDM.EQ.0) GO TO 19                                            CNI24600
C-----POPLE TRICK: PREVENT OSCILLATING SOLUTIONS. BY AVERAGING----------CNI24610
C     DENSITY MATRICES OF 2 PREVIOUS CYCLES (R.SPRECHER, MEMPHIS        CNI24620
C-----STATE UNIVERSITY)-------------------------------------------------CNI24630
      DO 12 I=1,N                                                       CNI24640
         DO 11 J=1,N                                                    CNI24650
            BNEW=(B(I,J)+BOLD(I,J))/2.D0                                CNI24660
            BOLD(I,J)=B(I,J)                                            CNI24670
            B(I,J)=BNEW                                                 CNI24680
   11    CONTINUE                                                       CNI24690
   12 CONTINUE                                                          CNI24700
C-----COPY CORE HAMILTONIAN (FROM Q AND UPPER TRIANGLE OF A)            CNI24710
C-----TO LOWER TRIANGLE OF A                                            CNI24720
   19 DO 21 I=1,N                                                       CNI24730
         A(I,I)=Q(I)                                                    CNI24740
         DO 20 J=I,N                                                    CNI24750
            A(J,I)=A(I,J)                                               CNI24760
   20    CONTINUE                                                       CNI24770
   21 CONTINUE                                                          CNI24780
C-----CONSTRUCT FOCK MATRIX, DIAGONAL TERMS-----------------------------CNI24790
      DO 31 I=1,N                                                       CNI24800
         II=IGAM(I)                                                     CNI24810
         A(I,I)=A(I,I)-B(I,I)*G(II,II)*0.5D0                            CNI24820
         DO 30 K=1,N                                                    CNI24830
            JJ=IGAM(K)                                                  CNI24840
            A(I,I)=A(I,I)+B(K,K)*G(II,JJ)                               CNI24850
   30    CONTINUE                                                       CNI24860
   31 CONTINUE                                                          CNI24870
C-----CONSTRUCT FOCK MATRIX IN LOWER TRIANGLE OF A                      CNI24880
      NM=N-1                                                            CNI24890
      DO 41 I=1,NM                                                      CNI24900
         II=IGAM(I)                                                     CNI24910
         LL=I+1                                                         CNI24920
         DO 40 J=LL,N                                                   CNI24930
            JJ=IGAM(J)                                                  CNI24940
            A(J,I)=A(J,I)-B(J,I)*G(II,JJ)*0.5D0                         CNI24950
   40    CONTINUE                                                       CNI24960
   41 CONTINUE                                                          CNI24970
C-----INDO MODIFICATION-------------------------------------------------CNI24980
      IF (OPTION.EQ.CNDO) GO TO 90                                      CNI24990
   50 DO 80 II=1,NATOMS                                                 CNI25000
         K=IATNO(II)                                                    CNI25010
         I=LIML(II)                                                     CNI25020
         IF (K.EQ.1) GO TO 80                                           CNI25030
   60    PAA=B(I,I)+B(I+1,I+1)+B(I+2,I+2)+B(I+3,I+3)                    CNI25040
         A(I,I)=A(I,I)-(PAA-B(I,I)) *G1(K)/6.D0                         CNI25050
         DO 70 J=1,3                                                    CNI25060
            A(I+J,I+J)=A(I+J,I+J)-B(I,I)*G1(K)/6.D0-(PAA-B(I,I))*7.D0*  CNI25070
     1      F2(K)/50.D0+B(I+J,I+J)*11.D0*F2(K)/50.D0                    CNI25080
            A(I+J,I)=A(I+J,I)+B(I,I+J)*G1(K)/2.D0                       CNI25090
   70    CONTINUE                                                       CNI25100
         I1=I+1                                                         CNI25110
         I2=I+2                                                         CNI25120
         I3=I+3                                                         CNI25130
         A(I2,I1)=A(I2,I1)+B(I2,I1)*11.D0*F2(K)/50.D0                   CNI25140
         A(I3,I1)=A(I3,I1)+B(I3,I1)*11.D0*F2(K)/50.D0                   CNI25150
         A(I3,I2)=A(I3,I2)+B(I3,I2)*11.D0*F2(K)/50.D0                   CNI25160
   80 CONTINUE                                                          CNI25170
   90 CONTINUE                                                          CNI25180
C-----CARRY OUT SUGGESTION OF RICHARD SPRECHER--------------------------CNI25190
C     PREVENT REPULSION OF CONVERGENCE BY DEGENERATE EIGENVALUES,       CNI25200
C-----BY ADDING A SMALL RANDOM NUMBER TO FOCK MATRIX--------------------CNI25210
      IF (IRN.EQ.0.OR.IPOLAR.EQ.0.OR.CONVRG.GT.1.D-05) GO TO 93         CNI25220
      DO 92 I=1,N                                                       CNI25230
         DO 91 J=I,N                                                    CNI25240
C ***                                                                   CNI25250
            CALL RANNUM(IX,IY,YLF)                                      CNI25260
            IX=IY                                                       CNI25270
            A(J,I)=A(J,I)+YLF*CONVRG*0.1D-03                            CNI25280
   91    CONTINUE                                                       CNI25290
   92 CONTINUE                                                          CNI25300
   93 CONTINUE                                                          CNI25310
C-----COMPUTE TOTAL ELECTRONIC ENERGY                                   CNI25320
      DO 100 I=1,N                                                      CNI25330
         ENERGY=ENERGY+0.5D0*B(I,I)*(A(I,I)+Q(I))                       CNI25340
  100 CONTINUE                                                          CNI25350
      DO 105 I=1,NM                                                     CNI25360
         LL=I+1                                                         CNI25370
         DO 104 J=LL,N                                                  CNI25380
            ENERGY=ENERGY+B(I,J)*(A(I,J)+A(J,I))                        CNI25390
  104    CONTINUE                                                       CNI25400
  105 CONTINUE                                                          CNI25410
      IF (NPULAY.LE.1) GO TO 530                                        CNI25420
C-----PULAY TRICK: SET UP AND STORE CURRENT FOCK MATRIX-----------------CNI25430
      DO 420 I=1,N                                                      CNI25440
        DO 410 J=I,N                                                    CNI25450
          FOLD(J,I,KPUL)=A(J,I)                                         CNI25460
          FOLD(I,J,KPUL)=A(J,I)                                         CNI25470
  410   CONTINUE                                                        CNI25480
  420 CONTINUE                                                          CNI25490
C-----CONSTRUCT, STORE CURRENT ERROR MATRIX-----------------------------CNI25500
C     AND GET MAXIMUM ERROR ELEMENT                                     CNI25510
C     PULERR = FOCK MATRIX * DENSITY MATRIX MINUS                       CNI25520
C-----        DENSITY MATRIX * FOCK MATRIX------------------------------CNI25530
      EMAX=0.0D0                                                        CNI25540
      DO 450 I=1,N                                                      CNI25550
        DO 440 J=1,N                                                    CNI25560
          SUM=0.0D0                                                     CNI25570
          DO 430 K=1,N                                                  CNI25580
            SUM=SUM+FOLD(I,K,KPUL)*B(K,J)-B(I,K)*FOLD(K,J,KPUL)         CNI25590
  430     CONTINUE                                                      CNI25600
          PULERR(I,J,KPUL)=SUM                                          CNI25610
          PTEMP=DABS(PULERR(I,J,KPUL))                                  CNI25620
          IF (PTEMP.GT.EMAX) EMAX=PTEMP                                 CNI25630
  440   CONTINUE                                                        CNI25640
  450 CONTINUE                                                          CNI25650
C-----CONSTRUCT PULAY MATRIX. FIRST SHIFT OLD ELEMENTS UP AND OVER------CNI25660
      DO 457 I=3,6                                                      CNI25680
        II=I-1                                                          CNI25690
        DO 453 J=3,6                                                    CNI25700
          JJ=J-1                                                        CNI25710
          PULAY(II,JJ)=PULAY(I,J)                                       CNI25720
  453   CONTINUE                                                        CNI25730
  457 CONTINUE                                                          CNI25740
C-----CONSTRUCT CURRENT TRACES FOR PULAY--------------------------------CNI25750
C     THESE ARE THE TRACES OF THE CURRENT ERROR MATRIX                  CNI25760
C-----TIMES THE TRANSPOSES OF THE OTHER ERROR MATRICES------------------CNI25770
      IC=IDIS(5)                                                        CNI25780
      DO 480 K=1,5                                                      CNI25790
        II=IDIS(K)                                                      CNI25800
C-------CORRECT LOCATION FOR THIS TRACE IN PULAY------------------------CNI25810
        KK=K+1                                                          CNI25820
        TRACE=0.0D0                                                     CNI25830
        DO 470 I=1,N                                                    CNI25840
          DO 460 J=1,N                                                  CNI25850
            TRACE=TRACE+PULERR(I,J,IC)*PULERR(I,J,II)                   CNI25860
  460     CONTINUE                                                      CNI25870
  470   CONTINUE                                                        CNI25880
        PULAY(KK,6)=TRACE                                               CNI25890
        PULAY(6,KK)=TRACE                                               CNI25900
  480 CONTINUE                                                          CNI25910
C-----CHECK ENTRY CONDITIONS FOR PULAY TRICK----------------------------CNI25920
C     SET UP THRESHOLD VALUES FOR STARTING/STOPPING                     CNI25930
C-----PULAY TRICK (ENTRANCE REQUIREMENTS)-------------------------------CNI25940
      CHTH1=0.1D0*DABS(ENERGY)                                          CNI25950
      IF (IFIELD.EQ.0) WRITE(LOUTPT,810) EMAX                           CNI25960
  810 FORMAT('         EMAX=',D17.8)                                    CNI25970
      IF (ICYCLE.LT.5) GO TO 511                                        CNI25980
      IF ((EMAX.GT.CHTH1).OR.(EMAX.LT.CONVRG)) GO TO 530                CNI25990
      IF (IFIELD.EQ.0) WRITE (LOUTPT,820)                               CNI26000
  820 FORMAT(' PULAY DIIS ENTERED')                                     CNI26010
C *** FIND PULAY PARAMETERS---------------------------------------------CNI26020
      CALL SOLPUL (PULAY,PLAM)                                          CNI26040
      SUMPLA=PLAM(2)+PLAM(3)+PLAM(4)+PLAM(5)+PLAM(6)                    CNI26050
      IF (IFIELD.EQ.0) WRITE (LOUTPT,830) (PLAM(I),I=1,6),SUMPLA        CNI26060
  830 FORMAT('    PLAM = ',6D13.6,' SUM=',D13.6)                        CNI26070
C-----CREATE NEW HYBRID FOCK MATRIX-------------------------------------CNI26080
      DO 520 I=1,N                                                      CNI26090
        DO 510 J=I,N                                                    CNI26100
          A(J,I)=0.0D0                                                  CNI26110
          DO 500 K=2,6                                                  CNI26120
            KK=IDIS(K-1)                                                CNI26130
            A(J,I)=A(J,I)+PLAM(K)*FOLD(J,I,KK)                          CNI26140
  500     CONTINUE                                                      CNI26150
  510   CONTINUE                                                        CNI26160
  520 CONTINUE                                                          CNI26170
C-----ROTATE IDIS COUNTER FOR NEXT CYCLE--------------------------------CNI26180
  511 DO 406 I=1,5                                                      CNI26190
        IDIS(I)=IDIS(I)+1                                               CNI26200
        KTEMP=IDIS(I)                                                   CNI26210
        IF (KTEMP.GT.5) IDIS(I)=IDIS(I)-5                               CNI26220
  406 CONTINUE                                                          CNI26230
  530 CONTINUE                                                          CNI26240
C-----END OF PULAY TRICK------------------------------------------------CNI26250
      IF (ISHIFT.EQ.0) GO TO 108                                        CNI26260
      IF (ICYCLE.EQ.1) GO TO 108                                        CNI26270
C-----TO EASE CONVERGENCE, USE SAUNDERS VIRTUAL LEVEL SHIFTER-----------CNI26280
C     ON FOCK MATRIX (LOWER TRIANGLE OF A)                              CNI26290
C-----(G.PONGOR, CHEM.PHYS. LETTERS 24:603(1974))-----------------------CNI26300
      DO 107 I=1,N                                                      CNI26310
         DO 106 J=I,N                                                   CNI26320
            DELKRO=0.0D0                                                CNI26330
            IF (I.EQ.J) DELKRO=1.0D0                                    CNI26340
            A(J,I)=A(J,I)+SHIFTR*(DELKRO-0.5D0*B(J,I))                  CNI26350
  106    CONTINUE                                                       CNI26360
  107 CONTINUE                                                          CNI26370
  108 CONTINUE                                                          CNI26380
      SHIFT=ENERGY-OLDENG                                               CNI26390
C-----2020.07.26. ISFTURN OFF CYCLE ENERGY REPORT (TO SHORTEN OUTPUT)------CNI26391
C     WRITE (LOUTPT,110) ICYCLE,ENERGY,SHIFT                            CNI26400
C-----2020.07.26.CYCLE ENERGY REPORT HAS BEEN TURNED OFF ---------------CNI25410
  110 FORMAT(' CYCLE ',I3,' EL.ENERGY ',D17.10,                         CNI26410
     1' A.U.; SHIFT ',D17.10)                                           CNI26420
      IF (DABS(ENERGY).GT.1.D30) GO TO 901                              CNI26430
      IF (IPOLAR.GE.1.AND.IDMOK.EQ.0) GO TO 150                         CNI26440
C-----IS CONVERGENCE OK. IF SO, SET ICYCLE=NCYCLE+1 AND QUIT------------CNI26450
      IF (IPOLAR.EQ.0.AND.DABS(ENERGY-OLDENG).GE.CONVRG) GO TO 150      CNI26460
      IF (ICYCLE.LT.5) GO TO 150                                        CNI26470
C-----CONVERGENCE HAS BEEN ACHIEVED, IN ENERGY -------------------------CNI26480
  120 ICICLE=ICYCLE                                                     CNI26490
      ICYCLE=NCYCLE+1                                                   CNI26500
  130 IF (IPOLAR.EQ.0) WRITE (LOUTPT,140) ICICLE,ENERGY,SHIFT           CNI26510
  140 FORMAT(' ENERGY SATISFIED AFTER CYCLE ',I3/                       CNI26520
     1' ENERGY=',D20.10,' SHIFT=',D20.10)                               CNI26530
      IF (IPOLAR.GE.1.AND.IFIELD.EQ.0) WRITE (LOUTPT,141) ICICLE,       CNI26540
     1ENERGY,SHIFT,IMX,JMX,DIFFOU                                       CNI26550
  141 FORMAT (' DENSITY MATRIX SATISFIED AFTER CYCLE ',I3/              CNI26560
     1' ENERGY ',D20.10/' SHIFT= ',D20.10/' MAX.DENS.MX SHIFT',         CNI26570
     2' (',I4,',',I4,')=',D20.10)                                       CNI26580
      IF (IPOLAR.GE.1.AND.IFIELD.GT.0) WRITE (LOUTPT,142) ACKACK,ICICLE,CNI26590
     1ENERGY,SHIFT,IMX,JMX,DIFFOU                                       CNI26600
  142 FORMAT ('1 ELECTRIC FIELD ALONG THE ',A1,' AXIS'///               CNI26610
     1' DENSITY MATRIX SATISFIED AFTER CYCLE ',I3/                      CNI26620
     2' ENERGY=',D20.10,' SHIFT=',D20.10,' MAX.DENS.MX.SHIFT',          CNI26630
     3' (',I4,',',I4,')=',D20.10)                                       CNI26640
      GO TO 170                                                         CNI26650
  150 CONTINUE                                                          CNI26660
  160 OLDENG=ENERGY                                                     CNI26670
  170 CONTINUE                                                          CNI26680
      IF (ICYCLE.LE.NCYCLE) GO TO 210                                   CNI26690
      IF (IFIELD.GT.0) GO TO 210                                        CNI26700
C-----SYMMETRIZE FOCK MATRIX F FOR PRINTING (MATRIX A) AFTER LAST CYCLE CNI26710
  180 DO 190 I=1,N                                                      CNI26720
         DO 185 J=I,N                                                   CNI26730
            A(I,J)=A(J,I)                                               CNI26740
  185    CONTINUE                                                       CNI26750
  190 CONTINUE                                                          CNI26760
      IF (IFIELD.GT.0) GO TO 210                                        CNI26770
      WRITE (LOUTPT,200)                                                CNI26780
  200 FORMAT(27H HARTREE-FOCK ENERGY MATRIX)                            CNI26790
C *** PRINT HARTREE-FOCK ENERGY MATRIX----------------------------------CNI26800
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI26810
  210 CONTINUE                                                          CNI26820
C-----DIAGONALIZE (EVERY CYCLE, AND AT END OF LAST CYCLE)---------------CNI26830
C     INPUT  : FOCK MATRIX A: LOWER TRIANGLE ONLY IS USED, AND IS       CNI26840
C              DESTROYED. UPPER TRIANGLE OF A IS PRESERVED.             CNI26850
C              ANYWAY, CORE HAMILTONIAN IS IN UPPER TRIANGLE OF A...    CNI26860
C     OUTPUT : EIGVAL: EIGENVALUES IN ASCENDING ALGEBRAIC ORDER         CNI26870
C *** ---------B: EIGENVECTORS: COLUMN VECTORS.-------------------------CNI26880
      CALL EIGN (N,RHO,A,B,XXX,XX6,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,  CNI26885
     1IORD)                                                             CNI26900
C-----IF SILVERSTONE-SAUNDERS LEVEL SHIFTING WAS DONE, UNDO THE DAMAGE. CNI26910
      IF (ISHIFT.EQ.0) GO TO 215                                        CNI26920
      IF (ICYCLE.EQ.1) GO TO 215                                        CNI26930
      NLUMO=NOCCA+1                                                     CNI26940
      DO 214 I=NLUMO,N                                                  CNI26950
         EIGVAL(I)=EIGVAL(I)-SHIFTR                                     CNI26960
  214 CONTINUE                                                          CNI26970
  215 CONTINUE                                                          CNI26980
      IF (ICYCLE.LE.NCYCLE) GO TO 240                                   CNI26990
C-----PRINT EIGENVALUES AND EIGENVECTORS AFTER LAST CYCLE---------------CNI27000
      DO 219 I=1,N                                                      CNI27010
         DO 218 J=1,N                                                   CNI27020
            BOLD(I,J)=B(I,J)                                            CNI27030
  218    CONTINUE                                                       CNI27040
  219 CONTINUE                                                          CNI27050
  220 IF (IFIELD.GT.0) GO TO 240                                        CNI27060
      WRITE (LOUTPT,230)                                                CNI27070
  230 FORMAT(/1X,28HEIGENVALUES AND EIGENVECTORS)                       CNI27080
C *** PRINT EIGENVALUES AND EIGENVECTORS--------------------------------CNI27090
      CALL SCFOUT (1,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                   CNI27100
C *** CNDO/ON: ORTHONORMALIZE THE MOS A LA ROALD HOFFMAN----------------CNI27110
      IF (IHOFMN.GE.2) CALL ON (QQ,B,C,XX5,XX6,XX7,EIGVAL,XX9,          CNI27130
     1G,BOLD,ALPH2F,ATLCHF,XXY,XXZ,IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,   CNI27135
     2IPOSV,IVPOS,IORD)                                                 CNI27140
      IF (IHOFMN.GT.1) GO TO 292                                        CNI27150
  240 CONTINUE                                                          CNI27160
C-----EIGENVECTORS (IN B) ARE CONVERTED INTO DENSITY MATRIX (IN B)      CNI27170
      DO 280 I=1,N                                                      CNI27180
         DO 260 J=I,N                                                   CNI27190
            XXX(J)=0.0D0                                                CNI27200
            DO 250 K=1,NOCCA                                            CNI27210
               XXX(J)=XXX(J)+B(I,K)*B(J,K)*2.0D0                        CNI27220
  250       CONTINUE                                                    CNI27230
  260    CONTINUE                                                       CNI27240
         DO 270 J=I,N                                                   CNI27250
            B(I,J)= XXX(J)                                              CNI27260
  270    CONTINUE                                                       CNI27270
  280 CONTINUE                                                          CNI27280
      IERR=0                                                            CNI27285
      DO 291 I=1,N                                                      CNI27290
         DO 290 J=I,N                                                   CNI27300
            B(J,I)=B(I,J)                                               CNI27310
            IF (DABS(B(I,J)).GT.2.000001D0) IERR=1                      CNI27315
  290    CONTINUE                                                       CNI27320
  291 CONTINUE                                                          CNI27330
      IF (IERR.EQ.1) GO TO 903                                          CNI27335
  292 CONTINUE                                                          CNI27340
C-----IPOLAR=0: LOOP TO NEXT CYCLE--------------------------------------CNI27350
      IF (IPOLAR.EQ.0.AND.ICYCLE.LE.NCYCLE) GO TO 10                    CNI27360
      IF (IDMOK.EQ.1.AND.ICYCLE.GT.NCYCLE) GO TO 295                    CNI27370
C-----IPOLAR=1: CONVERGENCE TEST ON DENSITY MATRIX----------------------CNI27380
      IDMOK=0                                                           CNI27390
      DIFFMX=-1.D05                                                     CNI27400
      IMX=0                                                             CNI27410
      JMX=0                                                             CNI27420
      DIFFOU=-22.D0                                                     CNI27430
      DO 294 I=1,N                                                      CNI27440
         DO 293 J=1,N                                                   CNI27450
            DIFFR=BOLD(I,J)-B(I,J)                                      CNI27460
            DIFF=DABS(DIFFR)                                            CNI27470
            IF (DIFF.LE.DIFFMX) GO TO 293                               CNI27480
            DIFFMX=DIFF                                                 CNI27490
            DIFFOU=DIFFR                                                CNI27500
            IMX=I                                                       CNI27510
            JMX=J                                                       CNI27520
  293    CONTINUE                                                       CNI27530
  294 CONTINUE                                                          CNI27540
  295 IF (DIFFMX.LE.CONVRG) IDMOK=1                                     CNI27550
      IF (IFIELD.GT.0) GO TO 297                                        CNI27560
C---- DENSITY MATRIX HAS NOT CONVERGED. LOOP BACK...                    CNI27570
  297 IF (IPOLAR.GE.1.AND.ICYCLE.LE.NCYCLE) GO TO 10                    CNI27580
  300 CONTINUE                                                          CNI27590
      IF (IPOLAR.EQ.0) GO TO 999                                        CNI27600
C-----RESTORE HAMILTONIAN FOR NEXT POLARIZABILITY CALCULATION           CNI27610
C-----(AT END OF SCF CYCLES)                                            CNI27620
      DO 320 I=1,N                                                      CNI27630
         A(I,I)=Q(I)                                                    CNI27640
         DO 310 J=I,N                                                   CNI27650
C---------- TRANSFER CORE HAMILTONIAN TO LOWER TRIANGLE                 CNI27660
            A(J,I)=A(I,J)                                               CNI27670
  310    CONTINUE                                                       CNI27680
  320 CONTINUE                                                          CNI27690
      GO TO 999                                                         CNI27700
C-----DIAGNOSTIC ERROR MESSAGES SECTION BEGINS                          CNI27710
  901 WRITE (LOUTPT,902)                                                CNI27720
  902 FORMAT (' RUN ABORTED. ELECTRONIC ENERGY BLEW UP IN',             CNI27730
     1' CYCLE. WE QUIT')                                                CNI27740
      STOP                                                              CNI27750
  903 WRITE (LOUTPT,904) ((I,J,B(I,J),J=1,N),I=1,N)                     CNI27752
  904 FORMAT (' RUN ABORTED. DENSITY MATRIX BLEW UP'/                   CNI27754
     1(' B(',I4,',',I4,')=',D20.10))                                    CNI27756
      STOP                                                              CNI27758
  999 RETURN                                                            CNI27760
CE.16 END OF SCFCLO (CNDOP)---------------------------------------------CNI27770
      END                                                               CNI27780
      SUBROUTINE CPRINT (A,B,C,XXX,EIGVAL,IATNO,ICORE,IOR2AT,           CNI27790
     1LIMU,LIML,ITITLE,ENERGY)                                          CNI27800
CB.17 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI27810
C     CALLED BY: MAIN  (03)                                             CNI27820
C     CALLS    : SCFOUT(23)                                             CNI27830
C-----PRINTS DENSITY MATRIX, TOTAL ENERGY, CHARGES (CLOSED-SHELL)       CNI27840
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI27850
      CHARACTER*4 ITITOL,ITITLE,EL                                      CNI27855
      INTEGER OPTION,CNDO,ANI,UL                                        CNI27990
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI27860
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI27870
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI27880
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI27890
      COMMON/INFOX/NATOMS,II1(2),N,II2(3),LIMG,IPREC                    CNI27910
      COMMON/CHOICE/OPTION,II3(2),CNDO,II4(3)                           CNI27920
      COMMON/AUXINT/XX1(34)                                             CNI04730
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI27970
     1RKAPPA(35,6)                                                      CNI27980
      DIMENSION A(N,N),B(N,N),C(NATOMS,3),XXX(NATOMS),EIGVAL(N),        CNI27940
     1IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),               CNI27950
     2LIML(NATOMS),ITITLE(NATOMS)                                       CNI27960
      K=NATOMS-1                                                        CNI28000
      IF (IFIELD.GT.0) GO TO 456                                        CNI28010
      WRITE (LOUTPT,40)                                                 CNI28020
   40 FORMAT(1X,15H DENSITY MATRIX)                                     CNI28030
C *** PRINT DENSITY MATRIX                                              CNI28040
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI28050
  456 CONTINUE                                                          CNI28070
      DO 50 I=1,K                                                       CNI28080
         L=I+1                                                          CNI28090
         DO 50 J=L,NATOMS                                               CNI28100
            RAD=DSQRT((C(I,1)-C(J,1))**2+(C(I,2)-C(J,2))**2             CNI28110
     1      +(C(I,3)-C(J,3))**2)                                        CNI28120
            ENERGY=ENERGY+(DBLE(FLOAT(ICORE(I)))*                       CNI28130
     1      DBLE(FLOAT(ICORE(J))))/RAD                                  CNI28130
   50 CONTINUE                                                          CNI28135
      WRITE (LOUTPT,60) ENERGY                                          CNI28140
   60 FORMAT(/' TOTAL ENERGY =',D24.10,' ATOMIC UNITS (HARTREES)')      CNI28150
      DO 70 I=1,NATOMS                                                  CNI28160
         ANI=IATNO(I)                                                   CNI28170
         ENERGY=ENERGY-ATENG(ANI)                                       CNI28180
   70 CONTINUE                                                          CNI28185
      WRITE (LOUTPT,80) ENERGY                                          CNI28190
   80 FORMAT(/" BINDING ENERGY= ",F16.10,' ATOMIC UNITS (HARTREES)'/    CNI28200
     1/ ' ATOM           VALENCE          NET           ATOM '          CNI28210
     2/ ' NO.     NAME    CHARGE          CHARGE        TITLE '/' ____',CNI28210
     3'    ____   _______          ___________     ____________ ')      CNI28220
      DO 110 I=1,NATOMS                                                 CNI28230
         TCHG = 0.D0                                                    CNI28240
         LL=LIML(I)                                                     CNI28250
         UL=LIMU(I)                                                     CNI28260
         DO 90 J=LL,UL                                                  CNI28270
            TCHG = TCHG+B(J,J)                                          CNI28280
   90    CONTINUE                                                       CNI28285
         ANI=IATNO(I)                                                   CNI28290
         CHGNET=ICORE(I)-TCHG                                           CNI28300
         WRITE (LOUTPT,100) I,EL(ANI),TCHG,CHGNET,ITITLE(I)             CNI28310
  100    FORMAT(I3,A4,13X,F7.4,F20.6,4X,A4)                             CNI28320
         XXX(I)=TCHG                                                    CNI28330
  110 CONTINUE                                                          CNI28340
      WRITE (LOUTPT,120)                                                CNI28325
  120 FORMAT (' ____   ____   _______          _________  ____________')CNI28326
      RETURN                                                            CNI28350
CE.17 END OF CPRINT (CNDOP)---------------------------------------------CNI28360
      END                                                               CNI28370
      SUBROUTINE DIPOLE (A,B,BOLD,C,XXX,EIGVAL,PDIAG,ATLCHG,ATLMUF,     CNI28380
     1ATLCHF,COORSM,HYBSAV,IATNO,ICORE,IOR2AT,LIMU,LIML,IBOND,ISYMOP,   CNI28390
     2ITITLE,ITABLE,IBD,ITSDUN,ICLOSD,ENERGY)                           CNI28400
CB.18 LAST CHANGE 12 OCT 2020 (CNDOP)-----------------------------------CNI28410
C     CALLED BY: MAIN  (03)                                             CNI28420
C     CALLS    : DIAGON(29),EIG3  (27),WACOS (38)                       CNI04150
C-----DIPOLE MOMENTS AND POLARIZABILITIES------------------------------ CNI28440
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI28450
      CHARACTER*4 ITITOL,ITITLE,ITIT,EL                                 CNI28455
      INTEGER OPTION,CNDO,ANI,UL                                        CNI28657
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI28460
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI28470
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI28480
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI28490
      COMMON/INFOX/NATOMS,II1(2),N,II2(3),LIMG,IPREC                    CNI28510
      COMMON/CHOICE/OPTION,II3(2),CNDO,II4(3)                           CNI28520
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI28521
      COMMON/FIXIT/FUDGE,IBIM                                           CNI28530
      DIMENSION A(N,N),B(N,N),BOLD(N,N),C(NATOMS,3),XXX(NATOMS),        CNI28540
     1EIGVAL(N),PDIAG(N),ATLCHG(NATOMS,3),ATLMUF(NATOMS,3,3),           CNI28580
     2ATLCHF(NATOMS,3),COORSM(NATOMS),HYBSAV(NATOMS,3,3),               CNI28590
     3IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),  CNI28592
     4IBOND(NATOMS),ISYMOP(NATOMS),ITITLE(NATOMS),ITABLE(NATOMS,NATOMS),CNI28593
     5IBD(NATOMS*NATOMS),ITSDUN(NATOMS),ICLOSD(NATOMS)                  CNI28594
      DIMENSION ATENG(35)                                               CNI28600
      DIMENSION CSTORE(3),RINGSM(3),ALFSAV(3,3),BETHAN(3,3),BETH(3,3),  CNI28610
     1ALFSUM(3,3),ALFACH(3,3),ALPHAS(3,3),ALFATM(3,3),ALFSYM(3,3),      CNI28620
     2ATDIPL(3),DIPM(3),ROOTS(3),DMCH(3),ATCOS(3),ONOMA(3),COSR(3),     CNI28630
     3ALASYM(6),DMHYB(3),DPM(3),DM(3),DMSP(3),DMPD(3),INEXT(20),        CNI28640
     4ALKEEP(3,3),ALTOTL(3,3),ALRING(3,3),ALRUNG(3,3),ALSAVE(3,3),      CNI28645
     5BOB(3,3),ALCHEK(3,3),ALGLOB(3,3),ALATOM(3,3),ALBOND(3,3)          CNI28648

C-----STORAGE MATRICES (3 BY 3 AND ALSO NATOMS BY 3) -------------------CNI28652
C     ATLCHF: (NATOMS BY 3)                                             CNI28653
C     ATLCHG: (NATOMS BY 3)                                             CNI28654
C     ATLHYZ: (NATOMS BY 3)                                             CNI28655
C     ATLHYF: (NATOMS BY 3)                                             CNI28656
C     ATLMUF: (NATOMS BY 3 BY 3)                                        CNI28657
C     HYBSAV: (NATOMS BY 3 BY 3)                                        CNI28658
C     ALFSUM: (3 BY 3)                                                  CNI28659
C     ALFACH: (3 BY 3)                                                  CNI28660
C     ATLCHG: (3 BY 3)                                    M              CNI28661
C     ALATOM: (3 BY 3) IATOM=1 AIM (ATOM-IN-MOLECULE POLARIZABILITY)    CNI
C     ALBOND: (3 BY 3) IATOM=0 BIM (BOND-IN-MOLECULE POLARIZABILITY)    CNI
C-----SUMMARIZING MATRICES:---------------------------------------------CNI28662
C     ALKEEP: (3 BY 3) MOLECULAR POLARIZABILITY TENSOR                  CNI28663
C     ALSAVE: (3 BY 3) IATOM=1 SUM OF AIM (ATOM-IN-MOLECULE POLARIZAB.) CNI28664
C     ALTOTL: (3 BY 3) IATOM=0 SUM OF BIM (BOND-IN-MOLECULE POLARIZAB.) CNI28665
C     ALRING: (3 BY 3) SIMPLE CLOSED RINGS POLARIZABILITY TENSOR        CNI28666
C     ALRUNG: (3 BY 3) COMPLICATED RINGS POLARIZABILITY TENSOR          CNI28667
C     ALGLOB: (3 BY 3) =ALSAVE+ALTOTL+ALRING+ALRUNG                     CNI28668
C     ALCHEK: (3 BY 3) =ALGLOB-ALKEEP: CHECKSUM CHECKER                 CNI28669
C-----SPECIALIZED MATRICES FOR SUBROUTINE DIAGON:-----------------------CNI28669
C     ALFATM: (3 BY 3) INPUT                                            CNI28670
C     ALFSYM: (3 BY 3) FOR   SYMMETRIC PART                             CNI28671
C     ALFASM: (3 BY 3) FOR UNSYMMETRIC PART                             CNI28672
C-----CLOSED-SHELL CORE POLARIZABILITY SELECTION BEGINS-----------------CNI28673
C     USE THE EXPERIMENTAL POLARIZABILITY 0.205042 ANGSTROMS**3 OF HE   CNI28674
C     GUGAN & MICHEL MOL.PHYS.39:783 (1980) FOR LI TO NE (ELEMWNTS 3-10)CNI28675
C     USE THE EXPERIMENTAL POLARIZABILITY 0.39432 ANGSTROMS**3 OF NEON  CNI28676
C     GAISER & FELLMUTH EUROPHYS.LETT.90:63002(2010) FOR NA TO AR(11-18)CNI28677
C     USE THE EXPERIMENTAL POLARIZABILITY 1.6419 ANGSTROMS**3 OF ARGON  CNI28678
C-----ORCUTT & COLE, J.CHEM.PHYS.46:697(1967) FOR K TO KR (19 TO 35)--- CNI28679
      DATA ALPHAT /2*0.0, 8*0.205042, 8*0.39432, 17*1.6419/             CNI28680
C-----CLOSED-SHELL CORE POLARIZABILITY SELECTION ENDS-------------------CNI28681
      REAL DMHYB                                                        CNI28682
      LOGICAL ONOMA,EXX,WHY,ZEE                                         CNI28683
      DATA EXX,WHY,ZEE/1HX,1HY,1HZ/                                     CNI28684
      ONOMA(1)=EXX                                                      CNI28690
      ONOMA(2)=WHY                                                      CNI28700
      ONOMA(3)=ZEE                                                      CNI28710
C-----NOTE THAT:--------------------------------------------------------CNI28720
C     0.52917715D0=14.39978445/27.211652                                CNI28730
C     NOTE ALSO THAT THE FACTOR:                                        CNI28740
C     2.541770146=0.52917715*4.803250=BOHR*DEBYE                        CNI28750
C     WILL CONVERT DIPOLE MOMENTS FROM ELECTRONS*BOHR TO                CNI28760
C-----4.80325 DEBYES=1.0 E*ANGSTROM-------------------------------------CNI28770
      LOUT=LOUTPT                                                       CNI28780
      LAUX=LAUXOU                                                       CNI28790
C-----NEGATE THE ELECTRIC FIELD (SO THAT ALPHAS ARE POSITIVE)           CNI28800
C-----AND CONVERT IT FROM E/BOHR**2 TO E/ANGSTROM**2                    CNI28810
      FIELD=-FIELD/BOHR**2                                              CNI28820
C-----INITIALIZE THE DIPOLE MOMENT AND HYBRID MOMENT ARRAYS-------------CNI28825
      DO 10 K=1,3                                                       CNI28830
         DM(K)=0.0D0                                                    CNI28840
         DMSP(K)=0.0D0                                                  CNI28850
         DMPD(K)=0.0D0                                                  CNI28860
   10 CONTINUE                                                          CNI28870
C07---READ-IN DATA CARDS TYPE 7: PATCH INPUT FOR IPIECE.GT.0 RUN--------CNI28880
      IF (IPIECE.GE.11) READ (LPIECE,11) (DIPM(K),DMCH(K),K=1,3),       CNI28890
     1((ATLCHF(J,K),ATLCHG(J,K),K=1,3),J=1,NATOMS)                      CNI28900
   11 FORMAT (D25.16)                                                   CNI28910
      IF (IPIECE.GE.12) READ (LPIECE,11)                                CNI28920
     1(ATLCHF(J,1),(ATLMUF(J,1,K),K=1,3),J=1,NATOMS),                   CNI28930
     2(ALFSUM(1,K),ALFACH(1,K),K=1,3)                                   CNI28940
      IF (IPIECE.EQ.13) READ (LPIECE,11)                                CNI28950
     1(ATLCHF(J,2),(ATLMUF(J,2,K),K=1,3),J=1,NATOMS),                   CNI28960
     2(ALFSUM(2,K),ALFACH(2,K),K=1,3)                                   CNI28970
C-----START EXACT DIPOLE MOMENT CALCULATIONS----------------------------CNI28990
C-----PROCEED WITH POPLE-TYPE CALCULATION OF MU(CHARGE)+MU(HYBRID)------CNI29000
      IF (IFIELD.EQ.0) WRITE (LOUTPT,20)                                CNI29010
   20 FORMAT (/'0ATOM ELECTRIC DIPOLE MOMENT  COMPONENTS:')             CNI29020
      IF (IFIELD.GT.0) WRITE (LOUTPT,21) ONOMA(IFIELD)                  CNI29030
   21 FORMAT (/'0ATOM STATIC ELECTRIC DIPOLE POLARIZABILITY COMPONENTS',CNI29040
     1' FIELD ALONG ',A1)                                               CNI29050
C-----HUGE LOOP OVER ALL ATOMS BEGINS-----------------------------------CNI29855
      DO 150 J=1,NATOMS                                                 CNI29060
         DO 30 K=1,3                                                    CNI29070
            ATDIPL(K)=0.0D0                                             CNI29080
   30    CONTINUE                                                       CNI29090
C--------SELECT ALGORITHMS FOR HYBRID MOMENT BY ATOMIC NUMBER-----------CNI29095
         IF (IATNO(J).LE. 2) GO TO 85                                   CNI29100
         IF (IATNO(J).LE.10) GO TO 70                                   CNI29110
         IF (IATNO(J).LE.18) GO TO 50                                   CNI29120
         IF (IATNO(J).LE.35) GO TO 40                                   CNI29130
C--------MU(HYBRID) FOR K,CA,SC-ZN,GE,AS,SE,BR -------------------------CNI29140
   40    SLTR1=(.65D0*DBLE(FLOAT(IATNO(J)))-15.15D0)/3.7D0              CNI29150
         FACTOR=BOHR*DEBYE*9.D0/(DSQRT(5.D0)*SLTR1)                     CNI29160
         INDEX=LIML(J)                                                  CNI29170
         DO 41 K=1,3                                                    CNI29180
C-----------COMPUTE MU(HYBRID) SP FOR K, CA, SC-ZN, GE, AS, SE, BR------CNI29185
            DSP=-B(INDEX,INDEX+K)*                                      CNI29190
     1      BOHR*DEBYE*9.D0/(SLTR1*DSQRT(3.0D0))                        CNI29200
C-----------13.2074251D0=0.52917715*4.803250*9/SQRT(3)------------------CNI29210
C                       =BOHR    *DEBYE  *9/SQRT(3)                     CNI29220
C-----------NOW DSP AND ATDIPL ARE IN DEBYES----------------------------CNI29230
            ATDIPL(K)=ATDIPL(K)+DSP                                     CNI29240
            DMSP(K)=DMSP(K)+ATDIPL(K)                                   CNI29250
   41    CONTINUE                                                       CNI29260
         IF (INODEE.EQ.1) GO TO 90                                      CNI29270
C--------MU(HYBRID) PD FOR K, CA, SC-ZN, GE,AS, SE, BR------------------CNI29275
         IF (IPLFCN.EQ.0.AND.INODEE.EQ.0)                               CNI29280
     1   FACTOR=BOHR*DEBYE*9.D0/(DSQRT(5.D0)*SLTR1)                     CNI29290
         IF (IPLFCN.EQ.1)                                               CNI29300
     1   FACTOR=BOHR*DEBYE*9.D0*(SLTR1*ZSLATR(IATNO(J),2))**4.5/        CNI29310
     2   (DSQRT(5.D0)*(.5D0*(SLTR1+ZSLATR(IATNO(J),2)))**10)            CNI29320
         DPD=-FACTOR*(B(INDEX+2,INDEX+8)+B(INDEX+3,INDEX+5)             CNI29330
     1  +B(INDEX+1,INDEX+7)-1.D0/DSQRT(3.D0)*B(INDEX+1,INDEX+4))        CNI29340
         DMPD(1)=DMPD(1)+DPD                                            CNI29350
         ATDIPL(1)=ATDIPL(1)+DPD                                        CNI29360
         DPD=-FACTOR*(B(INDEX+1,INDEX+8)+B(INDEX+3,INDEX+6)             CNI29370
     1   -B(INDEX+2,INDEX+7)-1.D0/DSQRT(3.D0)*B(INDEX+2,INDEX+4))       CNI29380
         DMPD(2)=DMPD(2)+DPD                                            CNI29390
         ATDIPL(2)=ATDIPL(2)+DPD                                        CNI29400
         DPD=-FACTOR*(B(INDEX+1,INDEX+5)+B(INDEX+2,INDEX+6)             CNI29410
     1   +2.D0/DSQRT(3.D0)*B(INDEX+3,INDEX+4))                          CNI29420
         DMPD(3)=DMPD(3)+DPD                                            CNI29430
         ATDIPL(3)=ATDIPL(3)+DPD                                        CNI29440
         GO TO 90                                                       CNI29450
C--------MU(HYBRID) FOR NA,MG,AL,SI,P,S,CL------------------------------CNI29460
   50    SLTR1=(.65D0*DBLE(FLOAT(IATNO(J)))-4.95D0)/3.D0                CNI29470
         FACTOR=BOHR*DEBYE*7.D0/(DSQRT(5.D0)*SLTR1)                     CNI29480
         INDEX=LIML(J)                                                  CNI29490
         DO 60 K=1,3                                                    CNI29500
            DSP=-B(INDEX,INDEX+K)*                                      CNI29510
     1      BOHR*DEBYE*7.D0/(SLTR1*DSQRT(3.0D0))                        CNI29520
C-----------10.27175D0=0.52917715*4.803250*7/SQRT(3)--------------------CNI29530
C                     =BOHR    *DEBYE  *7/SQRT(3)                       CNI29540
C-----------DSP AND ATDIPL ARE IN DEBYES--------------------------------CNI29550
            ATDIPL(K)=ATDIPL(K)+DSP                                     CNI29560
            DMSP(K)=DMSP(K)+ATDIPL(K)                                   CNI29570
   60    CONTINUE                                                       CNI29580
         IF (INODEE.EQ.1) GO TO 90                                      CNI29590
         IF (IPLFCN.EQ.0.AND.INODEE.EQ.0)                               CNI29600
     1   FACTOR=BOHR*DEBYE*7.D0/(DSQRT(5.D0)*SLTR1)                     CNI29610
         IF (IPLFCN.EQ.1)                                               CNI29620
     1   FACTOR=BOHR*DEBYE*7.D0*(SLTR1*ZSLATR(IATNO(J),2))**3.5/        CNI29630
     2   (DSQRT(5.D0)*(0.5D0*(SLTR1+ZSLATR(IATNO(J),2)))**8)            CNI29640
         DPD=-FACTOR*(B(INDEX+2,INDEX+8)+B(INDEX+3,INDEX+5)             CNI29650
     1   +B(INDEX+1,INDEX+7)-1.D0/DSQRT(3.D0)*B(INDEX+1,INDEX+4))       CNI29660
         DMPD(1)=DMPD(1)+DPD                                            CNI29670
         ATDIPL(1)=ATDIPL(1)+DPD                                        CNI29680
         DPD=-FACTOR*(B(INDEX+1,INDEX+8)+B(INDEX+3,INDEX+6)             CNI29690
     1   -B(INDEX+2,INDEX+7)-1.D0/DSQRT(3.D0)*B(INDEX+2,INDEX+4))       CNI29700
         DMPD(2)=DMPD(2)+DPD                                            CNI29710
         ATDIPL(2)=ATDIPL(2)+DPD                                        CNI29720
         DPD=-FACTOR*(B(INDEX+1,INDEX+5)+B(INDEX+2,INDEX+6)             CNI29730
     1   +2.D0/DSQRT(3.D0)*B(INDEX+3,INDEX+4))                          CNI29740
         DMPD(3)=DMPD(3)+DPD                                            CNI29750
         ATDIPL(3)=ATDIPL(3)+DPD                                        CNI29760
         GO TO 90                                                       CNI29770
C--------MU(HYBRID) FOR LI,BE,B,C,N,O,F---------------------------------CNI29780
   70    INDEX=LIML(J)                                                  CNI29790
         DO 80 K=1,3                                                    CNI29800
            DSP=-B(INDEX,INDEX+K)*BOHR*DEBYE*5.0D0/                     CNI29810
     1      (DSQRT(3.0D0)*.325D0*DBLE(FLOAT(IATNO(J)-1)))               CNI29820
C-----------7.337=0.529177*4.80325*5/SQRT(3)----------------------------CNI29830
C-----------DSP IS IN DEBYES--------------------------------------------CNI29840
            DMSP(K)=DMSP(K)+DSP                                         CNI29850
            ATDIPL(K)=ATDIPL(K)+DSP                                     CNI29860
   80    CONTINUE                                                       CNI29870
         IF (IPLFCN.EQ.0) GO TO 90                                      CNI29880
C--------LI,BE,B,C,N,O,F POLARIZATION FUNCTION TERMS--------------------CNI29890
         FACTOR=BOHR*DEBYE*DSQRT(2.D0)*                                 CNI29900
     1   (ZSLATR(IATNO(J),1)**2.5*ZSLATR(IATNO(J),2)**3.5)/((.5D0*      CNI29910
     2   (ZSLATR(IATNO(J),1)+ZSLATR(IATNO(J),2)))**7)                   CNI29920
         DPD=-FACTOR*(                                                  CNI29930
     1   DSQRT(3.D0)*B(INDEX+2,INDEX+8)+                                CNI29940
     2   DSQRT(3.D0)*B(INDEX+3,INDEX+5)+                                CNI29950
     3   DSQRT(3.D0)*B(INDEX+1,INDEX+7)-                                CNI29960
     4   B(INDEX+1,INDEX+4))                                            CNI29970
         DMPD(1)=DMPD(1)+DPD                                            CNI29980
         ATDIPL(1)=ATDIPL(1)+DPD                                        CNI29990
         DPD=-FACTOR*(                                                  CNI30000
     1   DSQRT(3.D0)*B(INDEX+1,INDEX+8)+                                CNI30010
     2   DSQRT(3.D0)*B(INDEX+3,INDEX+6)-                                CNI30020
     3   DSQRT(3.D0)*B(INDEX+2,INDEX+7)-                                CNI30030
     4   B(INDEX+2,INDEX+4))                                            CNI30040
         DMPD(2)=DMPD(2)+DPD                                            CNI30050
         ATDIPL(2)=ATDIPL(2)+DPD                                        CNI30060
         DPD=-FACTOR*(                                                  CNI30070
     1   DSQRT(3.D0)*B(INDEX+1,INDEX+5)+                                CNI30080
     2   DSQRT(3.D0)*B(INDEX+2,INDEX+6)+                                CNI30090
     3   2.D0*B(INDEX+3,INDEX+4))                                       CNI30100
         DMPD(3)=DMPD(3)+DPD                                            CNI30110
         ATDIPL(3)=ATDIPL(3)+DPD                                        CNI30120
         GO TO 90                                                       CNI30130
   85    IF (IPLFCN.EQ.0) GO TO 90                                      CNI30140
C--------HYDROGEN POLARIZATION FUNCTION TERMS---------------------------CNI30150
         INDEX=LIML(J)                                                  CNI30160
         DO 86 K=1,3                                                    CNI30170
            DSP=-B(INDEX,INDEX+K)*BOHR*DEBYE*2.D0*                      CNI30180
     1      ZSLATR(IATNO(J),1)**1.5*ZSLATR(IATNO(J),2)**2.5/            CNI30190
     2      ((.5D0*(ZSLATR(IATNO(J),1)+ZSLATR(IATNO(J),2)))**5)         CNI30200
            DMSP(K)=DMSP(K)+DSP                                         CNI30210
            ATDIPL(K)=ATDIPL(K)+DSP                                     CNI30220
            DMHYB(K)=DSP/DEBYE                                          CNI30230
   86    CONTINUE                                                       CNI30240
C--------ADD CHARGE CONTRIBUTION TO ALL ATOMS: DMCHAR IS IN DEBYES------CNI30250
   90    DMCHAR=(DBLE(FLOAT(ICORE(J)))-XXX(J))*BOHR*DEBYE               CNI30260
   92    IF (IFIELD.EQ.0) WRITE (LOUTPT,93) J,ITITLE(J),                CNI30265
     1   (ATDIPL(K),K=1,3)                                              CNI30270
   93    FORMAT (' ATOM I=',I3,A4,' HYBRIDIZATION MOMENT COMPONENTS ',  CNI30180
     1   'MUX MUY MUZ'/14X,3D15.6,' DEBYES ')                           CNI30300
C--------DMHYB IS IN ELECTRONS*ANGSTROMS------------------------------- CNI30310
         DMHYB(1)=ATDIPL(1)/DEBYE                                       CNI30320
         DMHYB(2)=ATDIPL(2)/DEBYE                                       CNI30330
         DMHYB(3)=ATDIPL(3)/DEBYE                                       CNI30340
         IF (IFIELD.EQ.0) WRITE (LOUTPT,94) (DMHYB(K),K=1,3)            CNI30360
   94    FORMAT (14X,3D15.6,' ELECTRONS*ANGSTROMS')                     CNI38380
         DO 100 K=1,3                                                   CNI30390
C-----------ACCUMULATE IN DM(K) NET ATOM CHARGE*ATOM POSITION-----------CNI30395
            DMADD=DMCHAR*C(J,K)                                         CNI30400
C-----------DMADD AND DM ARE IN DEBYES----------------------------------CNI30410
            DM(K)=DM(K)+DMADD                                           CNI30420
C-----------ZERO FIELD: ATLCHG STORES OPPOSITE OF ALL HYBRID MOMENTS----CNI30425
            IF (IFIELD.EQ.0) ATLCHG(J,K)=-ATDIPL(K)                     CNI30430
C-----------ZERO FIELD: ATLCHF STORES OPPOSITE OF NET ATOM CHARGES------CNI30435
            IF (IFIELD.EQ.0) ATLCHF(J,K)=-DMCHAR                        CNI30440
  100    CONTINUE                                                       CNI30450
         IF (IFIELD.EQ.0.OR.FIELD.EQ.0.0D0) GO TO 150                   CNI30460
C--------ELECTRIC FIELD IS NON-ZERO ALONG IFIELD=1:X, =2:Y, =3:Z -------CNI30465
         ATLCHF(J,IFIELD)=(ATLCHF(J,IFIELD)+DMCHAR)/(FIELD*DEBYE)       CNI30470
C--------NOW ATLCHF IS IN ANGSTROMS**3/BOHR-----------------------------CNI30480
         DO 120 K=1,3                                                   CNI30490
C-----------NON-ZERO FIELD: ATLMUF ACCUMULATES HYBRID POLARIZ. COMPS.---CNI30495
            ATLMUF(J,IFIELD,K)=(ATDIPL(K)+ATLCHG(J,K))/(FIELD*DEBYE)    CNI30500
C-----------ATLMUF IS NOW IN ANGSTROMS**3-------------------------------CNI30510
  120    CONTINUE                                                       CNI30520
         WRITE (LOUTPT,140) J,ONOMA(IFIELD),ATLCHF(J,IFIELD)            CNI30570
  140    FORMAT (' ATOM I=',I3,' FIELD ALONG ',A1,                      CNI30580
     1   ' ALPHA CHG (PER UNIT LENGTH)=',D16.9,' ANGSTROMS**2')         CNI30590
  150 CONTINUE                                                          CNI30600
      DO 155 J=1,NATOMS                                                 CNI30610
         IF (LIMU(J)-LIML(J).GT.1) WRITE (LOUTPT,130) J,                CNI30530
     1   (ONOMA(IFIELD),ATLMUF(J,IFIELD,K),K=1,3)                       CNI30540
  130    FORMAT (' ATOM I=',I3,' HYB A(',A1,'X)=',D13.6,                CNI30550
     1   ' ',A1,'Y=',D13.6,' ',A1,'Z=',D13.6,' ANGSTROMS**3')           CNI30560
  155 CONTINUE                                                          CNI30570
C-----HUGE LOOP OVER ALL ATOMS ENDS-------------------------------------CNI30605
      DO 160 I=1,3                                                      CNI30610
  160 DPM(I)=DM(I)+DMSP(I)+DMPD(I)                                      CNI30620
C-----ACCUMULATE CHARGE (DM) + SP-HYBRID (DMSP) + PD-HYBRID (DMPD) PARTSCNI30625
      DP=DSQRT(DPM(1)**2+DPM(2)**2+DPM(3)**2)                           CNI30630
      WRITE (LOUTPT,170) DM(1),DM(2),DM(3),DMSP(1),DMSP(2),DMSP(3),     CNI30640
     1DMPD(1),DMPD(2),DMPD(3),DPM(1),DPM(2),DPM(3),DP                   CNI30650
  170 FORMAT(/,20X,' ELECTRIC DIPOLE MOMENTS'/                          CNI30660
     15X,11H COMPONENTS,3X,2H X,8X,2H Y,8X,2H Z/                        CNI30670
     25X,10H DENSITIES,3(1X,F9.5)/5X,4H S.P,6X,3(1X,F9.5)/              CNI30680
     35X,4H P.D,6X,3(1X,F9.5)/    5X,6H TOTAL,4X,3(1X,F9.5),//          CNI30690
     43X,' ELECTRIC DIPOLE MOMENT=',F9.5,7H DEBYES,//)                  CNI30700
C-----NOW THE DIPOLE MOMENT CALCULATION IS FINISHED --------------------CNI30705
      IF (IPOLAR.EQ.0) GO TO 999                                        CNI30710
      IF (IHOFMN.GT.0) GO TO 999                                        CNI30720
C-----BEGIN POLARIZABILITY CALCULATION ALONG IFIELD=1:X, =2:Y,=3:Z------CNI30730
      IF (IFIELD.NE.0) GO TO 190                                        CNI30740
C-----COPY DIPOLE TOTAL MOMENT (DPM->DIPM) AND CHARGE MOMENT (DM->DMCH)-CNI30745
      DO 180 K=1,3                                                      CNI30750
         DIPM(K)=DPM(K)                                                 CNI30760
         DMCH(K)=DM(K)                                                  CNI30770
  180 CONTINUE                                                          CNI30780
  190 CONTINUE                                                          CNI30790
      IF (IPIECE.EQ.10) WRITE (LPIECE,11) (DIPM(K),DMCH(K),K=1,3),      CNI30800
     1((ATLCHF(J,K),ATLCHG(J,K),K=1,3),J=1,NATOMS)                      CNI30810
      IF (IFIELD.EQ.0) GO TO 999                                        CNI30820
C-----COMPUTE MOLECULAR POLARIZABILITY COMPONENTS (TOTAL & CHARGE PART)-CNI30825
      DO 200 K=1,3                                                      CNI30830
         ALFSUM(IFIELD,K)=(DPM(K)-DIPM(K))/(FIELD*DEBYE)                CNI30840
         ALFACH(IFIELD,K)=(DM (K)-DMCH(K))/(FIELD*DEBYE)                CNI30850
  200 CONTINUE                                                          CNI30860
C-----ADD DIAGONAL ATOM CORE POLARIZABILITIES TO THE MOLECULAR ALFSUM:--CNI30870
      DO 201 I=1,NATOMS                                                 CNI30872
         ALFSUM(IFIELD,IFIELD)=ALFSUM(IFIELD,IFIELD)+ALPHAT(IATNO(I))   CNI30874
  201 CONTINUE                                                          CNI30876
      FILD=-FIELD                                                       CNI30880
C-----TITLE: MOLECULAR POLARIZABILITY COMPONENTS (TOTAL & CHARGE PART)--CNI30885
      WRITE (LOUTPT,210) FILD,ONOMA(IFIELD),(ONOMA(IFIELD),             CNI30890
     1ALFSUM(IFIELD,K),K=1,3)                                           CNI30900
  210 FORMAT (' IF THE TOTAL MOLECULAR STATIC ELECTRIC DIPOLE POLARIZA',CNI30910
     1'BILITY'/ ' IS THE RATIO OF THE DIPOLE MOMENT'/                   CNI30920
     2' DIVIDED BY THE APPLIED ELECTRIC FIELD:',D20.7,' ELECTRONS/ANGS',CNI30940
     3'TROMS**2'/' IN THE POSITIVE ',A1,' DIRECTION'/                   CNI30950
     4' THEN IT IS: (UNITS OF ANGSTROMS**3)'/                           CNI30970
     5' TOT. MOL. ALPHA(',A1,'X)= ',F11.6/                              CNI30980
     6' TOT. MOL. ALPHA(',A1,'Y)= ',F11.6/                              CNI30990
     7' TOT. MOL. ALPHA(',A1,'Z)= ',F11.6//)                            CNI31000
      WRITE (LOUTPT,220) (ONOMA(IFIELD),ALFACH(IFIELD,K),K=1,3)         CNI31010
  220 FORMAT (' BOND POLARIZABILITY CONTRIBUTION:'/                     CNI31020
     1' BOND MOL. ALPHA(',A1,'X)= ',D13.6/                              CNI31030
     2' BOND MOL. ALPHA(',A1,'Y)= ',D13.6/                              CNI31040
     3' BOND MOL. ALPHA(',A1,'Z)= ',D13.6//)                            CNI31050
      IF (IPIECE.EQ.11.OR.IPIECE.EQ.12) WRITE (LPIECE,11)               CNI31060
     1(ATLCHF(J,IFIELD),(ATLMUF(J,IFIELD,K),K=1,3),J=1,NATOMS),         CNI31070
     2(ALFSUM(IFIELD,K),ALFACH(IFIELD,K),K=1,3)                         CNI31080
      IF (IFIELD.NE.3) GO TO 999                                        CNI31090
C-----(IFIELD=3); NOW PRINT ALL COMPONENTS OF MOLECULAR.ALPHA ----------CNI31100
      WRITE (LOUTPT,230) FIELD,FILD,((ONOMA(ICAMPO),ALFACH(ICAMPO,J     CNI31110
     1),J=1,3),ICAMPO=1,3),((ONOMA(ICAMPO),ALFSUM(ICAMPO,J),J=1,3),     CNI31120
     2ICAMPO=1,3)                                                       CNI31130
  230 FORMAT ('1FOR FIELD: ',D13.6,' ATOMIC UNITS (ELECTRONS/BOHR**2'/  CNI31140
     1' I.E.FIELD:',D13.6,' ELECTRONS/ANGSTROMS**2'/                    CNI31150
     2' THE MOLECULAR STATIC ELECTRIC DIPOLE POLARIZABILITIES ARE:'/    CNI31160
     33(' BOND MOL. A(',A1,'X)=',D13.6,' A(',A1,                        CNI31170
     4'Y)=',D13.6,' A(',A1,'Z)= ',D13.6/)/                              CNI31180
     73(' TOT. MOL. A(',A1,'X)=',D13.6,' A(',                           CNI31190
     8A1,'Y)=',D13.6,' A(',A1,'Z)=',D13.6/)/)                           CNI31200
      GAMSQD=0.5*((ALFSUM(1,1)-ALFSUM(2,2))**2+                         CNI31210
     1(ALFSUM(2,2)-ALFSUM(3,3))**2+(ALFSUM(3,3)-ALFSUM(1,1))**2)+       CNI31220
     23.D0*(ALFSUM(1,2)**2+ALFSUM(2,3)**2+ALFSUM(3,1)**2)               CNI31230
      WRITE (LOUTPT,240) GAMSQD                                         CNI31240
  240 FORMAT (' THE MOLECULAR OPTICAL ANISOTROPY',                      CNI31250
     1' (J.COLLOID SCI.27,529(1968) EQ.(5)) IS:'/                       CNI31260
     3' GAMMA**2=',D13.6,' ANGSTROMS**2'/)                              CNI31270
C *** DIAGONALIZE & GET PRINCIPAL VALUES OF MOLECULAR POLARIZABILITY----CNI31280
      CALL EIG3 (ALFSUM,ROOTS,BETH)                                     CNI31290
      ROOTAV=(ROOTS(1)+ROOTS(2)+ROOTS(3))/3.0D0                         CNI31300
      RKAY=DSQRT(((ROOTS(1)-ROOTAV)**2+(ROOTS(2)-ROOTAV)**2+            CNI31310
     1(ROOTS(3)-ROOTAV)**2)/(6.D0*ROOTAV**2))                           CNI31320
      WRITE (LOUTPT,250) ROOTAV,ROOTS(1),ROOTS(2),ROOTS(3),RKAY         CNI31330
  250 FORMAT (' DIAGONALIZED MOLECULAR POLARIZABILITY (ANGSTROMS**3) IS:CNI31340
     1'/' ',71('-')/                                                    CNI31350
     1' MOLECULE:'/' A(AVE)=',D13.6,' A1=',D13.6,                       CNI31360
     2' A2=',D13.6,' A3=',D13.6/'      K=',D13.6,' ',                   CNI31370
     350('-'))                                                          CNI31380
      DO 19 I=1,3                                                       CNI31390
         DO 19 J=1,3                                                    CNI31400
            BETHAN(I,J)=WACOS(BETH(I,J))/RAD2DG                         CNI31410
   19 CONTINUE                                                          CNI31420
      WRITE (LOUTPT,260) ((BETH(I,J),BETHAN(I,J),J=1,3),I=1,3)          CNI31430
  260 FORMAT (7X,'EIGENVECTORS      ',F8.5,F5.0,4X,F8.5,F5.0,4X,F8.5,   CNI31440
     1F5.0,2(/25X,F8.5,F5.0,4X,F8.5,F5.0,4X,F8.5,F5.0))                 CNI31450
      WRITE (LOUTPT,270)                                                CNI31460
  270 FORMAT (' ',71('-')/)                                             CNI31470
C-----MOLECULAR DIPOLE MOMENT AND POLARIZABILITY HAVE BEEN PRINTED------CNI31480
C     BEGIN IN TANDEM ATOM-IN-MOLECULE POLARIZABILITIES (IATOM=1) AND   CNI31490
C     BOND-IN-MOLECULE POLARIZABILITIES (IATOM=0)                       CNI31495
C     HUGE LOOP FROM 300 TO 999, FOR ATOM AND BOND POLARIZABILITIES     CNI31505
C     OVERALL STRATEGY: DECIDE HOW TO COMBINE CHARGE+BOND DISTANCE      CNI31507
C-----VERSUS HYBRID MOMENTS INTO AN ALGORITHM---------------------------CNI31509
C-----STORAGE MATRICES (3 BY 3 AND NATOMS BY 3) ------------------------CNI28652
C     ATLCHF: (NATOMS BY 3)                                             CNI28653
C     ATLCHG: (NATOMS BY 3)                                             CNI28654
C     ATLHYZ: (NATOMS BY 3)                                             CNI28655
C     ATLHYF: (NATOMS BY 3)                                             CNI28656
C     ATLMUF: (NATOMS BY 3 BY 3) <--ATLMUF STORES HYBRID POLARIZABILITY CNI28657
C     HYBSAV: (NATOMS BY 3 BY 3)                                        CNI28658
C     ALFSUM: (3 BY 3) <-- ALFSUM STORES MOLECULAR POLARIZABILITY       CNI28659
C     ALFACH: (3 BY 3)                                                  CNI28660
C     ATLCHG: (3 BY 3) <-- ATFLCH: STORES CHARGE PART OF POLARIZABILITY CNI28661
C-----SUMMARIZING MATRICES:---------------------------------------------CNI28662
C     ALATOM: (3 BY 3) IATOM=1 AIM (ATOM-IN-MOLECULE POLARIZABILITY)    CNI28
C     ALBOND: (3 BY 3) IATOM=0 BIM (BOND-IN-MOLECULE POLARIZABILITY)    CNI28
C     ALKEEP: (3 BY 3) <-- ALSO STORES MOLECULAR POLARIZABILITY TENSOR  CNI28663
C     ALSAVE: (3 BY 3) IATOM=1 SUM OF AIM (ATOM-IN-MOLECULE POLARIZAB.) CNI28664
C     ALTOTL: (3 BY 3) IATOM=0 SUM OF BIM (BOND-IN-MOLECULE POLARIZAB.) CNI28665
C     ALRING: (3 BY 3) SIMPLE CLOSED RINGS POLARIZABILITY TENSOR        CNI28666
C     ALRUNG: (3 BY 3) COMPLICATED RINGS POLARIZABILITY TENSOR          CNI28667
C     ALGLOB: (3 BY 3) =ALSAVE+ALTOTL+ALRING+ALRUNG (EVENTUALLY)        CNI28668
C     ALCHEK: (3 BY 3) = ALGLOB-ALKEEP: CHECKSUM CHECKER                CNI28669
C-----SPECIALIZED MATRICES FOR SUBROUTINE DIAGON:-----------------------CNI28669
C     ALFATM: (3 BY 3) INPUT                                            CNI28670
C     ALFSYM: (3 BY 3) FOR  SYMMETRIC PART                              CNI28671
C     ALFASM: (3 BY 3) FOR UNSYMMETRIC PART                             CNI28672
C-----------------------------------------------------------------------CNI28673
C ----INITIALIZE ARRAY BOLD TO STORE INTERATOMIC BOND DISTANCES---------CNI31555
  300 DO 302 I=1,NATOMS                                                 CNI31560
         DO 301 J=1,NATOMS                                              CNI31570
            BOLD(I,J)=0.0D0                                             CNI31580
            ITABLE(I,J)=0                                               CNI31656
  301    CONTINUE                                                       CNI31585
  302 CONTINUE                                                          CNI31590
C-----INITIALIZE COORDINATION NUMBER MEASURES IBOND & COORSM------------CNI31595
      DO 303 I=1,NATOMS                                                 CNI31600
         ITSDUN(I)=0                                                    CNI31605
         IBOND(I)=0                                                     CNI31610
         ICLOSD(I)=0                                                    CNI31615
         IF (IATOM.EQ.0) COORSM(I)=0.0D0                                CNI31620
  303 CONTINUE                                                          CNI31630
      IBONDS=0                                                          CNI31640
      XRING=0.D0                                                        CNI31645
      BONDSQ=(BONDMX/BOHR)**2                                           CNI31650
C ----FIND AND STORE INTERATOMIC DISTANCES IN BOLD(NATOMS,NATOMS)-------CNI31659
      DO 307 I=1,NATOMS                                                 CNI31680
         DO 304 J=I,NATOMS                                              CNI31690
            IF (I.EQ.J) GO TO 304                                       CNI31700
            DISTS=(C(J,1)-C(I,1))**2+(C(J,2)-C(I,2))**2+                CNI31710
     1      (C(J,3)-C(I,3))**2                                          CNI31720
            IF (DISTS.GT.BONDSQ) GO TO 304                              CNI31730
            DISTS=DSQRT(DISTS)*BOHR                                     CNI31740
C-----------STORE BOND DISTANCES (ANGSTROMS) IN ARRAY BOLD(I,J)---------CNI31745
            BOLD(I,J)=DISTS                                             CNI31750
            BOLD(J,I)=DISTS                                             CNI31760
            ITABLE(I,J)=1                                               CNI31762
            ITABLE(J,I)=1                                               CNI31764
C-----------IBOND(I) STORES THE COORDINATION NUMBER AROOUND ATOM I------CNI31765
            IBOND(I)=IBOND(I)+1                                         CNI31770
            IBOND(J)=IBOND(J)+1                                         CNI31780
C-----------FOR BOND POLARIZABILITY, COORSM =  REAL COORDINATION NUMBER CNI31785
            COORSM(I)=COORSM(I)+1.D0                                    CNI31790
            COORSM(J)=COORSM(J)+1.D0                                    CNI31800
            IBONDS=IBONDS+1                                             CNI31810
  304    CONTINUE                                                       CNI31820
         IF (IBOND(I).EQ.2) XRING=XRING+1.D0                            CNI31827
C--------IBOND(I)=2 SUGGESTS BUT DOES NOT PROVE THAT ATOM I IS IN A RINGCNI31829
C--------EXTRACT USEFUL DATA FROM MOLECULAR POLARIZABILITY DATA ABOVE---CNI31830
         DO 306 L=1,3                                                   CNI31835
            DO 305 M=1,3                                                CNI31836
C--------------SET TO ZERO SEVERAL SUMS---------------------------------CNI31837
               ALATOM(L,M)=0.D0                                         CNI31838
               ALBOND(L,M)=0.D0                                         CNI31839
               ALSAVE(L,M)=0.D0                                         CNI31840
               ALTOTL(L,M)=0.D0                                         CNI31844
               ALRING(L,M)=0.D0                                         CNI31845
               ALRUNG(L,M)=0.D0                                         CNI31846
               ALGLOB(L,M)=0.D0                                         CNI31847
               ALCHEK(L,M)=0.D0                                         CNI31848
C--------------SAVE ATOMIC HYBRID  POLARIZATION IN HYBSAV---------------CNI31849
               IF (IATOM.EQ.1) HYBSAV(I,L,M)=ATLMUF(I,L,M)              CNI31850
  305       CONTINUE                                                    CNI31860
C-----------SAVE ATOMIC CHARGE POLARIZATION IN ATLCHG-------------------CNI31865
            ATLCHG(I,L)=ATLCHF(I,L)                                     CNI31870
  306    CONTINUE                                                       CNI31880
  307 CONTINUE                                                          CNI31890
  308 IRINGT=0                                                          CNI31910
      IMAX=0                                                            CNI31920
C-----IROSEY=1: ATOMS WITH IBOND(I).GE.2 ENCLOSE A RING OF IRINGT ATOMS CNI31930
C-----IF THEIR BOND DISTANCES ARE BETWEEN 1.2 AND 1.6  ANGSTROMS--------CNI
      DO 309 I=1,NATOMS                                                 CNI31940
         IF (IBOND(I).LT.2) GO TO 309                                   CNI31851
         IF (ICLOSD(I).EQ.1) GO TO 309                                  CNI31952
         DO 3090 J=1,NATOMS                                             CNI31955
            IF (IBOND(J).LT.2) GO TO 3090                               CNI31960
            IF (ICLOSD(J).EQ.1) GO TO 3090                              CNI31952
            IF (BOLD(I,J).GT.1.7) GO TO 3090                            CNI31963
            IF (BOLD(I,J).LT.1.2) GO TO 3090                            CNI31964
            IF (ICLOSD(I).EQ.0) IRINGT=IRINGT+1                         CNI31965
            IF (ICLOSD(I).EQ.0) ICLOSD(I)=1                             CNI31966
            IF (ICLOSD(J).EQ.0) IRINGT=IRINGT+1                         CNI31967
            IF (ICLOSD(J).EQ.0) ICLOSD(J)=1                             CNI31968
 3090    CONTINUE                                                       CNI31969
         IF (IBOND(I).LT.IMAX) GO TO 309                                CNI31970
         IMAX=IBOND(I)                                                  CNI31980
  309 CONTINUE                                                          CNI31990
      IF (IRINGT.GE.3) IROSEY=1                                         CNI31995
      IF (IROSEY.EQ.1) WRITE (LOUTPT,310) IRINGT                        CNI32000
  310 FORMAT (' *** THIS MOLECULE HAS A CLOSED RING WITH IRINGT=',I3,   CNI32010
     1' ATOMS')                                                         CNI32020
      WRITE (LOUTPT,311) IMAX                                           CNI32025
  311 FORMAT (' THE MAXIMUM COORDINATION NUMBER FOUND WAS IMAX=',I3)    CNI32038
C-----STORE OTHER DATA FOUND FROM THE MOLECULAR POLARIZABILITY----------CNI32030
  312 DO 314 L=1,3                                                      CNI32040
         DO 313 M=1,3                                                   CNI32050
            ALFATM(L,M)=0.0D0                                           CNI32060
            ALFACH(L,M)=0.0D0                                           CNI32070
            ALKEEP(L,M)=ALFSUM(L,M)                                     CNI32080
C-----------CHECKSUMS WILL MEASURE HOW WELL AIM OR BIM MATCH ALKEEP     CNI32090
  313    CONTINUE                                                       CNI33000
  314 CONTINUE                                                          CNI33010
C-----THERE ARE THREE CASES TO CONSIDER:--------------------------------CNI33020
C     (1) OPEN STRUCTURE: ATOM-IN-MOLECULE ANALYSIS (IATOM=1)           CNI33030
C     (2) OPEN STRUCTURE: BOND-IN-MOLECULE ANALYSIS (IATOM=0)           CNI33040
C     (3) SIMPLE CLOSED RINGS (IATOM=2)                                 CNI33050
C     ANALYSIS STARTS FROM THE END ATOMS (WITH ONLY ONE NEAREST-NEIGHBORCNI33050
C     ATOMS TO WHICH THIS END ATOM IS BONDED (IBOND(I)=1). NEXT, ATOMS  CNI33060
C-----WITH IBOND(I)=2; THEN ATOMS WITH IBOND=2 OR 3 OR 4, ARE CONSIDEREDCNI33110
  330 IATOM=1                                                           CNI33120
  350 IF (IATOM.EQ.1) WRITE (LOUTPT,351)                                CNI33150
  351 FORMAT (36('=-')/' ATOM-IN-MOLECULE POLARIZABILITY ANALYSIS:'/)   CNI33160
  352 IF (IATOM.EQ.0) WRITE (LOUTPT,353)                                CNI33170
  353 FORMAT (24('=-=')/' BOND-IN-MOLECULE POLARIZABILITY ANALYSIS:'/)  CNI33180
C-----MEGVAN RECORDS HOW MANY ATOMS WERE FOUND:(0.LE.MEGVAN.LE.NATOMS)--CNI33130
      MEGVAN=0                                                          CNI33140
      ISTUDY=1                                                          CNI33190
C-----IN FIRST PASS, THE BIG LOOP TREATS SINGLE BONDS: IBOND(I)=ISTUDY=1CNI33200
C-----IN A SECOND PASS IBOND(I)=2 IS HANDLED BY INCREMENTING ISTUDY-----CNI33210
  360 DO 371 I=1,NATOMS                                                 CNI33230
         IF (ITSDUN(I).EQ.1) GO TO 371                                  CNI33240
         IF (IATOM.EQ.0.AND.NATOMS-MEGVAN.EQ.1) GO TO 371               CNI33245
         IF (IATOM.EQ.0.AND.I.EQ.IBIM) GO TO 371                        CNI33251
C--------FIRST STUDY IBOND(I)=1, THEN STUDY IBOND(I)=2,3 , ETC.---------CNI33260
         IF (IBOND(I).GT.ISTUDY) GO TO 371                              CNI33250
         INOW=I                                                         CNI33255
         BONDMN=2.6D0                                                   CNI33256
         DO 361 J=1,NATOMS                                              CNI33290
            IF (DABS(BOLD(I,J)).LE.1.0D-5) GO TO 361                    CNI33300
            BONDIJ=BOLD(I,J)*BOHR                                       CNI33305
C-----------FIND THE MINIMUM BOND DISTANCE BETWEEN ATOMS I AND J--------CNI33306
            IF (BONDIJ.GT.BONDMN) GO TO 361                             CNI33307
            JNOW=J                                                      CNI33308
            BONDMN=BONDIJ                                               CNI33309
  361    CONTINUE                                                       CNI33310
C -------ATOM JNOW WAS FOUND TO BE CLOSEST TO ATOM INOW ----------------CNI33320
         DO 362 M=1,3                                                   CNI33330
C-----------COSR(M) IS THE M-TH COMPONENT OF THE I/J DIRECTION COSINE---CNI33340
            IF (DABS(BOLD(INOW,JNOW)).LE.1.0D-5) GO TO 362              CNI33345
            COSR(M)=(C(INOW,M)-C(JNOW,M))/DSQRT((C(INOW,1)-C(JNOW,1))   CNI33350
     1      **2+(C(INOW,2)-C(JNOW,2))**2+(C(INOW,3)-C(JNOW,3))**2)      CNI33355
  362    CONTINUE                                                       CNI33360
C--------LOOP 369 IS CRUCIAL--------------------------------------------CNI33370
         DO 369 J=1,NATOMS                                              CNI33370
            IF (DABS(BOLD(I,J)).LE.1.0D-5) GO TO 369                    CNI33300
            DO 366 L=1,3                                                CNI33360
               DO 364 M=1,3                                             CNI33390
C-----------------ALFDUM GETS BOND MOMENT COMPONENT---------------------CNI33410
                  ALFDUM=ATLCHG(I,L)*BOLD(I,J)*COSR(M)*FUDGE            CNI33420
C-----------------PUT 1/2 OF BOND MOMENT + I-HYB.MOMENT TO ALFATM(L,M)--CNI33430
                  IF (IATOM.EQ.1) ALATOM(L,M)=ATLMUF(I,L,M)+ALFDUM      CNI33435
     1            *0.5D0*FUDGE                                          CNI33440
C-----------------PUT 1/2 OF BOND MOMENT + J-HYB.MOMENT TO ATLMUF(J,L,M)CNI33450
                  IF (IATOM.EQ.1) ATLMUF(J,L,M)=ATLMUF(J,L,M)+ALFDUM*   CNI33460
     1            0.5D0*FUDGE                                           CNI33470
                  IF (IATOM.EQ.0) ALBOND(L,M)=ALFDUM+                   CNI33480
     1            ATLMUF(I,L,M)/COORSM(I)+ATLMUF(J,L,M)/COORSM(J)       CNI33500
C-----------------IATOM=0 CASE: THE LAST 2 ATOMS MUST SHARE RESULTS-----CNI33510
                  IF (IATOM.EQ.0.AND.NATOMS-MEGVAN.LE.2) ALBOND(L,M)=   CNI33520
     1            ALFDUM+0.5D0*ATLMUF(I,L,M)/COORSM(I)+                 CNI33530
     2            ATLMUF(J,L,M)/COORSM(J)                               CNI33540
  364          CONTINUE                                                 CNI33550
C--------------PICK UP CORE POLARIZABILITY OF ATOM I--------------------CNI33560
  365          ALATOM(L,L)=ALATOM(L,L)+ALPHAT(IATNO(I))                 CNI33570
               ALBOND(L,L)=ALBOND(L,L)+ALPHAT(IATNO(I))                 CNI33580
  366       CONTINUE                                                    CNI33590
            DO 368 L=1,3                                                CNI33591
               DO 367 M=1,3                                             CNI33592
C-----------------ACCUMULATE ALATOM AND ALBOND IN ALSAVE AND ALTOTL-----CNI33593
                  ALSAVE(L,M)=ALSAVE(L,M)+ALATOM(L,M)                   CNI33594
                  ALTOTL(L,M)=ALTOTL(L,M)+ALBOND(L,M)                   CNI33595
  367          CONTINUE                                                 CNI33596
  368       CONTINUE                                                    CNI33597
            ITIT=ITITLE(INOW)                                           CNI35610
            ISYMS=ISYMOP(INOW)                                          CNI35620
            BONDIJ=BOLD(INOW,JNOW)                                      CNI35630
            IF (INOW.LE.0.OR.INOW.GT.NATOMS.OR.JNOW.LE.0.OR.            CNI35640
     1      JNOW.GT.NATOMS) GO TO 369                                   CNI35650
C *** ------DIAGONALIZE+PRINT ATOM-IN-MOLECULE POLARIZABILITY-----------CNI35660
            IF (IATOM.EQ.1) CALL DIAGON (IATOM,INOW,JNOW,BONDIJ,COSR,   CNI35670
     1      ONOMA,ALFATM,ALFACH,ALATOM,LOUT,LAUX,ITIT,ISYMS)            CNI35680
C *** ------DIAGONALIZE+PRINT BOND-IN-MOLECULE POLARIZABILITY-----------CNI35690
            IF (IATOM.EQ.0) CALL DIAGON (IATOM,INOW,JNOW,BONDIJ,COSR,   CNI35700
     1      ONOMA,ALFATM,ALFACH,ALBOND,LOUT,LAUX,ITIT,ISYMS)            CNI35710
            IF (J.LE.NATOMS) GO TO 370                                  CNI35725
  369    CONTINUE                                                       CNI35780
  370    MEGVAN=MEGVAN+1                                                CNI35782
         ITSDUN(INOW)=1                                                 CNI33600
  371 CONTINUE                                                          CNI35784
      ISTUDY=ISTUDY+1                                                   CNI35786
      IF (NATOMS-MEGVAN.GE.1.AND.ISTUDY.LT.6) GO TO 360                 CNI35787
      DO 373 L=1,3                                                      CNI35790
         DO 372 M=1,3                                                   CNI35791
C-----------ACCUMULATE ALSAVE(L,M) AND ALTOTL(L,M) IN ALGLOB(L,M)-------CNI35720
C           IF (IATOM.EQ.1) ALCHEK(L,M)=ALSAVE(L,M)-ALKEEP(L,M)         CNI35792
C           IF (IATOM.EQ.0) ALCHEK(L,M)=ALTOTL(L,M)-ALKEEP(L,M)         CNI35793
            IF (IATOM.EQ.1) ALCHEK(L,M)=ALSAVE(L,M)                     CNI35792
            IF (IATOM.EQ.0) ALCHEK(L,M)=ALTOTL(L,M)                     CNI35793
  372    CONTINUE                                                       CNI35794
  373 CONTINUE                                                          CNI35795
      IF (MEGVAN.EQ.NATOMS-1.AND.IATOM.EQ.0) GO TO 378                  CNI35796
C-----PRINT IATOM=1 RESULTS---------------------------------------------CNI35740
  374 CM=(ALCHEK(1,1)+ALCHEK(2,2)+ALCHEK(3,3))/(RADIX1+RADIX2+RADIX3)   CNI35811
      IF (IATOM.EQ.1.AND.MEGVAN.EQ.NATOMS) WRITE (LOUTPT,375) RADIX1,   CNI35811
     1RADIX2,RADIX3,((ONOMA(L),ONOMA(M),ALCHEK(L,M),M=1,3),L=1,3),      CNI35812
     2ALCHEK(1,1),ALCHEK(2,2),ALCHEK(3,3),RADIX1,RADIX2,RADIX3,CM,      CNI35813
     3ALFACH(1,2),ALFACH(2,3),ALFACH(3,1)                               CNI35814
  375 FORMAT (' ',35('A=')/' CHECKSUM CM FOR ATOM-IN-MOLECULE POLARIZA',CNI35815
     1' BILITY TENSORS'/' HOW WELL DID THE TRACE OF THE TOTAL MOLECULA',CNI35816
     2'R POLARIZABILITY TENSOR:'/' [MOLECULAR A(XX)=',D13.6,'+A(YY)=',  CNI35816
     3D13.6,'+A(ZZ)=',D13.6,']'/72('=')/' MATCH THE TRACE OF THE SUMME',CNI35817
     4'D ATOM-IN-MOLECULE POLARIZABILITY TENSORS:'/3(' TOTAL ATOM A(',  CNI35818
     52A1,')=',D13.6,2(' A(',2A1,')=',D13.6)/)/72('=')/' CHECKSUM CM= ('CNI35819
     6,D12.5, '+',D12.5,'+',D12.5,')'/'(',D12.5,'+',D12.5,'+',D12.5,')='CNI35820
     7,D14.6/ ' WHICH IS PERFECT MATCHING WHEN CM=1.0'/                 CNI35821
     8' ALPHA ANTISYMMETRIC(1,2)=',D13.6/' ALPHA ANTISYMMETRIC(2,3)=',  CNI35830
     9D13.6/' ALPHA ANTISYMMETRIC(3,1)=',D13.6/' ',35('A='))            CNI35840
C-----SET UP TO STUDY BOND-IN-MOLECULE POLARIZABILITES (IATOM=0)--------CNI35860
      IF (MEGVAN.GE.NATOMS-1.AND.IATOM.EQ.1) IATOM=0                    CNI35870
      IF (IATOM.EQ.0) MEGVAN=0                                          CNI35880
  376 DO 377 I=1,NATOMS                                                 CNI35902
         ITSDUN(I)=0                                                    CNI35904
  377 CONTINUE                                                          CNI35906
      IF (MEGVAN.LT.NATOMS.AND.IATOM.EQ.0) GO TO 352                    CNI35870
C-----PRINT IATOM=0 RESULTS---------------------------------------------CNI35900
  378 CB=(ALCHEK(1,1)+ALCHEK(2,2)+ALCHEK(3,3))/(RADIX1+RADIX2+RADIX3)   CNI35942
      IF (IATOM.EQ.0.AND.MEGVAN.GE.NATOMS-1) WRITE (LOUTPT,379) RADIX1, CNI35950
     1RADIX2,RADIX3,((ONOMA(L),ONOMA(M),ALCHEK(L,M),M=1,3),L=1,3),      CNI35960
     2ALCHEK(1,1),ALCHEK(2,2),ALCHEK(3,3),RADIX1,RADIX2,RADIX3,CB,      CNI35813
     3ALFACH(1,2),ALFACH(2,3),ALFACH(3,1)                               CNI35954
  379 FORMAT (' ',35('B=')/' CHECKSUM CB FOR BOND-IN-MOLECULE POLARIZA',CNI35815
     1'BILITY TENSORS'/' HOW WELL DID THE TRACE OF THE TOTAL MOLECULA', CNI35956
     2'R POLARIZABILITY TENSOR'/' [MOLECULAR A(XX)=',D13.6,'+A(YY)=',   CNI35957
     3D13.6,'+A(ZZ)=',D13.6,']'/72('=')/' MATCH THE TRACE OF THE SUMME',CNI35960
     4'D BOND-IN-MOLECULE POLARIZABILITY TENSORS'/3(' TOTAL BOND A(',   CNI35970
     52A1,')=',D13.6,2(' A(',2A1,')=',D13.6)/)72('=')/' CHECKSUM CB= (',CNI35975
     6D12.5,'+',D12.5,'+',D12.5,')/'/'(',D12.5,'+',D13.6,'+',D13.6,')=',CNI35820
     7D14.6/' WHICH IS PERFECT MATCHING WHEN CB=1'/                     CNI35821
     8' ALPHA ANTISYMMETRIC(1,2)=',D13.6/' ALPHA ANTISYMMETRIC(2,3)=',  CNI35990
     9D13.6/' ALPHA ANTISYMMETRIC(3,1)=',D13.6/' ',35('B='))            CNI36000
C-----END OF SIMPLE OPEN STRUCTURE  (IATOM=0, IATOM=1)------------------CNI35790
C-----STUDY A SIMPLE CLOSED RING (IATOM=2)------------------------------CNI36020
      IATOM=2                                                           CNI33120
  380 IF (IATOM.EQ.2.AND.IRINGT.GT.1) WRITE (LOUTPT,381)                CNI33150
  381 FORMAT (24('-=-')/' SIMPLE CLOSED RING POLARIZABILITY ANALYSIS:'/)CNI33160
      DO 390 I=1,NATOMS                                                 CNI35902
         ITSDUN(I)=0                                                    CNI35904
  390 CONTINUE                                                          CNI35906
      IF (IRINGT.LE.2) GO TO 430                                        CNI35910
      IF (IATOM.EQ.2) MEGVAN=0                                          CNI36040
  412 DO 420 I=1,NATOMS                                                 CNI33605
         IF (ICLOSD(I).NE.1) GO TO 420                                  CNI33630
         MEGVAN=MEGVAN+1                                                CNI33635
         DO 419 J=1,NATOMS                                              CNI33640
            IF (ICLOSD(J).NE.1) GO TO 419                               CNI33650
            IF (BOLD(I,J).GT.1.7) GO TO 419                             CNI
            IF (BOLD(I,J).LT.1.2) GO TO 419                             CNI
            BONDIJ=DABS(BOLD(I,J))                                      CNI33675
            DO 415 L=1,3                                                CNI35030
               DO 414 M=1,3                                             CNI35040
                  COSR(M)=(C(I,M)-C(J,M))/DSQRT((C(I,1)                 CNI33356
     1            -C(J,1))**2+(C(I,2)-C(J,2))**2+                       CNI33357
     2            (C(I,3)-C(J,3))**2)                                   CNI33358
                  ALRING(L,M)=ALRING(L,M)+BONDIJ*COSR(M)*               CNI33359
     1            ATLCHG(I,L)                                           CNI35050
  414          CONTINUE                                                 CNI35060
  415       CONTINUE                                                    CNI35070
  416       INOW=I                                                      CNI35075
            JNOW=J                                                      CNI35080
            ITIT=ITITLE(INOW)                                           CNI35710
            ISYMS=ISYMOP(INOW)                                          CNI35720
C *** ------DIAGONALIZE+PRINT SIMPLE-RING-IN-MOLECULE POLARIZABILITY----CNI35750
            CALL DIAGON (IATOM,INOW,JNOW,BONDIJ,COSR,                   CNI35760
     1      ONOMA,ALFATM,ALFACH,ALRING,LOUT,LAUX,ITIT,ISYMS)            CNI35770
            DO 418 L=1,3                                                CNI35780
               DO 417 M=1,3                                             CNI35790
C-----------------ALCHEK(L,M)=ALRING(L,M)-ALKEEP(L,M)-------------------CNI35800
                  ALCHEK(L,M)=ALRING(L,M)/2.D0                          CNI35810
  417          CONTINUE                                                 CNI35820
  418       CONTINUE                                                    CNI35830
  419    CONTINUE                                                       CNI35840
  420 CONTINUE                                                          CNI35112
      IF (IATOM.EQ.2.AND.MEGVAN.EQ.IRINGT.AND.IRINGT.GT.2) WRITE        CNI36070
     1(LOUTPT,507) ((ONOMA(L),ONOMA(M),ALCHEK(L,M),M=1,3),L=1,3),       CNI36080
     2ALFACH(1,2),ALFACH(2,3),ALFACH(3,1)                               CNI36090
  507 FORMAT (' ',35('R=')/' CHECKSUM FOR CLOSED-RING INDIVIDUAL ',     CNI36100
     1'POLARIZABILITY TENSORS TO MATCH '/' THE TOTAL MOLECULAR ',       CNI36110
     2'POLARIZABILITY TENSOR:'/3(' TOT. MOLEC. A(',2A1,')=',D13.6,      CNI36120
     32(' A(',2A1,')=',  D13.6)/) ' SHOULD BE CLOSE TO ZERO'/           CNI36130
     4' ALPHA ANTISYMMETRIC(1,2)=',D13.6/                               CNI36140
     5' ALPHA ANTISYMMETRIC(2,3)=',D13.6/                               CNI36150
     6' ALPHA ANTISYMMETRIC(3,1)=',D13.6/                               CNI36160
     7' SHOULD ALSO BE CLOSE TO ZERO'/' ',35('R='))                     CNI36170
C-----STUDY A FUSED RING (IATOM=3)--------------------------------------CNI36180
      IF (MEGVAN.GE.NATOMS.AND.IATOM.EQ.2) IATOM=3                      CNI36190
          GO TO 999
      IF (IATOM.EQ.3) MEGVAN=0                                          CNI36200
C-----COMPLICATED FUSED RINGS CASE (IATOM=3) BEGINS---------------------CNI35120
      IF (IATOM.NE.3) GO TO 999                                         CNI35122
  430 DO 441 I=1,NATOMS                                                 CNI35125
         DO 438 J=1,NATOMS                                              CNI35140
            IF (IBOND(J).LT.2) GO TO 438                                CNI35150
            IF (IMESS.EQ.1.AND.IBOND(J).NE.20) GO TO 438                CNI35160
            CSTORE(1)=0.0D0                                             CNI35170
            CSTORE(2)=0.0D0                                             CNI35180
            CSTORE(3)=0.0D0                                             CNI35190
            JNOPE=0                                                     CNI35200
            XRING=1.D0                                                  CNI35210
            XAWAY=XRING                                                 CNI35220
            ICOMP=J                                                     CNI35230
            JNOW=0                                                      CNI35240
            IF (I.EQ.JNOPE) GO TO 438                                   CNI35260
            IF (J.EQ.I) GO TO 438                                       CNI35250
            IF (DABS(BOLD(ICOMP,I)).LE.1.0D-4) GO TO 438                CNI35270
            IF (IBOND(I).EQ.3.AND.IBOND(ICOMP).EQ.3) GO TO 438          CNI35280
            XAWAY=XAWAY-1.0D0                                           CNI35290
            IF (XAWAY.LE.0.0D0) GO TO 434                               CNI35300
            DO 431 M=1,3                                                CNI35310
                CSTORE(M)=CSTORE(M)+XAWAY*(C(ICOMP,M)-C(I,M))           CNI35320
  431       CONTINUE                                                    CNI35330
            IF (XRING-XAWAY.GT.1.0D0) GO TO 432                         CNI35340
            JNOW=I                                                      CNI35350
  432       BONDIJ=DSQRT(BOLD(I,J))                                     CNI35370
            DO 433 M=1,3                                                CNI35380
               COSR(M)=(C(ICOMP,M)-C(I,M))/BONDIJ                       CNI35390
  433       CONTINUE                                                    CNI35400
  434       JNOPE=ICOMP                                                 CNI35410
            ICOMP=J                                                     CNI35420
  435       DO 437 L=1,3                                                CNI35430
               DO 436 M=1,3                                             CNI35440
                  ALFATM(L,M)=ATLCHG(I,L)*CSTORE(M)/XRING+              CNI35450
     1            ATLMUF(I,L,M)                                         CNI35460
                  IF (I.EQ.ITHREE) ALFATM(L,M)=ALFATM(L,M)+             CNI35470
     1            ALFSAV(L,M)                                           CNI35480
                  ALRUNG(L,M)=ALRUNG(L,M)+ALFATM(L,M)                   CNI35490
  436          CONTINUE                                                 CNI35500
  437       CONTINUE                                                    CNI35510
  438    CONTINUE                                                       CNI35512
         IATOM=1                                                        CNI
         INOW=I                                                         CNI
         JNOW=J                                                         CNI
         ITIT=ITITLE(INOW)                                              CNI35710
         ISYMS=ISYMOP(INOW)                                             CNI35720
         BONDIJ=BOLD(I,J)*BOHR                                          CNI
C ***    DIAGONALIZE+PRINT FUSED RING-IN-MOLECULE POLARIZABILITY--------CNI35750
         IF (IATOM.EQ.3) CALL DIAGON (IATOM,INOW,JNOW,BONDIJ,COSR,      CNI35760
     1   ONOMA,ALFATM,ALFACH,ALRUNG,LOUT,LAUX,ITIT,ISYMS)               CNI35770
C--------ACCUMULATE ALRUNG(L,M) IN ALGLOB(L,M)--------------------------CNI
         DO 440 L=1,3                                                   CNI
             DO 439 M=1,3                                               CNI
                ALCHEK(L,M)=ALRUNG(L,M)-ALKEEP(L,M)                     CNI
  439       CONTINUE                                                    CNI
  440    CONTINUE                                                       CNI
  441 CONTINUE                                                          CNI35513
C-----PRINT IATOM=3 RESULTS---------------------------------------------CNI36220
      IF (IATOM.EQ.3.AND.MEGVAN.EQ.NATOMS) WRITE (LOUTPT,508)           CNI36230
     1((ONOMA(L),ONOMA(M),ALCHEK(L,M),M=1,3),L=1,3),ALFACH(1,2),        CNI36240
     2ALFACH(2,3),ALFACH(3,1)                                           CNI36670
  508 FORMAT (' CHECKSUM FOR COMPLEX CLOSED RING INDIVIDUAL POLARIZA',  CNI36680
     1'BILITY TENSORS TO MATCH '/'  THE TOTAL MOLECULAR POLARIZABILITY',CNI36690
     2' TENSOR:'/3(' TOT. MOLEC. A(',2A1,')=',D13.6,2(' A(',2A1,')=',   CNI37000
     3D13.6)/) ' SHOULD BE CLOSE TO ZERO'/                              CNI36710
     4' ALPHA ANTISYMMETRIC(1,2)=',D13.6/                               CNI36720
     5' ALPHA ANTISYMMETRIC(2,3)=',D13.6/                               CNI36730
     6' ALPHA ANTISYMMETRIC(3,1)=',D13.6/                               CNI36730
     7' SHOULD ALSO BE CLOSE TO ZERO'/)                                 CNI36740
C-----NEGATE THE FIELD AGAIN TO RE-ESTABLISH ITS CORRECT SIGN-----------CNI36750
  999 FIELD=-FIELD*BOHR**2                                              CNI36760
      RETURN                                                            CNI36770
CE.18 END OF DIPOLE (CNDOP)-------------------------------------------- CNI36780
      END                                                               CNI36790
      SUBROUTINE HUCKOP (A,B,Q,XX5,XX6,XX7,EIGVAL,XX9,G,PDIAG,C,XXY,XXZ,CNI36800
     1IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,IVPOS,IORD)               CNI34190
CB.19 LAST CHANGE 19 JUL 1998 (CNDOP)-----------------------------------CNI34200
C     CALLED BY: MAIN  (03)                                             CNI34210
C     CALLS    : EIGN  (22),SCFOUT(23)                                  CNI04270
C-----EXTENDED HUCKEL THEORY FOR OPEN SHELLS----------------------------CNI34230
C     OVERLAP IS IN A, GAMMA MATRIX IS IN G                             CNI34240
C     AN INITIAL F MATRIX IS FORMED FROM -(I+A)/2 AND S(U,V)*(1/2)*     CNI34250
C     (BETA0A+BETA0B). THIS F MATRIX IS USED TO GENERATE AN INITIAL     CNI34260
C     DENSITY MATRIX. AT THIS POINT, ADDITIONAL INTEGRALS AND COR-      CNI34270
C     RECTIONS ARE ADDED TO THE F MATRIX TO FORM EITHER THE CNDO OR INDOCNI34280
C     CORE HAMILTONIAN. THESE ADDITIONS ARE THE INTEGRALS V(AB)FOR CNDO CNI34290
C-----AND CORRECTIONS TO U(I,I) FOR INDO.-------------------------------CNI34300
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI34310
      CHARACTER*4 ITITOL                                                CNI34315
      INTEGER OPTION,CNDO,UL,ANI                                        CNI34430
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI34320
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI34330
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI34340
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI34345
      COMMON/INFOX/NATOMS,NCHARG,MULTIP,N,NELECS,NOCCA,NOCCB,LIMG,IPREC CNI34370
      COMMON/CHOICE/OPTION,II1(2),CNDO,II2(3)                           CNI34380
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI34440
     1RKAPPA(35,6)                                                      CNI34450
      DIMENSION A(N,N),B(N,N),Q(N,N),XX5(N),XX6(N),XX7(N),EIGVAL(N),    CNI34390
     1XX9(N),G(LIMG,LIMG),PDIAG(N),C(NATOMS,3),XXY(N),XXZ(N),           CNI34400
     2IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),  CNI34410
     3IGAM(N),IPOSV(N),IVPOS(N),IORD(N)                                 CNI34420
      IRETUR=0                                                          CNI34460
      IF (IPOLAR.GE.1.AND.IFIELD.EQ.1.AND.ISHORT.EQ.1) GO TO 10         CNI34470
      IF (IFIELD.GE.2.AND.ISHORT.EQ.1) IRETUR=1                         CNI34480
      IF (IFIELD.GE.2.AND.ISHORT.EQ.1) GO TO 10                         CNI34490
C-----FILL H CORE(DIAGONAL) WITH (I+A)/2--------------------------------CNI34500
      DO 6 I=1,NATOMS                                                   CNI34510
         LL =LIML(I)                                                    CNI34520
         UL =LIMU(I)                                                    CNI34530
         ANI=IATNO(I)                                                   CNI34540
         L=0                                                            CNI34550
         DO 5 J=LL,UL                                                   CNI34560
            L=L+1                                                       CNI34570
            IF (L.EQ.1) GO TO 4                                         CNI34580
            IF (L.LT.5) GO TO 3                                         CNI34590
C-----------NA,MG,AL,SI,P,S,CL; GE,AS,SE,BR-----------------------------CNI34600
            A(J,J)=-ENEG(ANI,3)/HARTRE                                  CNI34610
            GO TO 5                                                     CNI34620
C-----------LI,BE,B,C,N,O,F: -------------------------------------------CNI34630
    3       A(J,J)=-ENEG(ANI,2)/HARTRE                                  CNI34640
            GO TO 5                                                     CNI34650
C-----------HYDROGEN ONLY ----------------------------------------------CNI34660
    4       A(J,J)=-ENEG(ANI,1)/HARTRE                                  CNI34670
    5    CONTINUE                                                       CNI34680
    6 CONTINUE                                                          CNI34690
C-----FORM HUECKEL HAMILTONIAN IN A (OFF-DIAGONAL TWO-CENTER TERMS)-----CNI34700
C-----FROM OVERLAP INTEGRAL  -------------------------------------------CNI34710
      DO 9 I=2,N                                                        CNI34720
         K=IOR2AT(I)                                                    CNI34730
         L=IATNO(K)                                                     CNI34740
         UL=I-1                                                         CNI34750
         DO 8 J=1,UL                                                    CNI34760
            KK=IOR2AT(J)                                                CNI34770
            LL=IATNO(KK)                                                CNI34780
            IF ((L.GT.9).OR.(LL.GT.9)) GO TO 7                          CNI34790
            A(I,J)=A(I,J)*(BETA0(L)+BETA0(LL))/(2.D0*HARTRE)            CNI34800
            A(J,I)=A(I,J)                                               CNI34810
            GO TO 8                                                     CNI34820
    7       IF (INUPAR.EQ.0) A(I,J)=0.75D0*A(I,J)*(BETA0(L)+BETA0(LL))  CNI34830
     1      /(2.D0*HARTRE)                                              CNI34840
            IF (INUPAR.EQ.1) A(I,J)=A(I,J)*BETAD/HARTRE                 CNI34850
            IF (INUPAR.EQ.4) A(I,J)=A(I,J)*(BETA0(L)+BETA0(LL))         CNI34860
     1      /(2.D0*HARTRE)                                              CNI34870
            A(J,I)=A(I,J)                                               CNI34880
    8    CONTINUE                                                       CNI34890
    9 CONTINUE                                                          CNI34900
C-----ADD TO CORE HAMILTONIAN THE ONE-CENTER OFF-DIAGONAL---------------CNI34910
C-----HYBRIDIZATION TERM OF THE FINITE ELECTRIC FIELD PERTURBATION------CNI34920
   10 IF (IRETUR.GE.1.AND.ISHORT.EQ.1) FIELD=-FIELD                     CNI34930
      IF (IRETUR.GE.1.AND.ISHORT.EQ.1) IFIELD=IFIELD-1                  CNI34940
   11 ROOT3=DSQRT(3.0D0)                                                CNI34950
      IF (IFIELD.EQ.0) GO TO 30                                         CNI34960
      ROOT5=DSQRT(5.0D0)                                                CNI34970
      ROOT2=DSQRT(2.0D0)                                                CNI34980
      ROOT6=DSQRT(6.0D0)                                                CNI34990
      DO 25 I=2,N                                                       CNI35000
         KATOM =IOR2AT(I)                                               CNI35010
         LATMNO=IATNO(KATOM)                                            CNI35020
         L     =LIML(KATOM)                                             CNI35030
         LIMUPP=LIMU(KATOM)                                             CNI35040
         LRANGE=LIMUPP-L+1                                              CNI35050
         IF (LATMNO.GE.11.AND.LATMNO.LE.35.AND.INODEE.EQ.0) LRANGE=9    CNI35060
         ZETA  =ZSLATR(LATMNO,1)                                        CNI35070
         ZETA2 =ZSLATR(LATMNO,2)                                        CNI35080
         ZETAV =0.5D0*(ZETA+ZETA2)                                      CNI35090
         I1=I-1                                                         CNI35100
         IF (I.NE.LIMUPP) GO TO 25                                      CNI35110
         DO 24 J=1,I1                                                   CNI35120
            IF (J.NE.L) GO TO 24                                        CNI35130
            IF (IOR2AT(J).NE.KATOM) GO TO 24                            CNI35140
            IADDR=L+IFIELD                                              CNI35150
            IF (IPLFCN.EQ.0) GO TO 12                                   CNI35160
            IF (LATMNO.NE.1) GO TO 12                                   CNI35170
C-----------HYDROGEN POLARIZATION FUNCTIONS-----------------------------CNI35180
C           (1S/X/2PX) = ((ZETA**3)*(ZETA2**5))**0.5/ZETAV**5           CNI35200
C           (1S/Y/2PY) =   DITTO                                        CNI35210
C-----------(1S/Z/2PZ) =   DITTO----------------------------------------CNI35220
            A(IADDR,L)=A(IADDR,L)-FIELD*(((ZETA**3)*                    CNI35230
     1      (ZETA2**5))**0.5D0)/ZETAV**5                                CNI35240
            GO TO 24                                                    CNI35250
   12       IF (LATMNO.LT.3.OR.LATMNO.GT.9) GO TO 16                    CNI35260
C-----------USING /2PX)=(ZETA**5/PI)**0.5*X*EXP(-ZETA*R)----------------CNI35270
C           LI,BE,B,C,N,O,F:                                            CNI35280
C           (2S/X/2PX)=2.5/(SQRT(3.)*ZETA)                              CNI35290
C           (2S/Y/2PY)=2.5/(SQRT(3.)*ZETA)                              CNI35300
C-----------(2S/Z/2PZ)=2.5/(SQRT(3.)*ZETA)------------------------------CNI35310
            A(IADDR,L)=A(IADDR,L)-2.5D0*FIELD/(ROOT3*ZETA)              CNI35320
            IF (IPLFCN.EQ.0) GO TO 24                                   CNI35330
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUNCTION CASE....-------------CNI35340
            ZE=((ZETA**2.5)*(ZETA2**3.5))/(ZETAV**7)                    CNI35350
            IF (IFIELD-2) 13,14,15                                      CNI35360
C-----------LI,BE,B,C,N,O,F POL: ---------------------------------------CNI35370
C           (2PX/X/3DZ2)    =-SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/          CNI35380
C                            2*ZETAV**7                                 CNI35390
C           (2PX/X/3DX2-Y2) =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI35400
C                            2*ZETAV**7                                 CNI35410
C           (2PY/X/3DXY)    =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI35420
C                            2*ZETAV**7                                 CNI35430
C           (2PZ/X/3DXZ)    =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI35440
C-----------                 2*ZETAV**7 --------------------------------CNI35450
   13       A(L+4,L+1)=A(L+4,L+1)+FIELD*ROOT2*ZE/2.D0                   CNI35460
            A(L+7,L+1)=A(L+7,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI35470
            A(L+8,L+2)=A(L+8,L+2)-FIELD*ROOT6*ZE/2.D0                   CNI35480
            A(L+5,L+3)=A(L+5,L+3)-FIELD*ROOT6*ZE/2.D0                   CNI35490
            GO TO 24                                                    CNI35500
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUCTION CASE....--------------CNI35510
C           (2PX/Y/3DXY)    =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI35520
C                            2*ZETAV**7                                 CNI35530
C           (2PY/Y/3DZ2)    =-SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/          CNI35540
C                            2*ZETAV**7                                 CNI35550
C           (2PY/Y/3DX2-Y2) =-SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/          CNI35560
C                            2*ZETAV**7                                 CNI35570
C           (2PZ/Y/3DXY)    =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/           CNI35580
C-----------                 2*ZETAV**7 --------------------------------CNI35590
   14       A(L+8,L+1)=A(L+8,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI35600
            A(L+4,L+2)=A(L+4,L+2)+FIELD*ROOT2*ZE/2.D0                   CNI35610
            A(L+7,L+2)=A(L+7,L+2)+FIELD*ROOT6*ZE/2.D0                   CNI35620
            A(L+6,L+3)=A(L+6,L+3)-FIELD*ROOT6*ZE/2.D0                   CNI35630
            GO TO 24                                                    CNI35640
C-----------LI,BE,B,C,N,O,F: POLARIZATION FUCTION CASE...---------------CNI35650
C           (2PX/Z/3DXZ)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI35660
C                           2*ZETAV**7                                  CNI35670
C           (2PY/Z/3DYZ)   =SQRT(6.)*(ZETA**2.5*ZETA2**3.5)/            CNI35680
C                           2*ZETAV**7                                  CNI35690
C           (2PZ/Z/3DZ2)   =SQRT(2.)*(ZETA**2.5*ZETA2**3.5)/            CNI35700
C-----------                ZETAV**7 -----------------------------------CNI35710
   15       A(L+5,L+1)=A(L+5,L+1)-FIELD*ROOT6*ZE/2.D0                   CNI35720
            A(L+6,L+2)=A(L+6,L+2)-FIELD*ROOT6*ZE/2.D0                   CNI35730
            A(L+4,L+3)=A(L+4,L+3)-FIELD*ROOT2*ZE                        CNI35740
            GO TO 24                                                    CNI35750
   16       IF (LATMNO.LT.11.OR.LATMNO.GT.17) GO TO 20                  CNI35760
C-----------NA,MG,SI,P,S,CL: (3S/X/3PX), (3S/Y/3PY), (3S/Z/3PZ)---------CNI35770
            A(IADDR,L)=A(IADDR,L)-3.5D0*FIELD/(ROOT3*ZETA)              CNI35780
            IF (INODEE.EQ.1) GO TO 24                                   CNI35790
            IF (IPLFCN.EQ.0) ZE=ZETA                                    CNI35800
            IF (IPLFCN.EQ.1) ZE=ZETAV**8/((ZETA*ZETA2)**3.5)            CNI35810
            IF (IFIELD-2) 17,18,19                                      CNI35820
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI35830
C           (3PX/X/3DZ2)   =-3.5/(SQRT(15.)*ZETA)                       CNI35840
C           (3PX/X/3DX2-Y2)= 3.5/(SQRT(5.)*ZETA)                        CNI35850
C           (3PY/X/3DXY)   = 3.5/(SQRT(5.)*ZETA)                        CNI35860
C-----------(3PZ/X/3DXZ)   = 3.5/(SQRT(5.)*ZETA) -----------------------CNI35870
   17       A(L+4,L+1)=A(L+4,L+1)+3.5D0*FIELD/(ROOT3*ROOT5*ZE)          CNI35880
            A(L+7,L+1)=A(L+7,L+1)-3.5D0*FIELD/(ROOT5*ZE)                CNI35890
            A(L+8,L+2)=A(L+8,L+2)-3.5D0*FIELD/(ROOT5*ZE)                CNI35900
            A(L+5,L+3)=A(L+5,L+3)-3.5D0*FIELD/(ROOT5*ZE)                CNI35910
            GO TO 24                                                    CNI35920
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI35930
C           (3PX/Y/3DXY)   = 3.5/(SQRT(5.)*ZETA)                        CNI35940
C           (3PY/Y/3DZ2)   =-3.5/(SQRT(15.)*ZETA)                       CNI35950
C           (3PY/Y/3DX2-Y2)=-3.5/(SQRT(5.)*ZETA)                        CNI35960
C-----------(3PZ/Y/3DYZ)   = 3.5/(SQRT(5.)*ZETA)------------------------CNI35970
   18       A(L+8,L+1)=A(L+8,L+1)-3.5D0*FIELD/(ROOT5*ZE)                CNI35980
            A(L+4,L+2)=A(L+4,L+2)+3.5D0*FIELD/(ROOT3*ROOT5*ZE)          CNI35990
            A(L+7,L+2)=A(L+7,L+2)+3.5D0*FIELD/(ROOT5*ZE)                CNI36000
            A(L+6,L+3)=A(L+6,L+3)-3.5D0*FIELD/(ROOT5*ZE)                CNI36010
            GO TO 24                                                    CNI36020
C-----------NA,MG,AL,SI,P,S,CL:-----------------------------------------CNI36030
C           (3PX/Z/3DXZ)=3.5/(SQRT(5.)*ZETA)                            CNI36040
C           (3PY/Z/3DYZ)=3.5/(SQRT(5.)*ZETA)                            CNI36050
C-----------(3PZ/Z/3DZ2)=7.0/(SQRT(15.)*ZETA)---------------------------CNI36060
   19       A(L+5,L+1)=A(L+5,L+1)-3.5D0*FIELD/(ROOT5*ZE)                CNI36070
            A(L+6,L+2)=A(L+6,L+2)-3.5D0*FIELD/(ROOT5*ZE)                CNI36080
            A(L+4,L+3)=A(L+4,L+3)-7.0*FIELD/(ROOT3*ROOT5*ZE)            CNI36090
            GO TO 24                                                    CNI36100
   20       IF (LATMNO.LT.32.OR.LATMNO.GT.35) GO TO 24                  CNI36110
            IF (LATMNO.GE.19.AND.LATMNO.LE.35.AND.INODEE.EQ.0)          CNI36120
     1      LRANGE=9                                                    CNI36130
            ZETA =ZSLATR(LATMNO,1)                                      CNI36140
            ZETA2=ZSLATR(LATMNO,2)                                      CNI36150
            ZETAV=.5D0*(ZETA+ZETA2)                                     CNI36160
C-----------GE,AS,SE,BR:------------------------------------------------CNI36170
C           (4PX/X/4DZ2)   =-4.5/(SQRT(15.)*ZE)                         CNI36180
C           (4PX/X/4DX2-Y2)= 4.5/(SQRT(5.)*ZE)                          CNI36190
C           (4PY/X/4DXY)   = 4.5/(SQRT(5.)*ZE)                          CNI36200
C-----------(4PZ/X/4DXZ)   = 4.5/(SQRT(5.)*ZE)--------------------------CNI36210
            IF(IFIELD-2) 21,22,23                                       CNI36220
   21       A(L+4,L+1)=A(L+4,L+1)+4.5D0*FIELD/(ROOT3*ROOT5*ZE)          CNI36230
            A(L+7,L+1)=A(L+7,L+1)-4.5D0*FIELD/(ROOT5*ZE)                CNI36240
            A(L+8,L+2)=A(L+8,L+2)-4.5D0*FIELD/(ROOT5*ZE)                CNI36250
            A(L+5,L+3)=A(L+5,L+3)-4.5D0*FIELD/(ROOT5*ZE)                CNI36260
            GO TO 24                                                    CNI36270
C-----------GE,AS,SE,BR:                                                CNI36280
C           (4PX/Y/4DXY)   = 4.5/(SQRT(5.)*ZE)                          CNI36290
C           (4PY/Y/4DZ2)   =-4.5/(SQRT(15.)*ZE)                         CNI36300
C           (4PY/Y/4DX2-Y2)=-4.5/(SQRT(5.)*ZE)                          CNI36310
C-----------(4PZ/Y/4DYZ)   = 4.5/(SQRT(5.)*ZE)--------------------------CNI36320
   22       A(L+8,L+1)=A(L+8,L+1)-4.5D0*FIELD/(ROOT5*ZE)                CNI36330
            A(L+4,L+2)=A(L+4,L+2)+4.5D0*FIELD/(ROOT3*ROOT5*ZE)          CNI36340
            A(L+7,L+2)=A(L+7,L+2)+4.5D0*FIELD/(ROOT5*ZE)                CNI36350
            A(L+6,L+3)=A(L+6,L+3)-4.5D0*FIELD/(ROOT5*ZE)                CNI36360
            GO TO 24                                                    CNI36370
C-----------GE,AS,SE,BR:------------------------------------------------CNI36380
C           (4PX/Z/4DXZ)=4.5/(SQRT( 5.)*ZE)                             CNI36390
C           (4PY/Z/4DYZ)=4.5/(SQRT( 5.)*ZE)                             CNI36400
C-----------(4PZ/Z/4DZ2)=9  /(SQRT(15.)*ZE)-----------------------------CNI36410
   23       A(L+5,L+1)=A(L+5,L+1)-4.5D0*FIELD/(ROOT5*ZE)                CNI36420
            A(L+6,L+2)=A(L+6,L+2)-4.5D0*FIELD/(ROOT5*ZE)                CNI36430
            A(L+4,L+3)=A(L+4,L+3)-9.0D0*FIELD/(ROOT3*ROOT5*ZE)          CNI36440
   24   CONTINUE                                                        CNI36450
   25 CONTINUE                                                          CNI36460
      DO 27 I=2,N                                                       CNI36470
         I1=I-1                                                         CNI36480
         DO 26 J=1,I1                                                   CNI36490
            A(J,I)=A(I,J)                                               CNI36500
   26    CONTINUE                                                       CNI36510
   27 CONTINUE                                                          CNI36520
      IF (IRETUR.GE.1.AND.ISHORT.EQ.1) IRETUR=IRETUR+1                  CNI36530
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) IFIELD=IFIELD+1                  CNI36540
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) FIELD=-FIELD                     CNI36550
      IF (IRETUR.EQ.2.AND.ISHORT.EQ.1) GO TO 11                         CNI36560
      IFIEL1=IFIELD-1                                                   CNI36570
C-----ADD TO CORE HAMILTONIAN ONE-CENTER DIAGONAL PART -----------------CNI36580
C-----OF THE FINITE ELECTRIC FIELD PERTURBATION ------------------------CNI36590
      DO 29 I=1,NATOMS                                                  CNI36600
         LL=LIML(I)                                                     CNI36610
         UL=LIMU(I)                                                     CNI36620
         DO 28 J=LL,UL                                                  CNI36630
            IF (IFIELD.GE.2.AND.ISHORT.EQ.1)                            CNI36640
     1      A(I,J)=A(I,J)+FIELD*C(I,IFIEL1)                             CNI36650
            A(I,J)=A(I,J)-FIELD*C(I,IFIELD)                             CNI36660
   28    CONTINUE                                                       CNI36670
   29 CONTINUE                                                          CNI36680
   30 CONTINUE                                                          CNI36690
      DO 100 I=1,N                                                      CNI36700
         DO 90 J=1,N                                                    CNI36710
            Q(I,J)=A(I,J)                                               CNI36720
   90    CONTINUE                                                       CNI36730
  100 CONTINUE                                                          CNI36740
      IF (IPOLAR.GE.1.AND.IFIELD.GT.0.AND.ISHORT.EQ.1) GO TO 300        CNI36750
      RHO=1.D-6                                                         CNI36760
C *** DIAGONALIZE-------------------------------------------------------CNI36770
      CALL EIGN (N,RHO,A,B,XX5,XX6,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,  CNI
     1IORD)                                                             CNI36780
      RHO=0.1D-01*CONVRG                                                CNI36790
      DO 110 I=1,N                                                      CNI36800
         PDIAG(I)=0.0D0                                                 CNI36810
         DO 110 J=1,N                                                   CNI36820
            A(I,J)=B(I,J)                                               CNI36830
  110 B(I,J)=0.0D0                                                      CNI36840
      DO 160 I=1,N                                                      CNI36850
         DO 120 K=1,NOCCA                                               CNI36860
  120    B(I,I)=B(I,I)+A(I,K)*A(I,K)                                    CNI36870
         DO 130 K=1,NOCCB                                               CNI36880
  130    PDIAG(I)=PDIAG(I)+A(I,K)*A(I,K)                                CNI36890
         LL=I+1                                                         CNI36900
         IF (LL.GT.N) GO TO 160                                         CNI36910
         DO 159 J=LL,N                                                  CNI36920
            DO 140 K=1,NOCCB                                            CNI36930
  140       B(I,J)=B(I,J)+A(I,K)*A(J,K)                                 CNI36940
            DO 150 K=1,NOCCA                                            CNI36950
  150       B(J,I)=B(J,I)+A(I,K)*A(J,K)                                 CNI36960
  159 CONTINUE                                                          CNI36970
  160 CONTINUE                                                          CNI36980
      IERR=0                                                            CNI36990
      DO 162 I=1,N                                                      CNI37000
         DO 161 J=1,N                                                   CNI37010
            IF (DABS(B(I,J)).GT.3.D0) IERR=1                            CNI37020
  161    CONTINUE                                                       CNI37030
  162 CONTINUE                                                          CNI37040
C-----ADD V(AB) TO HCORE--CNDO/2 ---------------------------------------CNI37050
      DO 180 I=1,N                                                      CNI37060
CEIL-----NOTE THAT GAMMA ADDRESSES ARE NO LONGER SIMPLE ATOM------------CNI37070
CEIL     ADDRESSES. ODD INDICES GET PRINCIPAL SHELL GAMMAS AT EACH      CNI37080
CEIL-----CENTER. EVEN INDICES GET POLARIZATTION SHELL GAMMAS------------CNI37090
         J=IOR2AT(I)                                                    CNI37100
         IJ=IGAM(I)                                                     CNI37110
         IIJ=IJ                                                         CNI37120
CEIL-----IF TRUE POLARIZATION FUNCTION (I.E. NOT ENERGETICALLY          CNI37130
CEIL     DEGENERATE WITH AN OCCUPIED GROUND STATE OF THE ATOM)          CNI37140
CEIL     THEN U(I,I)=-(I+A)/2 + 0.5*(GAMMA(I,I) BETWEEN THIS FCN AND THECNI37150
CEIL                 VALENCE FCNS)-(NUMBER OF VALENCE ELECTRONS)*       CNI37160
CEIL                 (GAMMA INTEGRAL BETWEEN THE POLARIZATION FCN AND   CNI37170
CEIL                 THE VALENCE FCNS)                                  CNI37180
CEIL     IF FCN IS NORMAL VALENCE FCN,                                  CNI37190
CEIL     THEN U(I,I)=-(I+A)/2+0.5*GAMMA(I,I)-(NUMBER OF VALENCE         CNI37200
CEIL-----             ELECTRONS)*GAMMA(I,I)-----------------------------CNI37210
         IDIV=IJ/2                                                      CNI37220
         IIDIV=2*IDIV                                                   CNI37230
         IF ((IJ-IIDIV).GT.0) GO TO 1160                                CNI37240
         IIJ=IJ-1                                                       CNI37250
 1160    Q(I,I)=Q(I,I)+0.5D0*G(IJ,IJ)                                   CNI37260
         Q(I,I)=Q(I,I)-DBLE(FLOAT(ICORE(J)))*G(IJ,IIJ)                  CNI37270
         DO 170 K=1,NATOMS                                              CNI37280
            IF (K.EQ.J) GO TO 170                                       CNI37290
            IK=2*K-1                                                    CNI37300
CEIL--------APPROXIMATE THE NUCLEAR ATTRACTION TO CORE OF ATOM K--------CNI37310
CEIL        BY -(REPULSION INTEGRAL BETWEEN I AND THE VALENCE           CNI37320
CEIL--------ELECTRONS OF K)---------------------------------------------CNI37330
            Q(I,I)=Q(I,I)-DBLE(FLOAT(ICORE(K)))*G(IJ,IK)                CNI37340
  170    CONTINUE                                                       CNI37350
  180 CONTINUE                                                          CNI37360
CEIL  CAVEAT: THE ABOVE CODE DOES NOT TREAT THE CASE--------------------CNI37370
CEIL  WHERE THE GROUND-STATE ATOM HAS OCCUPIED D ORBITALS WITH          CNI37380
CEIL  DIFFERENT EXPONENTS OR PRINCIPAL QUANTUM NUMBERS THAN             CNI37390
CEIL  THE OCCUPIED S AND P SHELLS                                       CNI37400
CEIL  FOR SUCH AN S(L) P(M) D(N) GROUND-STATE CONFIGURATION:            CNI37410
CEIL  U(S,S)=-0.5*(I+A)+0.5*GAMMA(S,S)-L*GAMMA(S,S)-N*GAMMA(S,D)        CNI37420
CEIL                                  -M*GAMMA(S,P)                     CNI37430
CEIL  U(P,P)=-0.5*(I+A)+0.5*GAMMA(P,P)-M*GAMMA(P,P)-L*GAMMA(S,P)        CNI37440
CEIL                                  -N*GAMMA(P,D)                     CNI37450
CEIL  U(D,D)=-0.5*(I+A)+0.5*GAMMA(D,D)-N*GAMMA(D,D)-L*GAMMA(S,D)        CNI37460
CEIL                                  -M*GAMMA(P,D)                     CNI37470
CEIL  THE INDIRECT ADDRESSING SHOULD WORK: JUST TAKE CARE TO LOOK UP    CNI37480
CEIL  THE RIGHT GAMMA, AND DETERMINE THE OCCUPATION NUMBERS ------------CNI37490
C-----EXIT SEGMENT IF ONLY CNDO APPROXIMATIONS ARE DESIRED              CNI37500
      IF (OPTION.EQ.CNDO) GO TO 300                                     CNI37510
C-----INDO MODIFICATION (CORRECTION TO U(I,I))--------------------------CNI37520
  190 DO 290 I=1,NATOMS                                                 CNI37530
         K=IATNO(I)                                                     CNI37540
         J=LIML(I)                                                      CNI37550
         IF ((K.GT.1).AND.(K.LT.10)) GO TO 200                          CNI37560
         GO TO 290                                                      CNI37570
  200    IF (K.LE.3) GO TO 220                                          CNI37580
  210    Q(J,J)=Q(J,J)+(DBLE(FLOAT(ICORE(I)))-1.5D0)*G1(K)/6.D0         CNI37590
  220    IF (K.EQ.3) GO TO 260                                          CNI37600
  230    IF (K.EQ.4) GO TO 250                                          CNI37610
  240    TEMP=G1(K)/3.D0+(DBLE(FLOAT(ICORE(I)))-2.5D0)*2.D0*            CNI37620
     1    F2(K)/25.D0                                                   CNI37620
         GO TO 270                                                      CNI37630
  250    TEMP=G1(K)/4.D0                                                CNI37640
         GO TO 270                                                      CNI37650
  260    TEMP=G1(K)/12.D0                                               CNI37660
  270    CONTINUE                                                       CNI37670
         DO 280 L=1,3                                                   CNI37680
  280    Q(J+L,J+L)=Q(J+L,J+L)+TEMP                                     CNI37690
  290 CONTINUE                                                          CNI37700
  300 CONTINUE                                                          CNI37710
      IF (IFIELD.GT.0) GO TO 999                                        CNI37720
      WRITE (LOUTPT,310)                                                CNI37730
  310 FORMAT(18H CORE HAMILTONIAN /)                                    CNI37740
C *** PRINT CORE HAMILTONIAN--------------------------------------------CNI37750
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,Q,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI37760
      WRITE (LOUTPT,400)                                                CNI37780
  400 FORMAT (' INITIAL DENSITY MATRIX.')                               CNI37790
C *** PRINT INITIAL DENSITY MATRIX--------------------------------------CNI37800
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI37810
      IF (IERR.EQ.1) GO TO 901                                          CNI37820
      GO TO 999                                                         CNI37830
C-----DIAGNOSTIC ERROR MESSAGES SECTION                                 CNI37840
  901 WRITE (LOUTPT,902)                                                CNI37850
  902 FORMAT (' RUN ABORTED. DENSITY MATRIX BLEW UP')                   CNI37860
      STOP                                                              CNI37870
  999 RETURN                                                            CNI37880
CE.19 END OF HUCKOP (CNDOP)---------------------------------------------CNI37890
      END                                                               CNI37900
      SUBROUTINE SCFOPN (A,B,Q,C,XX5,XX6,XX7,EIGVAL,XX9,G,FDIAG,        CNI37910
     1PDIAG,BOLD,ALPH2F,ATLCHF,FOLD,PULERR,FOLDB,PULERB,XXY,XXZ,        CNI37920
     2IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,IVPOS,IORD,ITITLE,ENERGY) CNI37930
CB.20 LAST CHANGE 25 AUG 2014 (CNDOP)-----------------------------------CNI37940
C     CALLED BY: MAIN  (03)                                             CNI37950
C     CALLS    : RANNUM(25),SOLPUL(40),SCFOUT(23),                      CNI04430
C                EIGN  (22),ON    (39)                                  CNI04430
C-----OPEN-SHELL SELF-CONSISTENT FIELD CYCLES---------------------------CNI37970
C     GAMMA MATRIX CONTAINED IN G, CORE HAMILTONIAN CONTAINED IN Q,     CNI38010
C     INITIAL DENSITY MATRICES IN B                                     CNI38020
C     OLD DENSITY MATRIX IN BOLD.                                       CNI38030
C     OPTIONS    CNDO OR INDO                                           CNI38040
C     AND THE APPROPRIATE CORE HAMILTONIAN. THE TWO ELECTRON INTEGRALS  CNI38050
C     ARE ADDED TO THE F MATRIX (A) IN TWO PARTS - FIRST THE CNDO GAMMASCNI38060
C     ARE ADDED AND THEN THE INDO CORRECTIONS TO THE ONE-CENTER INTEGRALCNI38070
C     THE PROCEDURE IS THAT F(ALPHA) AND F(BETA) ARE FORMED, THEN       CNI38080
C     THE ELECTRONIC ENERGY IS COMPUTED.EIGN IS CALLED TO DIAGONALIZE   CNI38090
C     THE TWO F MATRICES AND THE ALPHA AND BETA BONDORDERS ARE FORMED.  CNI38100
C-----THESE ARE USED TO FORM NEW F MATRICES AND THE CYCLE IS REPEATED   CNI38110
C-----PULAY TRICK PROGRAMMED BY R.M.METZGER, DOES NOT WORK--------------CNI37980
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI37990
      CHARACTER*4 ITITOL,ITITLE,EL                                      CNI
      INTEGER OPTION,CNDO                                               CNI38290
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI38120
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI38130
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI38140
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI38150
      COMMON/INFOX/NATOMS,II1(2),N,II2(1),NOCCA,NOCCB,LIMG,IPREC        CNI38170
      COMMON/CHOICE/OPTION,II3(2),CNDO,II4(3)                           CNI38180
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI38190
     1RKAPPA(35,6)                                                      CNI38200
      DIMENSION A(N,N),B(N,N),Q(N,N),C(NATOMS,3),XX5(N),XX6(N),         CNI38220
     1XX7(N),EIGVAL(N),XX9(N),G(LIMG,LIMG),FDIAG(N),PDIAG(N),           CNI38230
     2BOLD(N,N),ALPH2F(NATOMS,3,3),ATLCHF(NATOMS,3),                    CNI38240
     3FOLD(NPULAY,NPULAY,5),PULERR(NPULAY,NPULAY,5),FOLDB(NPULAY,5),    CNI38250
     4PULERB(NPULAY,5),XXY(N),XXZ(N),IATNO(NATOMS),ICORE(NATOMS),       CNI38260
     5IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),IGAM(N),IPOSV(N),IVPOS(N),    CNI38270
     6IORD(N),ITITLE(NATOMS)                                            CNI38280
C-----THE PULAY TRICK: DECLARATION                                      CNI38300
C       PULERR  = LAST 4 + CURRENT ERROR MATRICES                       CNI38310
C       FOLD    = LAST 4 + CURRENT FOCK  MATRICES                       CNI38320
C       FOLDB,PULERB: SAME FOR DIAGONAL BETA SPIN MATRICES              CNI38330
C       PULAYA= PULAY ERROR TRACES MATRIX FOR ALPHA SPIN                CNI38340
C       PULAYB= PULAY ERROR TRACES MATRIX FOR BETA  SPIN                CNI38350
C       PLAMA = ALPHA COEFFICIENT MATRIX FOR FINAL STAGE OF PULAY TRICK CNI38360
C       PLAMB = BETA  COEFFICIENT MATRIX FOR FINAL STAGE OF PULAY TRICK CNI38370
C-----  IDIS  = CIRCULAR POINTER STACK                                  CNI38380
      DIMENSION PULAYA(6,6),PLAMA(6),PULAYB(6,6),PLAMB(6),IDIS(5)       CNI38390
C-----END DECLARATION FOR PULAY TRICK                                   CNI38400
C-----IX INITIALIZES PSEUDO-RANDOM GENERATOR RANNUM.                    CNI38410
      IX=536870911                                                      CNI38420
C-----INITIALIZE COUNTER ICYCLE AND BEGIN SCF CYCLE AT 10               CNI38430
      ICYCLE=0                                                          CNI38440
      DO 2 I=1,N                                                        CNI38450
         DO 1 J=1,N                                                     CNI38460
            BOLD(I,J)=B(I,J)                                            CNI38470
    1    CONTINUE                                                       CNI38480
    2 CONTINUE                                                          CNI38490
C-----CHECK IF USER WANTS TO RUN PULAY TRICK----------------------------CNI38500
      IF (NPULAY.LE.1) GO TO 10                                         CNI38510
      DO 402 K=1,5                                                      CNI38520
         IDIS(K)=K                                                      CNI38530
         DO 401 J=1,NPULAY                                              CNI38540
            PULERB(J,K)=0.D0                                            CNI38550
            DO 400 I=1,NPULAY                                           CNI38560
               PULERR(I,J,K)=0.0D0                                      CNI38570
  400       CONTINUE                                                    CNI38580
  401    CONTINUE                                                       CNI38590
  402 CONTINUE                                                          CNI38600
      PULAYA(1,1)=0.D0                                                  CNI38610
      PULAYB(1,1)=0.D0                                                  CNI38620
      DO 404 I=2,6                                                      CNI38630
         PULAYA(I,1)=-1.D0                                              CNI38640
         PULAYA(1,I)=-1.D0                                              CNI38650
         PULAYB(1,I)=-1.D0                                              CNI38660
         PULAYB(I,1)=-1.D0                                              CNI38670
         DO 403 J=2,6                                                   CNI38680
            PULAYA(I,J)=0.D0                                            CNI38690
            PULAYB(I,J)=0.D0                                            CNI38700
  403    CONTINUE                                                       CNI38710
  404 CONTINUE                                                          CNI38720
C-----PULAY TRICK: FINISHED INITIALIZING. START SCF CYCLES--------------CNI38730
   10 CONTINUE                                                          CNI38750
      ICYCLE=ICYCLE+1                                                   CNI38760
      ENERGY = 0.D0                                                     CNI38770
      IF (IDM.EQ.0) GO TO 19                                            CNI38780
C-----TO PREVENT OSCILLATIONS, AVERAGE THE DENSITY MATRICES FROM--------CNI38790
C     THE TWO MOST RECENT CYCLES.                                       CNI38800
C     BOLD GETS CURRENT DENSITY MATRICES FOR NEXT CYCLE                 CNI38810
C-----(UPPER TRIANGLE: B.O.(BETA), LOWER TRIANGLE: B.O.(ALPHA))---------CNI38820
      DO 12 I=1,N                                                       CNI38830
         DO 11 J=1,N                                                    CNI38840
            BNEW=(B(I,J)+BOLD(I,J))/2.D0                                CNI38850
            BOLD(I,J)=B(I,J)                                            CNI38860
            B(I,J)=BNEW                                                 CNI38870
   11    CONTINUE                                                       CNI38880
   12 CONTINUE                                                          CNI38890
C-----TRANSFER CORE HAMILTONIAN FROM Q TO A AND TO FDIAG----------------CNI38900
   19 DO 20 I=1,N                                                       CNI38910
         FDIAG(I)=Q(I,I)                                                CNI38920
         DO 20 J=1,N                                                    CNI38930
            A(I,J)=Q(I,J)                                               CNI38940
   20 CONTINUE                                                          CNI38950
C-----AT THIS POINT DIAGONAL AND LOWER TRIANGLE OF A: H(ALPHA)=H(BETA ) CNI38960
C-----AND           FDIAG    AND UPPER TRIANGLE OF A: H(BETA )=H(ALPHA) CNI38970
      DO 30 I=1,N                                                       CNI38980
         II=IGAM(I)                                                     CNI38990
         A(I,I)  =A(I,I)  -B(I,I)*G(II,II)                              CNI39000
         FDIAG(I)=FDIAG(I)-PDIAG(I)*G(II,II)                            CNI39010
         DO 25 K=1,N                                                    CNI39020
            JJ=IGAM(K)                                                  CNI39030
            A(I,I)  =A(I,I)+  (PDIAG(K)+B(K,K))*G(II,JJ)                CNI39040
            FDIAG(I)=FDIAG(I)+(PDIAG(K)+B(K,K))*G(II,JJ)                CNI39050
   25    CONTINUE                                                       CNI39060
   30 CONTINUE                                                          CNI39070
      NM=N-1                                                            CNI39080
      DO 50 I=1,NM                                                      CNI39090
         II=IGAM(I)                                                     CNI39100
         LL=I+1                                                         CNI39110
         DO 40 J=LL,N                                                   CNI39120
            JJ=IGAM(J)                                                  CNI39130
            A(I,J)=A(I,J)-B(I,J)*G(II,JJ)                               CNI39140
            A(J,I)=A(J,I)-B(J,I)*G(II,JJ)                               CNI39150
   40    CONTINUE                                                       CNI39160
   50 CONTINUE                                                          CNI39170
      IF (OPTION.EQ.CNDO) GO TO 100                                     CNI39180
C-----INDO MODIFICATION-------------------------------------------------CNI39190
   60 DO 90 II=1,NATOMS                                                 CNI39200
         K=IATNO(II)                                                    CNI39210
         I=LIML(II)                                                     CNI39220
         IF (K.EQ.1) GO TO 90                                           CNI39230
   70    PAA=B(I,I)  +B(I+1,I+1)+B(I+2,I+2)+B(I+3,I+3)                  CNI39240
         PAB=PDIAG(I)+PDIAG(I+1)+PDIAG(I+2)+PDIAG(I+3)                  CNI39250
         A(I,I)  =A(I,I)  -(PAA-B(I,I)  )*G1(K)/3.D0                    CNI39260
         FDIAG(I)=FDIAG(I)-(PAB-PDIAG(I))*G1(K)/3.D0                    CNI39270
         DO 80 J=1,3                                                    CNI39280
            A(I+J,I+J)=A(I+J,I+J)                                       CNI39290
     1      +(B(I+J,I+J)-(PAA-B(I,I)))*F2(K)/5.D0                       CNI39300
     2      -B(I,I)*G1(K)/3.D0                                          CNI39310
     3      +(6.D0*PDIAG(I+J)-2.D0*(PAB-PDIAG(I)))*F2(K)/25.D0          CNI39320
            FDIAG(I+J)=FDIAG(I+J)                                       CNI39330
     1      +(PDIAG(I+J)-(PAB-PDIAG(I)))*F2(K)/5.D0                     CNI39340
     2      -PDIAG(I)*G1(K)/3.D0                                        CNI39350
     3      +(6.D0*B(I+J,I+J)-2.D0*(PAA-B(I,I)))*F2(K)/25.D0            CNI39360
            A(I,I+J)=A(I,I+J)+(B(I,I+J)+2.D0*B(I+J,I))*G1(K)/3.D0       CNI39370
            A(I+J,I)=A(I+J,I)+(B(I+J,I)+2.D0*B(I,I+J))*G1(K)/3.D0       CNI39380
            DO 79 L=1,3                                                 CNI39390
               IF (J.EQ.L) GO TO 79                                     CNI39400
   75          A(I+L,I+J)=A(I+L,I+J)+(5.D0*B(I+L,I+J)+6.D0*B(I+J,I+L))  CNI39410
     1         *F2(K)/25.D0                                             CNI39420
   79       CONTINUE                                                    CNI39430
   80    CONTINUE                                                       CNI39440
   90 CONTINUE                                                          CNI39450
C-----AT THIS POINT DIAGONAL AND LOWER TRIANGLE OF A = NEW F(ALPHA)-----CNI39460
C                   FDIAG    AND UPPER TRIANGLE OF A  = NEW F(BETA )    CNI39470
C     ADD SMALL RANDOM NUMBER TO PREVENT NUMERICAL INSTABILITY          CNI39480
C-----OF CONVERGENCE PROCESS--------------------------------------------CNI39490
  100 IF (IRN.EQ.0.OR.IPOLAR.EQ.0.AND.CONVRG.GT.1.D-06) GO TO 103       CNI39500
      IF (ICYCLE.EQ.1) GO TO 103                                        CNI39510
      DO 102 I=1,N                                                      CNI39520
         DO 101 J=1,N                                                   CNI39530
C ***       CALL THE PSEUDO-RANDOM GENERATOR                            CNI39540
            CALL RANNUM(IX,IY,YLF)                                      CNI39550
            IX=IY                                                       CNI39560
            A(I,J)=A(I,J)+YLF*CONVRG*0.1D-03                            CNI39570
  101    CONTINUE                                                       CNI39580
  102 CONTINUE                                                          CNI39590
C-----COMPUTE ELECTRONIC ENERGY-----------------------------------------CNI39600
  103 DO 110 I=1,N                                                      CNI39610
         ENERGY=ENERGY+0.5D0*((A(I,I)+Q(I,I))*B(I,I)+(FDIAG(I)+         CNI39620
     1   Q(I,I))*PDIAG(I))                                              CNI39630
  110 CONTINUE                                                          CNI39640
      DO 115 I=1,NM                                                     CNI39650
         LL=I+1                                                         CNI39660
         DO 114 J=LL,N                                                  CNI39670
            ENERGY=ENERGY+((A(I,J)+Q(I,J))*B(I,J)+(A(J,I)+              CNI39680
     1      Q(J,I))*B(J,I))                                             CNI39690
  114    CONTINUE                                                       CNI39700
  115 CONTINUE                                                          CNI39710
      IF (NPULAY.EQ.1) GO TO 530                                        CNI39720
C-----PULAY TRICK: SET UP AND STORE CURRENT FOCK MATRIX-----------------CNI39730
      KPUL=IDIS(5)                                                      CNI39740
      DO 420 I=1,N                                                      CNI39750
         FOLDB(I,KPUL)=FDIAG(I)                                         CNI39760
         DO 410 J=1,N                                                   CNI39770
            FOLD(I,J,KPUL)=A(I,J)                                       CNI39780
  410    CONTINUE                                                       CNI39790
  420 CONTINUE                                                          CNI39800
C-----CONSTRUCT, STORE CURRENT ERROR MATRIX-----------------------------CNI39810
C     AND GET MAXIMUM ERROR ELEMENT                                     CNI39820
C     PULERR = FOCK MATRIX * DENSITY MATRIX MINUS                       CNI39830
C-----         DENSITY MATRIX * FOCK MATRIX-----------------------------CNI39840
      EMAX=0.0D0                                                        CNI39850
      DO 450 I=1,N                                                      CNI39860
C--------FOCK(BETA):  --------------------------------------------------CNI39870
C--------PULERR(I.LT.J,KPUL)=SUM(K)(F(I.LT.K)*B(K.LT.J)-B(I.LT.K)*F(K.LTCNI39880
         DO 440 J=1,N                                                   CNI39890
            SUMA=0.D0                                                   CNI39900
            SUMB=0.D0                                                   CNI39910
            DO 430 K=1,N                                                CNI39920
               IF (I-K) 121,122,123                                     CNI39930
  121          FAIK=A    (K,I)                                          CNI39940
               BAIK=B    (K,I)                                          CNI39950
               FBIK=A    (I,K)                                          CNI39960
               BBIK=B    (I,K)                                          CNI39970
               GO TO 125                                                CNI39980
  122          FAIK=A    (I,I)                                          CNI39990
               BAIK=B    (I,I)                                          CNI40000
               FBIK=FDIAG(I)                                            CNI40010
               BBIK=PDIAG(I)                                            CNI40020
               GO TO 125                                                CNI40030
  123          FAIK=A    (I,K)                                          CNI40040
               BAIK=B    (I,K)                                          CNI40050
               FBIK=A    (K,I)                                          CNI40060
               BBIK=B    (K,I)                                          CNI40070
  125          IF (K-J) 126,127,128                                     CNI40080
  126          FAKJ=A    (J,K)                                          CNI40090
               BAKJ=B    (J,K)                                          CNI40100
               FBKJ=A    (K,J)                                          CNI40110
               BBKJ=B    (K,J)                                          CNI40120
               GO TO 129                                                CNI40130
  127          FAKJ=A    (J,J)                                          CNI40140
               BAKJ=B    (J,J)                                          CNI40150
               FBKJ=FDIAG(J)                                            CNI40160
               BBKJ=PDIAG(J)                                            CNI40170
               GO TO 129                                                CNI40180
  128          FAKJ=A    (K,J)                                          CNI40190
               BAKJ=B    (K,J)                                          CNI40200
               FBKJ=A    (J,K)                                          CNI40210
               BBKJ=B    (J,K)                                          CNI40220
  129          SUMA=SUMA+FAIK*BAKJ-BAIK*FAKJ                            CNI40230
               SUMB=SUMB+FBIK*BBKJ-BBIK*FBKJ                            CNI40240
  430       CONTINUE                                                    CNI40250
            IF (I-J) 431,432,433                                        CNI40260
  431       PULERR(I,J,KPUL)=SUMB+SUMB                                  CNI40270
            GO TO 435                                                   CNI40280
  432       PULERR(I,I,KPUL)=SUMA                                       CNI40290
            PULERB(I,  KPUL)=SUMB                                       CNI40300
            GO TO 435                                                   CNI40310
  433       PULERR(I,J,KPUL)=SUMA+SUMA                                  CNI40320
  435       PTEMP=DABS(SUMB)                                            CNI40330
            IF (PTEMP.GT.EMAX) EMAX=PTEMP                               CNI40340
  440    CONTINUE                                                       CNI40350
  450 CONTINUE                                                          CNI40360
C-----CONSTRUCT PULAY MATRIX. FIRST, SHIFT OLD ELEMENTS UP AND OVER-----CNI40370
      DO 452 I=3,6                                                      CNI40390
        II=I-1                                                          CNI40400
        DO 451 J=3,6                                                    CNI40410
          JJ=J-1                                                        CNI40420
          PULAYA(II,JJ)=PULAYA(I,J)                                     CNI40430
          PULAYB(II,JJ)=PULAYB(I,J)                                     CNI40440
  451   CONTINUE                                                        CNI40450
  452 CONTINUE                                                          CNI40460
C-----CONSTRUCT CURRENT TRACES FOR PULAY -------------------------------CNI40470
C     THESE ARE THE TRACES OF THE CURRENT ERROR MATRIX                  CNI40480
C-----TIMES THE TRANSPOSES OF THE OTHER ERROR MATRICES------------------CNI40490
      IC=IDIS(5)                                                        CNI40500
      DO 480 K=1,5                                                      CNI40510
         II=IDIS(K)                                                     CNI40520
C--------CORRECT LOCATION FOR THIS TRACE IN PULAY ----------------------CNI40530
         TA=0.D0                                                        CNI40540
         TB=0.D0                                                        CNI40550
         DO 470 I=1,N                                                   CNI40560
            DO 460 J=1,N                                                CNI40570
               IF (I-J) 456,457,458                                     CNI40580
  456          TB=TB+2.D0*PULERR(I,J,IC)*PULERR(I,J,II)                 CNI40590
               GO TO 460                                                CNI40600
  457          TB=TB+     PULERB(I,  IC)*PULERB(I,  II)                 CNI40610
               TA=TA+     PULERR(I,I,IC)*PULERR(I,I,II)                 CNI40620
               GO TO 460                                                CNI40630
  458          TA=TA+2.D0*PULERR(I,J,IC)*PULERR(I,J,II)                 CNI40640
  460       CONTINUE                                                    CNI40650
  470    CONTINUE                                                       CNI40660
         KK=K+1                                                         CNI40670
         PULAYB(KK,6)=TB                                                CNI40680
         PULAYB(6,KK)=TB                                                CNI40690
         PULAYA(KK,6)=TA                                                CNI40700
         PULAYA(6,KK)=TA                                                CNI40710
  480 CONTINUE                                                          CNI40720
C-----CHECK ENTRY CONDITIONS FOR PULAY TRICK----------------------------CNI40730
C     SET UP THRESHOLD VALUES FOR STARTING/STOPPING                     CNI40740
C-----PULAY TRICK (ENTRANCE REQUIREMENTS) ------------------------------CNI40750
      CHTH1=0.1D0*DABS(ENERGY)                                          CNI40760
      IF (IFIELD.EQ.0) WRITE(LOUTPT,810) EMAX                           CNI40770
  810 FORMAT('         EMAX=',D17.8)                                    CNI40780
      IF ((EMAX.GT.CHTH1).OR.(EMAX.LT.CONVRG)) GO TO 530                CNI40790
      IF (ICYCLE.LT.05) GO TO 530                                       CNI40800
C *** FIND PULAY PARAMETERS---------------------------------------------CNI40810
      CALL SOLPUL (PULAYA,PLAMA)                                        CNI40830
      IF (IFIELD.EQ.0) WRITE (LOUTPT,830) (PLAMA(I),I=1,6)              CNI40840
  830 FORMAT(' PULAY DIIS:  PLAM = ',6D13.6)                            CNI40850
C ***                                                                   CNI40860
      CALL SOLPUL (PULAYB,PLAMB)                                        CNI40870
      IF (IFIELD.EQ.0) WRITE (LOUTPT,830) (PLAMB(I),I=1,6)              CNI40880
C-----CREATE NEW HYBRID FOCK MATRIX-------------------------------------CNI40890
      DO 520 I=1,N                                                      CNI40900
C--------BETA FOCK MATRIX: FDIAG AND UPPER TRIANGLE OF A(I.LT.J)--------CNI40910
         SUMB=0.D0                                                      CNI40920
         DO 499 K=2,6                                                   CNI40930
            KK=IDIS(K-1)                                                CNI40940
            SUMB=SUMB+PLAMB(K)*FOLDB(I,KK)                              CNI40950
  499    CONTINUE                                                       CNI40960
         FDIAG(I)=SUMB                                                  CNI40970
         IP1=I+1                                                        CNI40980
         DO 502 J=IP1,N                                                 CNI40990
            SUMB=0.D0                                                   CNI41000
            DO 501 K=2,6                                                CNI41010
               KK=IDIS(K-1)                                             CNI41020
               SUMB=SUMB+PLAMB(K)*FOLD(I,J,KK)                          CNI41030
  501       CONTINUE                                                    CNI41040
            A(I,J)=SUMB                                                 CNI41050
  502    CONTINUE                                                       CNI41060
C--------ALPHA  FOCK MATRIX: LOWER TRIANGLE OF A(I.GE.J)----------------CNI41070
         DO 510 J=1,I                                                   CNI41080
            SUMA=0.D0                                                   CNI41090
            DO 500 K=2,6                                                CNI41100
               KK=IDIS(K-1)                                             CNI41110
               SUMA=SUMA+PLAMA(K)*FOLD(I,J,KK)                          CNI41120
  500       CONTINUE                                                    CNI41130
            A(I,J)=SUMA                                                 CNI41140
  510    CONTINUE                                                       CNI41150
  520 CONTINUE                                                          CNI41160
C-----ROTATE IDIS COUNTER FOR NEXT CYCLE                                CNI41170
      DO 406 I=1,5                                                      CNI41180
         IDIS(I)=IDIS(I)+1                                              CNI41190
         KTEMP=IDIS(I)                                                  CNI41200
         IF (KTEMP.GT.5) IDIS(I)=IDIS(I)-5                              CNI41210
  406 CONTINUE                                                          CNI41220
  530 CONTINUE                                                          CNI41230
C-----END OF PULAY TRICK                                                CNI41240
      IF (ISHIFT.EQ.0) GO TO 118                                        CNI41250
      IF (ICYCLE.EQ.1) GO TO 118                                        CNI41260
C-----TO EASE CONVERGENCE, USE SAUNDERS VIRTUAL LEVEL SHIFTER ----------CNI41270
C     ON BOTH F(ALPHA AND F(BETA)                                       CNI41280
C-----(G.PONGOR, CHEM.PHYS. LETTERS 24,603(1974))-----------------------CNI41290
      DO 117 I=1,N                                                      CNI41300
         FDIAG(I)=FDIAG(I)+SHIFTR*(1.0D0-0.5D0*PDIAG(I))                CNI41310
         DO 116 J=1,N                                                   CNI41320
            DELKRO=0.0D0                                                CNI41330
            IF (I.EQ.J) DELKRO=1.0D0                                    CNI41340
            A(I,J)=A(I,J)+SHIFTR*(DELKRO-0.5D0*B(I,J))                  CNI41350
  116    CONTINUE                                                       CNI41360
  117 CONTINUE                                                          CNI41370
  118 SHIFT=ENERGY-OLDENG                                               CNI41380
      IF (IFIELD.EQ.0) WRITE (LOUTPT,120) ICYCLE,ENERGY,SHIFT           CNI41400
      IF (DABS(ENERGY).GT.1.D30) GO TO 901                              CNI41410
  120 FORMAT(' CYCLE ',I3,'  EL.ENERGY ',D14.6,                         CNI41420
     1' A.U.; SHIFT ',D14.6)                                            CNI41430
      IF (IPOLAR.EQ.0.AND.DABS(SHIFT ).GE.CONVRG) GO TO 160             CNI41440
      IF (IPOLAR.GE.1.AND.DABS(DIFFMX).GE.CONVRG) GO TO 160             CNI41450
      IF (ICYCLE.LE.5) GO TO 160                                        CNI41460
C-----ENERGY OR DENSITY MATRIX SATISFIED: SET ICYCLE=NCYCLE+1           CNI41470
C-----AND PREPARE TO EXIT FROM SCFOPN AFTER ROUTINE OUTPUT              CNI41480
  130 ICICLE=ICYCLE                                                     CNI41490
      ICYCLE=NCYCLE+1                                                   CNI41500
  140 IF (IPOLAR.EQ.0) WRITE (LOUTPT,150) ICICLE,ENERGY,SHIFT           CNI41510
  150 FORMAT(' ENERGY SATISFIED AFTER CYCLE ',I3 /                      CNI41520
     1' ENERGY=',D20.10,' SHIFT=',D14.6)                                CNI41530
      IF (IPOLAR.GE.1) WRITE (LOUTPT,151) ICICLE,ENERGY,SHIFT,          CNI41540
     1IMX,JMX,DIFFOU                                                    CNI41550
  151 FORMAT (' DENSITY MATRIX SATISFIED AFTER CYCLE ',I3/              CNI41560
     1' ENERGY=',D14.6,' SHIFT=',D14.6,' MAX.DENS.MX.SHIFT',            CNI41570
     2' (',I3,',',I3,')=',D14.6)                                        CNI41580
      GO TO 180                                                         CNI41590
  160 CONTINUE                                                          CNI41600
  170 OLDENG=ENERGY                                                     CNI41610
  180 CONTINUE                                                          CNI41620
      IF (ICYCLE.LE.NCYCLE) GO TO 240                                   CNI41630
      IF (IFIELD.GT.0) GO TO 240                                        CNI41640
C-----TRANSFER F(ALPHA) FROM LOWER TRIANGLE OF A TO Q-------------------CNI41650
C-----FOR PRINTING (DURING LAST PASS ONLY)------------------------------CNI41660
  190 DO 200 I=1,N                                                      CNI41670
         DO 195 J=I,N                                                   CNI41680
            Q(I,J)=A(J,I)                                               CNI41690
            Q(J,I)=A(J,I)                                               CNI41700
  195    CONTINUE                                                       CNI41710
  200 CONTINUE                                                          CNI41720
      WRITE (LOUTPT,210)                                                CNI41730
  210 FORMAT(1X,42H HARTREE-FOCK ENERGY MATRIX FOR ALPHA SPIN//)        CNI41740
C *** PRINT HARTREE-FOCK ENERGY MATRIX FOR ALPHA SPIN-------------------CNI41750
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,Q,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI41760
C-----TRANSFER F(BETA) FROM LOWER TRIANGLE OF A TO Q--------------------CNI41770
C-----FOR PRINTING (LAST PASS ONLY)-------------------------------------CNI41780
      DO 220 I=1,N                                                      CNI41790
         Q(I,I)=FDIAG(I)                                                CNI41800
         LL=I+1                                                         CNI41810
         IF (LL.GT.N) GO TO 220                                         CNI41820
         DO 215 J=LL,N                                                  CNI41830
            Q(I,J)=A(I,J)                                               CNI41840
            Q(J,I)=A(I,J)                                               CNI41850
  215    CONTINUE                                                       CNI41860
  220 CONTINUE                                                          CNI41870
      WRITE (LOUTPT,230)                                                CNI41880
  230 FORMAT(1X,41H HARTREE-FOCK ENERGY MATRIX FOR BETA SPIN//)         CNI41890
C *** PRINT HARTREE-FOCK ENERGY MATRIX FOR BETA SPIN--------------------CNI41900
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,Q,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI41910
  240 CONTINUE                                                          CNI41920
C-----DIAGONALIZE (ALPHA SPIN CASE) :-----------------------------------CNI41930
C     INPUT:  FOCK MATRIX: A: LOWER TRIANGLE ONLY IS USED, AND IS       CNI41940
C             DESTROYED. UPPER TRIANGLE OF A IS PRESERVED.              CNI41950
C     OUTPUT: EIGVAL: EIGENVALUES IN ASCENDING ALGEBRAIC ORDER          CNI41960
C ***---------B: EIGENVECTORS, AS COLUMN VECTORS.-----------------------CNI41970
      CALL EIGN (N,RHO,A,B,XX5,XX6,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,  CNI
     1IORD)                                                             CNI41990
C-----IF SILVERSTONE-SAUNDERS LEVEL SHIFTING WAS DONE, UNDO THE DAMAGE  CNI42000
      IF (ISHIFT.EQ.0) GO TO 246                                        CNI42010
      IF (ICYCLE.EQ.1) GO TO 246                                        CNI42020
      DO 245 I=1,N                                                      CNI42030
         IF (I.GT.NOCCA) EIGVAL(I)=EIGVAL(I)-SHIFTR                     CNI42040
         IF (I.LE.NOCCA) EIGVAL(I)=EIGVAL(I)-SHIFTR*0.5D0               CNI42050
  245 CONTINUE                                                          CNI42060
  246 CONTINUE                                                          CNI42070
      IF (ICYCLE.LE.NCYCLE) GO TO 276                                   CNI42080
      IF (IFIELD.GT.0) GO TO 276                                        CNI42090
  250 WRITE (LOUTPT,260)                                                CNI42100
  260 FORMAT(1X,43HEIGENVALUES AND EIGENVECTORS FOR ALPHA SPIN//)       CNI42110
C *** PRINT EIGENVALUES AND EIGENVECTORS FOR ALPHA SPIN-----------------CNI42120
      IF (IBRIEF.EQ.0) CALL SCFOUT (1,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI42130
C-----PRINT OUT SPIN DENSITY MATRIX (COEFFS OF HOMO SQUARED)------------CNI42140
      DO 272 I=1,NATOMS                                                 CNI42150
         IL=LIML(I)                                                     CNI42160
         IH=LIMU(I)                                                     CNI42170
         EIGVAL(I)=0.D0                                                 CNI42180
         DO 271 J=IL,IH                                                 CNI42190
            EIGVAL(I)=EIGVAL(I)+B(J,NOCCA)**2                           CNI42200
  271    CONTINUE                                                       CNI42210
  272 CONTINUE                                                          CNI42220
      WRITE (LOUTPT,273) NOCCA                                          CNI42230
  273 FORMAT (' SPIN DENSITY (HOMO SUM OF SQUARES OF COEFFS)',          CNI42240
     1' FOR ALPHA SPIN MOLECULAR ORBITAL NO.',I5)                       CNI42250
      WRITE (LOUTPT,274) (I,EL(IATNO(I)),ITITLE(I),EIGVAL(I),I=1,       CNI42260
     1NATOMS)                                                           CNI42270
  274 FORMAT (I5,A4,3X,A4,F10.6)                                        CNI42280
      DO 275 I=1,NATOMS                                                 CNI42290
         EIGVAL(I)=0.D0                                                 CNI42300
  275 CONTINUE                                                          CNI42310
C *** IF IHOFMN=1, GET CNDO/ON PROCEDURE OF R.HOFFMAN.------------------CNI42320
      IF (IHOFMN.GE.1) CALL ON (Q,B,C,XX5,XX6,XX7,EIGVAL,XX9,G,BOLD,    CNI42330
     1ALPH2F,ATLCHF,XXY,XXZ,IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,    CNI
     2IVPOS,IORD)                                                       CNI42340
  276 CONTINUE                                                          CNI42350
C-----TRANSFER F(BETA) TO LOWER HALF OF A-------------------------------CNI42360
      DO 280 I=1,N                                                      CNI42380
         A(I,I)=FDIAG(I)                                                CNI42390
         FDIAG(I)=0.0D0                                                 CNI42400
         K=I+1                                                          CNI42410
         IF (K.GT.N) GO TO 280                                          CNI42420
         DO 279 J=K,N                                                   CNI42430
            A(J,I)=A(I,J)                                               CNI42440
            A(I,J)=0.0D0                                                CNI42450
  279    CONTINUE                                                       CNI42460
  280 CONTINUE                                                          CNI42470
C-----FORM ALPHA BONDORDERS IN TOP HALF OF A AND IN FDIAG  - TEMPORARY  CNI42480
      IERR=0                                                            CNI42490
      DO 300 I=1,N                                                      CNI42500
         DO 290 K=1,NOCCA                                               CNI42510
            IF (DABS(B(I,K)).GT.1.0000001D0) IERR=1                     CNI42520
            FDIAG(I)=FDIAG(I)+B(I,K)*B(I,K)                             CNI42530
  290    CONTINUE                                                       CNI42540
         LL=I+1                                                         CNI42550
         IF (LL.GT.N) GO TO 300                                         CNI42560
         DO 296 J=LL,N                                                  CNI42570
            DO 295 K=1,NOCCA                                            CNI42580
               IF (DABS(B(I,K)).GT.1.000001D0) IERR=1                   CNI42590
               IF (DABS(B(J,K)).GT.1.000001D0) IERR=1                   CNI42600
               A(I,J)=A(I,J)+B(I,K)*B(J,K)                              CNI42610
  295       CONTINUE                                                    CNI42620
  296    CONTINUE                                                       CNI42630
  300 CONTINUE                                                          CNI42640
      IF (IERR.EQ.1) GO TO 917                                          CNI42650
C-----DIAGONALIZE (BETA SPIN CASE):-------------------------------------CNI42660
C     INPUT:  FOCK MATRIX: A: LOWER TRIANGLE ONLY IS USED, AND IS       CNI42670
C             DESTROYED. UPPER TRIANGLE OF A IS PRESERVED.              CNI42680
C     OUTPUT: EIGVAL: EIGENVALUES IN ASCENDING ALGEBRAIC ORDER          CNI42690
C *** --------B: EIGENVECTORS, AS COLUMN VECTORS. ----------------------CNI42700
      CALL EIGN (N,RHO,A,B,XX5,XX6,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,  CNI
     1IORD)                                                             CNI42720
C-----IF SILVERSTONE-SAUNDERS LEVEL SHIFTING WAS DONE, UNDO THE DAMAGE  CNI42730
      IF (ISHIFT.EQ.0) GO TO 305                                        CNI42740
      IF (ICYCLE.EQ.1) GO TO 305                                        CNI42750
      DO 304 I=1,N                                                      CNI42760
         IF (I.GT.NOCCB) EIGVAL(I)=EIGVAL(I)-SHIFTR                     CNI42770
         IF (I.LE.NOCCB) EIGVAL(I)=EIGVAL(I)-SHIFTR*0.5D0               CNI42780
  304 CONTINUE                                                          CNI42790
  305 CONTINUE                                                          CNI42800
      IF (ICYCLE.LE.NCYCLE) GO TO 330                                   CNI42810
      IF (IFIELD.GT.0) GO TO 330                                        CNI42820
  310 WRITE (LOUTPT,320)                                                CNI42830
  320 FORMAT(1X,43HEIGENVALUES AND EIGENVECTORS FOR BETA SPIN //)       CNI42840
C *** PRINT EIGENVALUES AND EIGENVECTORS FOR BETA SPIN------------------CNI42850
      IF (IBRIEF.EQ.0) CALL SCFOUT (1,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI42860
C *** ORTHONORMALIZE MOS IF DESIRED (CNDO/ON OF ROALD HOFFMAN)----------CNI42870
      IF (IHOFMN.EQ.2) CALL ON (Q,B,C,XXX,XX6,XX7,EIGVAL,XX9,G,BOLD,    CNI42890
     1ALPH2F,ATLCHF,XXY,XXZ,IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,    CNI
     2IVPOS,IORD)                                                       CNI42900
  330 CONTINUE                                                          CNI42910
C-----FORM BETA BONDORDERS IN LOWER HALF OF A AND IN PDIAG--------------CNI42920
      IERR=0                                                            CNI42930
      DO 350 I=1,N                                                      CNI42940
         PDIAG(I)=0.0D0                                                 CNI42950
         DO 340 K=1,NOCCB                                               CNI42960
            IF (DABS(B(I,K)).GT.1.0000001D0) IERR=1                     CNI42970
            PDIAG(I)=PDIAG(I)+B(I,K)*B(I,K)                             CNI42980
  340    CONTINUE                                                       CNI42990
         LL=I+1                                                         CNI43000
         IF (LL.GT.N) GO TO 350                                         CNI43010
         DO 349 J=LL,N                                                  CNI43020
            A(J,I)=0.0D0                                                CNI43030
            DO 345 K=1,NOCCB                                            CNI43040
               IF (DABS(B(I,K)).GT.1.0000001D0) IERR=1                  CNI43050
               IF (DABS(B(J,K)).GT.1.0000001D0) IERR=1                  CNI43060
               A(J,I)=A(J,I)+B(I,K)*B(J,K)                              CNI43070
  345       CONTINUE                                                    CNI43080
  349    CONTINUE                                                       CNI43090
  350 CONTINUE                                                          CNI43100
      IF (IERR.EQ.1) GO TO 919                                          CNI43110
C-----TRANSFER BONDORDERS FROM A TO B ----------------------------------CNI43120
      DO 370 I=1,N                                                      CNI43130
         DO 360 J=1,N                                                   CNI43140
  360    B(I,J)=A(J,I)                                                  CNI43150
  370 B(I,I)=FDIAG(I)                                                   CNI43160
C-----AT THIS POINT LOWER TRIANGLE AND DIAGONAL OF B: DENS.MX.(ALPHA)   CNI43170
C-----              UPPER TRIANGLE OF B AND PDIAG   : DENS.MX.(BETA )   CNI43180
      IF (IPOLAR.EQ.0.AND.ICYCLE.LE.NCYCLE) GO TO 10                    CNI43190
      IF (IDM.EQ.0.AND.ICYCLE.GT.NCYCLE) GO TO 376                      CNI43200
      DIFFMX=-1.0D+05                                                   CNI43210
      DIFFOU=-22.D0                                                     CNI43220
      DO 372 I=1,N                                                      CNI43230
         DO 371 J=1,N                                                   CNI43240
            DIFFR=BOLD(I,J)-B(I,J)                                      CNI43250
            DIFF=DABS(DIFFR)                                            CNI43260
            IF (DIFF.LE.DIFFMX) GO TO 371                               CNI43270
            DIFFMX=DIFF                                                 CNI43280
            DIFFOU=DIFFR                                                CNI43290
            IMX=I                                                       CNI43300
            JMX=J                                                       CNI43310
  371   CONTINUE                                                        CNI43320
  372 CONTINUE                                                          CNI43330
  376 CONTINUE                                                          CNI43340
      IF (IPOLAR.GE.1.AND.ICYCLE.LE.NCYCLE) GO TO 10                    CNI43350
  380 CONTINUE                                                          CNI43360
      IF (IPOLAR.EQ.0) GO TO 999                                        CNI43370
C-----RESTORE HAMILTONIAN FOR NEXT POLARIZABILITY LOOP------------------CNI43380
      DO 600 I=1,N                                                      CNI43390
         FDIAG(I)=Q(I,I)                                                CNI43400
         DO 590 J=I,N                                                   CNI43410
C-----------TRANSFER CORE HAMILTONIAN TO LOWER TRIANGLE                 CNI43420
            A(J,I)=Q(I,J)                                               CNI43430
  590    CONTINUE                                                       CNI43440
  600 CONTINUE                                                          CNI43450
      GO TO 999                                                         CNI43460
C-----DIAGNOSTIC ERROR MESSSAGES SECTION BEGINS-------------------------CNI43470
  901 WRITE (LOUTPT,902)                                                CNI43480
  902 FORMAT (' RUN ABORTED. ELECTRONIC ENERGY BLEW UP')                CNI43490
      WRITE (LOUTPT,903) (I,EIGVAL(I),I=1,N)                            CNI43500
  903 FORMAT (' EIGENVALUE(',I3,')=',D20.10)                            CNI43510
      WRITE (LOUTPT,904)                                                CNI43520
  904 FORMAT (' CORE HAMILTONIAN ')                                     CNI43530
C *** PRINT CORE HAMILTONIAN--------------------------------------------CNI43540
      CALL SCFOUT (0,Q,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                   CNI43550
      WRITE (LOUTPT,905)                                                CNI43560
  905 FORMAT (' B MATRIX')                                              CNI43570
C *** PRINT B MATRIX----------------------------------------------------CNI43580
      CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                   CNI43590
      WRITE (LOUTPT,906)                                                CNI43600
  906 FORMAT (' F MATRIX ')                                             CNI43610
C *** PRINT F MATRIX----------------------------------------------------CNI43620
      CALL SCFOUT (0,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                   CNI43630
      STOP                                                              CNI43640
  917 WRITE (LOUTPT,918) (I,EIGVAL(I),I=1,N)                            CNI43650
  918 FORMAT (' ALPHA SPIN DIAGONALIZATION GAVE',                       CNI43660
     1' EIGENVECTOR COMPONENTS GT.1 EIGENVECTOR MATRIX FOLOWS',         CNI43670
     2' BUT FIRST THE EIGENVALUES'/                                     CNI43680
     399( ' EN(',I3,')=',D20.10/))                                      CNI43690
      WRITE (LOUTPT,1012) RHO,N                                         CNI43700
      WRITE (LOUTPT,1011) ((I,J,B(I,J),J=1,N),I=1,N)                    CNI43710
 1012 FORMAT (' RHO=',D20.10,' N=',I5)                                  CNI43720
 1011 FORMAT (' ',3('B(',I3,',',I3,')=',D20.10)/)                       CNI43730
      STOP                                                              CNI43740
  919 WRITE (LOUTPT,920) (I,EIGVAL(I),I=1,N)                            CNI43750
  920 FORMAT (' BETA DIAGONALIZATION GAVE',                             CNI43760
     1' EIVECTORS.GT.1. EIGENVECTOR MATRIX FOLLOWS'                     CNI43770
     2/ ' BUT FIRST THE EIGENENERGIES'/                                 CNI43780
     399( ' EN(',I3,')= ',D20.10/))                                     CNI43790
      WRITE (LOUTPT,1012) RHO,N                                         CNI43800
      WRITE (LOUTPT,1011) ((I,J,B(I,J),J=1,N),I=1,N)                    CNI43810
      STOP                                                              CNI43820
C-----DIAGNOSTIC ERROR MESSSAGES SECTION ENDS---------------------------CNI43470
  999 RETURN                                                            CNI43830
CE.20 END OF SCFOPN (CNDOP)---------------------------------------------CNI43840
      END                                                               CNI43850
      SUBROUTINE OPRINT (A,B,C,XXX,EIGVAL,PDIAG,IATNO,ICORE,IOR2AT,     CNI43860
     1LIMU,LIML,ITITLE,ENERGY)                                          CNI43870
CB.21 LAST CHANGE 17 JUL 1998 (CNDOP)-----------------------------------CNI43880
C     CALLED BY: MAIN  (03)                                             CNI43890
C     CALLS    : SCFOUT(23)                                             CNI43900
C-----PRINT ALPHA AND BETA BOND ORDER, TOTAL DENSITY AND SPIN DENSITY   CNI43910
C-----MATRICES (OPEN SHELL)---------------------------------------------CNI43920
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI43930
      CHARACTER*4 ITITOL,ITITLE,EL                                      CNI43935
      INTEGER OPTION,CNDO,LIML,ANI,UL                                   CNI44080
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI43940
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI43950
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI43960
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI43970
      COMMON/INFOX/NATOMS,II1(2),N,II2(3),LIMG,IPREC                    CNI43990
      COMMON/CHOICE/OPTION,II3(2),CNDO,INDO,II4(2)                      CNI44000
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI44060
     1RKAPPA(35,6)                                                      CNI44070
      DIMENSION A(N,N),B(N,N),C(NATOMS,3),XXX(NATOMS),EIGVAL(N),        CNI44010
     1PDIAG(N),IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),      CNI44020
     2LIML(NATOMS),ITITLE(NATOMS)                                       CNI44030
      DIMENSION CISO(10)                                                CNI44050
      K=NATOMS-1                                                        CNI44090
C-----BONDORDER HALF MATRICES ARE NOW BEING STORED IN FULL MATRICES FOR CNI44100
C-----PRINTING---ALPHA IN B AND BETA IN A ------------------------------CNI44110
      DO 40 I=1,N                                                       CNI44120
         A(I,I)=PDIAG(I)                                                CNI44130
         LL=I+1                                                         CNI44140
         IF (LL.GT.N) GO TO 40                                          CNI44150
         DO 35 J=LL,N                                                   CNI44160
            A(I,J)=B(I,J)                                               CNI44170
            A(J,I)=B(I,J)                                               CNI44180
            B(I,J)=B(J,I)                                               CNI44190
   35    CONTINUE                                                       CNI44200
   40 CONTINUE                                                          CNI44210
      IF (IFIELD.GT.0) GO TO 70                                         CNI44220
      WRITE (LOUTPT,50)                                                 CNI44230
   50 FORMAT(1X,23H ALPHA BONDORDER MATRIX//)                           CNI44240
C *** PRINT BOND ORDER MATRIX FOR ALPHA SPINS---------------------------CNI44250
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI44260
      WRITE (LOUTPT,60)                                                 CNI44270
   60 FORMAT(1X,22H BETA BONDORDER MATRIX//)                            CNI44280
C *** PRINT BOND ORDER MATRIX FOR BETA SPINS----------------------------CNI44290
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI44300
   70 CONTINUE                                                          CNI44310
      DO 80 I=1,N                                                       CNI44320
         DO 80 J=1,N                                                    CNI44330
            B(I,J)=A(I,J)+B(I,J)                                        CNI44340
            A(I,J)=B(I,J)-2.D0*A(I,J)                                   CNI44350
   80 CONTINUE                                                          CNI44360
      IF (IFIELD.GT.0) GO TO 101                                        CNI44370
      WRITE (LOUTPT,90)                                                 CNI44380
   90 FORMAT(1X,25H SCF TOTAL DENSITY MATRIX//)                         CNI44390
C *** PRINT SCF TOTAL DENSITY MATRIX------------------------------------CNI44400
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI44410
      WRITE (LOUTPT,100)                                                CNI44420
  100 FORMAT(1X,24H SCF SPIN DENSITY MATRIX//)                          CNI44430
C *** PRINT SCF SPIN DENSITY MATRIX-------------------------------------CNI44440
      IF (IBRIEF.EQ.0) CALL SCFOUT (0,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)  CNI44450
  101 CONTINUE                                                          CNI44460
      DO 110 I=1,K                                                      CNI44470
         L=I+1                                                          CNI44480
         DO 110 J=L,NATOMS                                              CNI44490
            RAD=DSQRT((C(I,1)-C(J,1))**2+(C(I,2)-C(J,2))**2             CNI44500
     1      +(C(I,3)-C(J,3))**2)                                        CNI44510
            ENERGY=ENERGY+(DBLE(FLOAT(ICORE(I)))*                       CNI44520
     1      DBLE(FLOAT(ICORE(J))))/RAD                                  CNI44520
  110 CONTINUE                                                          CNI44530
      WRITE (LOUTPT,120) ENERGY                                         CNI44540
  120 FORMAT(/10X,' TOTAL ENERGY =', F16.10)                            CNI44550
      DO 130 I=1,NATOMS                                                 CNI44560
         ANI=IATNO(I)                                                   CNI44570
  130 ENERGY=ENERGY-ATENG(ANI)                                          CNI44580
      WRITE (LOUTPT,140) ENERGY                                         CNI44590
  140 FORMAT(/10X,'BINDING ENERGY=',F18.10,' A.U.')                     CNI44600
      CISO(1) = 539.8635D0                                              CNI44610
      CISO(6) = 820.0959D0                                              CNI44620
      CISO(7) = 379.3557D0                                              CNI44630
      CISO(8) = 888.6855D0                                              CNI44640
      CISO(9) = 44829.2 D0                                              CNI44650
      WRITE (LOUTPT,150)                                                CNI44660
  150 FORMAT(15X,'VALENCE',10X,'S ORBITAL',10X,'HYPERFINE')             CNI44670
      WRITE (LOUTPT,160)                                                CNI44680
  160 FORMAT(10X,'*ELECTRON DENSITY*  *SPIN DENSITY*',                  CNI44690
     1'  *COUPLING CONSTANT*  *NET CHARGE*')                            CNI44700
      WRITE (LOUTPT,170)                                                CNI44710
  170 FORMAT(80X)                                                       CNI44720
      DO 200 I=1,NATOMS                                                 CNI44730
         TCHG = 0.D0                                                    CNI44740
         LL=LIML(I)                                                     CNI44750
         UL=LIMU(I)                                                     CNI44760
         ANI=IATNO(I)                                                   CNI44770
         HFC=CISO(ANI)*A(LL,LL)                                         CNI44780
         IF (OPTION.EQ.INDO) GO TO 2                                    CNI44790
    1    HFC=0.0                                                        CNI44800
    2    CONTINUE                                                       CNI44810
         DO 180 J=LL,UL                                                 CNI44820
  180    TCHG = TCHG+B(J,J)                                             CNI44830
         CHGNET=ICORE(I)-TCHG                                           CNI44840
         WRITE (LOUTPT,190) I,EL(ANI),TCHG,A(LL,LL),HFC,CHGNET,         CNI44850
     1   ITITLE(I)                                                      CNI44860
  190    FORMAT (I3,A4,8X,F7.4,10X,F7.4,12X,F9.4,5X,F12.6,4X,A4)        CNI44870
         XXX(I)=TCHG                                                    CNI44880
  200 CONTINUE                                                          CNI44890
      RETURN                                                            CNI44900
CE.21 END OF OPRINT (CNDOP)---------------------------------------------CNI44910
      END                                                               CNI44920
      SUBROUTINE EIGN (N,RHO,A,VEC,GAMMA,BETA,BETASQ,EIGVAL,XX9,P,Q,    CNI44930
     1IPOSV,IVPOS,IORD)                                                 CNI44940
CB.22 LAST CHANGE 13 JUN 1984 (CNDOP)                                   CNI44950
C     CALLED BY: HUCKCL(15),SCFCLO(16),HUCKOP(19),SCFOPN(20),ON(39)-----CNI44960
C     CALLS    : NONE                                                   CNI44970
C-----GIVENS-HOUSEHOLDER DIAGONALIZATION ROUTINE------------------------CNI44980
C     RHO=     UPPER LIMIT FOR OFF-DIAGONAL ELEMENT                     CNI45000
C     N =      SIZE OF MATRICES                                         CNI45010
C     A =      F MATRIX (LOWER TRIANGLE IS USED AND IS DESTROYED)       CNI45020
C     EIGVAL = RETURNED EIGENVALUES IN ALGEBRAIC ASCENDING ORDER        CNI45030
C-----VEC    = RETURNED EIGENVECTORS IN COLUMNS-------------------------CNI45040
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI44990
      DIMENSION A(N,N),VEC(N,N),GAMMA(N),BETA(N),BETASQ(N),EIGVAL(N),   CNI45050
     1XX9(N),P(N),Q(N),IPOSV(N),IVPOS(N),IORD(N)                        CNI45060
C-----NOTE THAT BETASQ(N) AND IORD(N) SHARE THE SAME LOCATION-----------CNI
      RHOSQ=RHO*RHO                                                     CNI45070
      IF (N .EQ. 0) GO TO 640                                           CNI45080
   10 N1=N-1                                                            CNI45090
      N2=N-2                                                            CNI45100
      GAMMA(1)=A(1,1)                                                   CNI45110
      IF(N2) 200,190,40                                                 CNI45120
   40 DO 180 NR=1,N2                                                    CNI45130
         B=A(NR+1,NR)                                                   CNI45140
         S=0.D0                                                         CNI45150
         DO 50 I=NR,N2                                                  CNI45160
   50    S=S+A(I+2,NR)**2                                               CNI45170
C--------PREPARE FOR POSSIBLE BYPASS OF TRANSFORMATION                  CNI45180
         A(NR+1,NR)=0.D0                                                CNI45190
         IF (S) 170,170,60                                              CNI45200
   60    S=S+B*B                                                        CNI45210
         SGN=+1.D0                                                      CNI45220
         IF (B) 70,80,80                                                CNI45230
   70    SGN=-1.D0                                                      CNI45240
   80    SQRTS=DSQRT(S)                                                 CNI45250
         D=SGN/(SQRTS+SQRTS)                                            CNI45260
         TEMP=DSQRT(.5D0+B*D)                                           CNI45270
         XX9(NR)=TEMP                                                   CNI45280
         A(NR+1,NR)=TEMP                                                CNI45290
         D=D/TEMP                                                       CNI45300
         B=-SGN*SQRTS                                                   CNI45310
C--------D IS FACTOR OF PROPORTIONALITY. NOW COMPUTE AND SAVE XX9.      CNI45320
C--------EXTRA SINGLY SUBSCRIPTED XX9 VECTOR USED FOR SPEED.            CNI45330
         DO 90 I=NR,N2                                                  CNI45340
            TEMP=D*A(I+2,NR)                                            CNI45350
            XX9(I+1)=TEMP                                               CNI45360
   90    A(I+2,NR)=TEMP                                                 CNI45370
C--------PREMULTIPLY VECTOR XX9 BY MATRIX A TO OBTAIN P VECTOR.         CNI45380
C--------SIMULTANEOUSLY ACCUMULATE DOT PRODUCT WP,(THE SCALAR K)        CNI45390
         WTAW=0.D0                                                      CNI45400
         DO 140 I=NR,N1                                                 CNI45410
            SUM=0.D0                                                    CNI45420
            DO 100 J=NR,I                                               CNI45430
  100       SUM=SUM+A(I+1,J+1)*XX9(J)                                   CNI45440
            I1=I+1                                                      CNI45450
            IF (N1-I1) 130,110,110                                      CNI45460
  110       DO 120 J=I1,N1                                              CNI45470
  120       SUM=SUM+A(J+1,I+1)*XX9(J)                                   CNI45480
  130       P(I)=SUM                                                    CNI45490
  140    WTAW=WTAW+SUM*XX9(I)                                           CNI45500
C--------P VECTOR AND SCALAR K  NOW STORED. NEXT COMPUTE Q VECTOR       CNI45510
         DO 150 I=NR,N1                                                 CNI45520
  150    Q(I)=P(I)-WTAW*XX9(I)                                          CNI45530
C--------NOW FORM PAP MATRIX, REQUIRED PART                             CNI45540
         DO 160 J=NR,N1                                                 CNI45550
            QJ=Q(J)                                                     CNI45560
            WJ=XX9(J)                                                   CNI45570
            DO 159 I=J,N1                                               CNI45580
               A(I+1,J+1)=A(I+1,J+1)-2.D0*(XX9(I)*QJ+WJ*Q(I))           CNI45590
  159       CONTINUE                                                    CNI45600
  160    CONTINUE                                                       CNI45610
  170    BETA(NR)=B                                                     CNI45620
         BETASQ(NR)=B*B                                                 CNI45630
  180 GAMMA(NR+1)=A(NR+1,NR+1)                                          CNI45640
  190 B=A(N,N-1)                                                        CNI45650
      BETA(N-1)=B                                                       CNI45660
      BETASQ(N-1)=B*B                                                   CNI45670
      GAMMA(N)=A(N,N)                                                   CNI45680
  200 BETASQ(N)=0.D0                                                    CNI45690
C-----ADJOIN AN IDENTITY MATRIX TO BE POSTMULTIPLIED BY ROTATIONS.      CNI45700
      DO 220 I=1,N                                                      CNI45710
         DO 210 J=1,N                                                   CNI45720
  210    VEC(I,J)=0.D0                                                  CNI45730
  220 VEC(I,I)=1.D0                                                     CNI45740
      M=N                                                               CNI45750
      SUM=0.D0                                                          CNI45760
      NPAS=1                                                            CNI45770
      GO TO 350                                                         CNI45780
  230 SUM=SUM+SHIFT                                                     CNI45790
      COSA=1.D0                                                         CNI45800
      G=GAMMA(1)-SHIFT                                                  CNI45810
      PP=G                                                              CNI45820
      PPBS=PP*PP+BETASQ(1)                                              CNI45830
      PPBR=DSQRT(PPBS)                                                  CNI45840
      DO 320 J=1,M                                                      CNI45850
         COSAP=COSA                                                     CNI45860
         IF (PPBS.GT.0.1D-04*RHOSQ) GO TO 250                           CNI45870
  240    SINA=0.D0                                                      CNI45880
         SINA2=0.D0                                                     CNI45890
         COSA=1.D0                                                      CNI45900
         GO TO 290                                                      CNI45910
  250    SINA=BETA(J)/PPBR                                              CNI45920
         SINA2=BETASQ(J)/PPBS                                           CNI45930
         COSA=PP/PPBR                                                   CNI45940
C--------POSTMULTIPLY IDENTITY BY P-TRANSPOSE MATRIX                    CNI45950
         NT=J+NPAS                                                      CNI45960
         IF (NT .LT. N) GO TO 270                                       CNI45970
  260    NT=N                                                           CNI45980
  270    DO 280 I=1,NT                                                  CNI45990
            TEMP=COSA*VEC(I,J)+SINA*VEC(I,J+1)                          CNI46000
            VEC(I,J+1)=-SINA*VEC(I,J)+COSA*VEC(I,J+1)                   CNI46010
  280    VEC(I,J)=TEMP                                                  CNI46020
  290    DIA=GAMMA(J+1)-SHIFT                                           CNI46030
         U=SINA2*(G+DIA)                                                CNI46040
         GAMMA(J)=G+U                                                   CNI46050
         G=DIA-U                                                        CNI46060
         PP=DIA*COSA-SINA*COSAP*BETA(J)                                 CNI46070
         IF (J .NE. M) GO TO 310                                        CNI46080
  300    BETA(J)=SINA*PP                                                CNI46090
         BETASQ(J)=SINA2*PP*PP                                          CNI46100
         GO TO 330                                                      CNI46110
  310    PPBS=PP*PP+BETASQ(J+1)                                         CNI46120
         PPBR=DSQRT(PPBS)                                               CNI46130
         BETA(J)=SINA*PPBR                                              CNI46140
  320 BETASQ(J)=SINA2*PPBS                                              CNI46150
  330 GAMMA(M+1)=G                                                      CNI46160
C-----TEST FOR CONVERGENCE OF LAST DIAGONAL ELEMENT                     CNI46170
      NPAS=NPAS+1                                                       CNI46180
      IF(BETASQ(M) .GT. RHOSQ) GO TO 370                                CNI46190
  340 EIGVAL(M+1)=GAMMA(M+1)+SUM                                        CNI46200
  350 BETA(M)=0.D0                                                      CNI46210
      BETASQ(M)=0.D0                                                    CNI46220
      M=M-1                                                             CNI46230
      IF(M .EQ. 0) GO TO 400                                            CNI46240
  360 IF(BETASQ(M) .LE. RHOSQ) GO TO 340                                CNI46250
C-----TAKE ROOT OF CORNER 2 BY 2 NEAREST TO LOWER DIAGONAL IN VALUE     CNI46260
C-----AS ESTIMATE OF EIGENVALUE TO USE FOR SHIFT                        CNI46270
  370 A2=GAMMA(M+1)                                                     CNI46280
      R2=0.5D0*A2                                                       CNI46290
      R1=0.5D0*GAMMA(M)                                                 CNI46300
      R12=R1+R2                                                         CNI46310
      DIF=R1-R2                                                         CNI46320
      TEMP=DSQRT(DIF*DIF+BETASQ(M))                                     CNI46330
      R1=R12+TEMP                                                       CNI46340
      R2=R12-TEMP                                                       CNI46350
      DIF=DABS(A2-R1)-DABS(A2-R2)                                       CNI46360
      IF(DIF .LT. 0.D0) GO TO 390                                       CNI46370
  380 SHIFT=R2                                                          CNI46380
      GO TO 230                                                         CNI46390
  390 SHIFT=R1                                                          CNI46400
      GO TO 230                                                         CNI46410
  400 EIGVAL(1)=GAMMA(1)+SUM                                            CNI46420
C-----INITIALIZE AUXILIARY TABLES REQUIRED FOR REARRANGING THE VECTORS  CNI46430
      DO 410 J=1,N                                                      CNI46440
         IPOSV(J)=J                                                     CNI46450
         IVPOS(J)=J                                                     CNI46460
  410 IORD(J)=J                                                         CNI46470
C-----USE A TRANSPOSITION SORT TO ORDER THE EIGENVALUES-----------------CNI46480
      M=N                                                               CNI46490
      GO TO 450                                                         CNI46500
  420 DO 440 J=1,M                                                      CNI46510
         IF (EIGVAL(J).LE.EIGVAL(J+1)) GO TO 440                        CNI46520
  430    TEMP       =EIGVAL(J  )                                        CNI46530
         EIGVAL(  J)=EIGVAL(J+1)                                        CNI46540
         EIGVAL(J+1)=TEMP                                               CNI46550
         ITEMP      =IORD(J)                                            CNI46560
         IORD(J)    =IORD(J+1)                                          CNI46570
         IORD(J+1)  =ITEMP                                              CNI46580
  440 CONTINUE                                                          CNI46590
  450 M=M-1                                                             CNI46600
      IF (M.NE.0) GO TO 420                                             CNI46610
  460 IF (N1.EQ.0) GO TO 510                                            CNI46620
  470 DO 500 L=1,N1                                                     CNI46630
         NV=IORD(L)                                                     CNI46640
         NP=IPOSV(NV)                                                   CNI46650
         IF (NP.EQ.L) GO TO 500                                         CNI46660
  480    LV=IVPOS(L)                                                    CNI46670
         IVPOS(NP)=LV                                                   CNI46680
         IPOSV(LV)=NP                                                   CNI46690
         DO 490 I=1,N                                                   CNI46700
            TEMP=VEC(I,L)                                               CNI46710
            VEC(I,L)=VEC(I,NP)                                          CNI46720
  490    VEC(I,NP)=TEMP                                                 CNI46730
  500 CONTINUE                                                          CNI46740
C-----BACK TRANSFORM THE VECTORS OF THE TRIPLE DIAGONAL MATRIX----------CNI46760
  510 DO 570 NRR=1,N                                                    CNI46770
         K=N1                                                           CNI46780
  520    K=K-1                                                          CNI46790
         IF (K .LE. 0) GO TO 560                                        CNI46800
  530    SUM=0.D0                                                       CNI46810
         DO 540 I=K,N1                                                  CNI46820
  540    SUM=SUM+VEC(I+1,NRR)*A(I+1,K)                                  CNI46830
         SUM=SUM+SUM                                                    CNI46840
         DO 550 I=K,N1
  550    VEC(I+1,NRR)=VEC(I+1,NRR)-SUM*A(I+1,K)                         CNI46860
         GO TO 520                                                      CNI46870
  560    CONTINUE                                                       CNI46880
  570 CONTINUE                                                          CNI46890
  640 RETURN                                                            CNI46900
CE.22 END OF EIGN (CNDOP)-----------------------------------------------CNI46910
      END                                                               CNI46920
      SUBROUTINE SCFOUT (OP,A,EIGVAL,IATNO,IOR2AT,LIMU,LIML)            CNI46930
CB.23 LAST CHANGE 16 NOV 2020 (CNDOP)                                   CNI46940
C     CALLED BY: SCFCLO(16),SCFOPN(20)                                  CNI46950
C     CALLS    : EIGOUT(24)                                             CNI46960
C-----PRINTS MATRICES WITH CAPTIONS AND EIGENVALUES IF NEEDED           CNI46970
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI46980
      CHARACTER*4 EL
      INTEGER ITITOL,HOMO,ZERO,CATCH(7),OP,ORB,ANII                     CNI46985
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI47020
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI47030
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI47040
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI47050
      COMMON/INFOX/NATOMS,II1(2),N,II2(3),LIMG,IPREC                    CNI47070
      COMMON/ORBITS/ORB(9)                                              CNI47080
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      DIMENSION A(N,N),EIGVAL(N),IATNO(NATOMS),IOR2AT(N),LIMU(NATOMS),  CNI47100
     1LIML(NATOMS)                                                      CNI47110
      DATA HOMO/'HOMO'/,ZERO/'    '/                                    CNI4711S
      DATA EL/4H   H,4H  HE,4H  LI,4H  BE,4H   B,4H   C,4H   N,4H   O,  CNI09150
     1 4H   F,4H  NE,4H  NA,4H  MG,4H  AL,4H  SI,4H   P,4H   S,4H  CL,  CNI09160
     2 4H  AR,4H   K,4H  CA,4H  SC,4H  TI,4H   V,4H  CR,4H  MN,4H  FE,  CNI09170
     3 4H  CO,4H  NI,4H  CU,4H  ZN,4H  GA,4H  GE,4H  AS,4H  SE,4H  BR/  CNI09180
      DO 10 II=1,7                                                      CNI47112
         CATCH(II)=ZERO                                                 CNI47113
   10 CONTINUE                                                          CNI47114
      DO 120 M=1,N,7                                                    CNI47120
         K=M+6                                                          CNI47130
         IF (K.LE.N) GO TO 30                                           CNI47140
   20    K=N                                                            CNI47150
   30    CONTINUE                                                       CNI47160
         WRITE (LOUTPT,100)                                             CNI47170
  100    FORMAT(1X)                                                     CNI47350
C--------IF OP = 1 THE EIGENVALES ARE ALSO PRINTED                      CNI47174
C--------IF OP = 0 THE EIGENVALUES ARE NOT PRINTED                      CNI47176
         IF (OP.EQ.1) GO TO 40                                          CNI47180
         GO TO 50                                                       CNI47190
   40    MM=M                                                           CNI47200
C ***    PRINT THE EIGENVALUES                                          CNI47210
         CALL EIGOUT (MM,K,EIGVAL)                                      CNI47220
   50    CONTINUE                                                       CNI47230
         WRITE (LOUTPT,60) (I,I=M,K)                                    CNI47240
   60    FORMAT(10X,50I9)                                               CNI47250
         DO 61 II=1,7                                                   CNI47251
            CATCH(II)=ZERO                                              CNI47252
            IF (M+II-1.EQ.NHOMO) CATCH(II)=HOMO                         CNI47253
   61    CONTINUE                                                       CNI47254
         IF (OP.EQ.1) WRITE (LOUTPT,65) (CATCH(II),II=1,7)              CNI47254
   65    FORMAT (17X,50(2X,A4,3X))                                      CNI47256
         CATCH(IPL7)=ZERO                                               CNI47258
         DO 110 I=1,N                                                   CNI47260
            II=IOR2AT(I)                                                CNI47270
            ANII=IATNO(II)                                              CNI47280
            L=I-LIML(II)+1                                              CNI47290
   70       WRITE (LOUTPT,80) I,II,EL(ANII),ORB(L),(A(I,J),J=M,K)       CNI47300
   80       FORMAT (2X,I3,I3,2X,A4,5X,A4,50(F9.4))
            IF (I.EQ.LIMU(II)) GO TO 90                                 CNI47320
            GO TO 110                                                   CNI47330
   90       WRITE (LOUTPT,100)                                          CNI47340
  110    CONTINUE                                                       CNI47360
  120 CONTINUE                                                          CNI47370
      WRITE (LOUTPT,100)                                                CNI47380
      WRITE (LOUTPT,100)                                                CNI47390
      RETURN                                                            CNI47400
CE.23 END OF SCFOUT (CNDOP)---------------------------------------------CNI47410
      END                                                               CNI47420
      SUBROUTINE EIGOUT (M,K,EIGVAL)                                    CNI47430
CB.24 LAST CHANGE 25 FEB 1988 (CNDOP)-----------------------------------CNI47440
C     CALLED BY: SCFOUT(23)                                             CNI47450
C     CALLS    : NONE                                                   CNI47460
C-----PRINTS OUT EIGENVALUES                                            CNI47470
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI47480
      CHARACTER*4 ITITOL                                                CNI47485
C-----THIS ROUTINE IS CALLED BY SCFOUT TO PRINT THE EIGENVALUES M TO K  CNI47490
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI47500
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI47510
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI47520
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI47530
      COMMON/INFOX/II1(3),N,II2(3),LIMG,IPREC                           CNI47550
      DIMENSION EIGVAL(N)                                               CNI47560
      DIMENSION EPSIEV(11)                                              CNI47570
      MM=M-1                                                            CNI47580
      MOUT=0                                                            CNI47590
      DO 1 I=1,7                                                        CNI47600
         MM=MM+1                                                        CNI47610
         MOUT=MOUT+1                                                    CNI47620
         EPSIEV(I)=EIGVAL(MM)*HARTRE                                    CNI47630
         IF (MM.GE.K) GO TO 2                                           CNI47640
    1 CONTINUE                                                          CNI47650
    2 WRITE (LOUTPT,3) (EIGVAL(I),I=M,K)                                CNI47660
    3 FORMAT(' EIGENVALUES---',20(F9.4))                                CNI47670
      WRITE (LOUTPT,4) (EPSIEV(I),I=1,MOUT)                             CNI47680
    4 FORMAT  (' ENERGIES (EV) ',20(F9.4)//)                            CNI47690
      RETURN                                                            CNI47700
CE.24 END OF EIGOUT (CNDOP)---------------------------------------------CNI47710
      END                                                               CNI47720
      SUBROUTINE RANNUM (IX,IY,YFL)                                     CNI47730
CB.25 LAST CHANGE 24 MAR 1989 (CNDOP)-----------------------------------CNI47740
C     CALLED BY: SCFCLO(16),SCFOPN(20)                                  CNI47750
C     CALLS    : NONE                                                   CNI47760
C-----RANDOM NUMBER GENERATOR                                           CNI47770
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI47780
C-----THIS IS A RANDOM NUMBER GENERATOR PATTERNED AFTER-----------------CNI47790
C     IBM SCIENTIFIC SUBROUTINE PACKAGE SUBROUTINE RANDU                CNI47800
C     (IBM PUBLICATION H20-0205-3 (1968) PAGE 77)                       CNI47810
C     SEE ALSO D.KNUTH, SEMINUMERICAL ALGORITHMS, VOL. II OF            CNI47820
C     THE ART OF SCIENTIFIC PROGRAMMING (ADDISON-WESLEY, READING, MASS.,CNI47830
C-----PAGES 1-155                                                       CNI47840
CCRA  CRAY X-MP/24: 64-BIT WORD INTEG=2**46-1=7.03687E+14               CNI
CCRA  (USING ONLY 46 BITS)      ISEED=2**24+3=16777216+3 (A GUESS)      CNI
CCRA                            RECIP=1.42108E-14                       CNI
CIBM  IBM 360, 32-BIT WORD:  INTEG=2147483647=2**31-1                   CNI47850
CIBM  (AND IBM 370)          ISEED=65539     =2**16+3                   CNI47860
CIBM                         RECIP=0.4656613E-9=1./INTEG IN SINGLE      CNI47870
CIBM                         PRECISION                                  CNI47880
CDEC  DEC 1077, 36-BIT WORD: INTEG=34359738367=2**35-1                  CNI47890
CDEC                         ISEED=262147     =2**18+3 (A GUESS)        CNI47900
CDEC                         RECIP=0.291038304575807366D-10 IN          CNI47910
CDEC                         DOUBLE PRECISION                           CNI47920
CVAX  DEFEAT INTEGER OVERFLOW TRAP FOR VAX/11780:                       CNI47930
CVAX  CALL ERRSET (70,.TRUE.,.FALSE.,.FALSE.,.FALSE.,0)                 CNI47940
CVAX  ABOVE STATEMENT SUPPRESSES ALL ARITHMETIC OVERFLOW MESSAGES       CNI47950
CIBM  IY=IX*65539                                                       CNI47960
CDEC  CALL ERRSET (0)                                                   CNI47970
CDEC  IY=IX*262147                                                      CNI47980
CCRA  IY=IX*16777219                                                    CNI
      IY=IX*65539                                                       CNI47990
      IF (IY.GE.0) GO TO 1                                              CNI48000
CDEC  IY=IY+34359738367+1                                               CNI48010
CIBM  IY=IY+ 2147483647+1                                               CNI48020
CCRA  IY=IY+70368700000000+1                                            CNI
      IY=IY+2147483647+1                                                CNI48030
    1 YFL=IY                                                            CNI48040
CDEC  YFL=YFL*0.291038304575807366D-10                                  CNI48050
CIBM  YFL=YFL*0.4656613D-09                                             CNI48060
CCRA  YFL=YFL*1.42108D-14                                               CNI
      YFL=YFL*0.4656613D-09                                             CNI48070
      RETURN                                                            CNI48080
CE.25 END OF RANNUM (CNDOP)---------------------------------------------CNI48090
      END                                                               CNI48100
      SUBROUTINE AXEQB(A1,X,B1,JJJ)                                     CNI48110
CB.26 LAST CHANGE 25 AUG 2014 (CNDOP)-----------------------------------CNI48120
C     CALLED BY: EIG3  (27)                                             CNI48130
C     CALLS    : NONE                                                   CNI48140
C-----SOLVES MATRIX EQUATION A*X = B FOR X                              CNI48150
C     ROUTINE FROM CARROL K. JOHNSONS ORTEP                             CNI48160
C     ***** USES METHOD OF TRIANGULAR ELIMINATION *****                 CNI48170
C     ***** B AND X HAVE DIMENSIONS (3,JJJ),A IS ALWAYS (3,3)           CNI48180
C     ***** TO INVERT A MAKE B 3 BY 3 IDENITY MATRIX *****              CNI48190
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI48200
      CHARACTER*4 ITITOL                                                CNI48205
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI48210
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI48220
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI48230
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI48240
      DIMENSION A1(3,3),A(3,3),B(3,3),B1(3,JJJ),X(3,JJJ)                CNI48260
      NV=JJJ                                                            CNI48270
C-----TRANSFER DATA *****                                               CNI48280
      DO 2 I=1,3                                                        CNI48290
         DO 2 J=1,3                                                     CNI48300
            IF(NV-J)2,1,1                                               CNI48310
    1    B(I,J)=B1(I,J)                                                 CNI48320
    2 A(I,J)=A1(I,J)                                                    CNI48330
C-----TRIANGULARIZE MATRIX A *****                                      CNI48340
      DO 17 I=1,2                                                       CNI48350
         S=0.0                                                          CNI48360
         DO 4 J=I,3                                                     CNI48370
            R=DABS(A(J,I))                                              CNI48380
            IF(R-S)4,3,3                                                CNI48390
    3       S=R                                                         CNI48400
            L=J                                                         CNI48410
    4    CONTINUE                                                       CNI48420
         IF(L-I)5,10,5                                                  CNI48430
    5    DO 6 J=I,3                                                     CNI48440
            S=A(I,J)                                                    CNI48450
            A(I,J)=A(L,J)                                               CNI48460
    6    A(L,J)=S                                                       CNI48470
         DO 8 J=1,NV                                                    CNI48480
            S=B(I,J)                                                    CNI48490
            B(I,J)=B(L,J)                                               CNI48500
    8    B(L,J)=S                                                       CNI48510
   10    TEM=A(I,I)                                                     CNI48520
         IF(TEM)11,17,11                                                CNI48530
   11    IPO=I+1                                                        CNI48540
         DO 16 J=IPO,3                                                  CNI48550
            IF(A(J,I))12,16,12                                          CNI48560
   12       S=A(J,I)/TEM                                                CNI48570
            A(J,I)=0.0                                                  CNI48580
            DO 13 K=IPO,3                                               CNI48590
   13       A(J,K)=A(J,K)-A(I,K)*S                                      CNI48600
            DO 15 K=1,NV                                                CNI48610
   15       B(J,K)=B(J,K)-B(I,K)*S                                      CNI48620
   16    CONTINUE                                                       CNI48630
   17 CONTINUE                                                          CNI48640
C-----MODIFY SINGULAR MATRIX *****                                      CNI48650
      DO 20 I=1,3                                                       CNI48660
         IF(A(I,I))20,19,20                                             CNI48670
   19    A(I,I)=DMAX1(1.D-18,DMAX1(A(1,1),A(2,2),A(3,3))*1.D-10)        CNI48680
   20 CONTINUE                                                          CNI48690
      DO 24 K=1,NV                                                      CNI48700
         DO 24 I=1,3                                                    CNI48710
            N=4-I                                                       CNI48720
            M=N+1                                                       CNI48730
            TEM=B(N,K)                                                  CNI48740
            IF(3-M)23,21,21                                             CNI48750
   21       DO 22 J=M,3                                                 CNI48760
   22       TEM=TEM-A(N,J)*B(J,K)                                       CNI48770
   23       B(N,K)=TEM/A(N,N)                                           CNI48780
   24 X(N,K)=B(N,K)                                                     CNI48790
      RETURN                                                            CNI48800
CE.26 END OF AXEQB (CNDOP)----------------------------------------------CNI48810
      END                                                               CNI48820
      SUBROUTINE EIG3 (W,VALU,VECT)                                     CNI48830
CB.27 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI48840
C     CALLED BY: DIPOLE(18)                                             CNI48850
C     CALLS    : AXEQB (26)                                             CNI48860
C-----EIGENVALUES AND EIGENVECTORS OF A 3 X 3 MATRIX--------------------CNI48870
C-----ROUTINE FROM CARROL K. JOHNSONS ORTEP-----------------------------CNI48880
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI48890
      CHARACTER*4 ITITOL                                                CNI48895
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI48900
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI48910
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI48920
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI48930
      DIMENSION W(3,3),VALU(3),VECT(3,3),A(3,3),B(3,3),V(3),U(3)        CNI48950
C-----STATEMENT FUNCTION -----------------------------------------------CNI48960
      PHIF(Z)=((B2-Z)*Z+B1)*Z+B0                                        CNI48970
C-----PHIF(Z)= -Z**3 + B2*Z**2 + B1*Z + B0 -----------------------------CNI48980
      ERRND=5.D-7                                                       CNI48990
C-----TRANSFER INPUT MATRIX TO MATRIX A.--------------------------------CNI49000
C     COMPUTE SUM OF SQUARES OF ALL ELEMENTS OF A, SIGMA.               CNI49010
C-----IF SIGMA.EQ.0, GIVE UP. ------------------------------------------CNI49020
      SIGMA=0.D0                                                        CNI49030
      DO 115 J=1,3                                                      CNI49040
         DO 115 I=1,3                                                   CNI49050
            TEM=W(I,J)                                                  CNI49060
            A(I,J)=TEM                                                  CNI49070
  115 SIGMA=SIGMA+TEM*TEM                                               CNI49080
C-----CHECK FOR NULL MATRIX --------------------------------------------CNI49090
      IF(SIGMA)901,901,120                                              CNI49100
  120 SIGMA=DSQRT(SIGMA)                                                CNI49110
C-----FORM CHARACTERISTIC EQUATION--------------------------------------CNI49120
C     SET UP THE DETERMINANTAL EQUATION:                                CNI49130
C         (A11-X   A12      A13    )                                    CNI49140
C     DET (A21     A22-X    A23    ) = 0.0                              CNI49150
C         (A31     A32      A33-X  )                                    CNI49160
C-----WHICH REDUCES TO: -X**3 + B2*X**2 + B1*X + B0 = 0.0---------------CNI49170
      B2=A(1,1)+A(2,2)+A(3,3)                                           CNI49180
      B1=-A(1,1)*A(2,2)-A(1,1)*A(3,3)-A(2,2)*A(3,3)+A(1,3)*A(3,1)       CNI49190
     1+A(2,3)*A(3,2)+A(1,2)*A(2,1)                                      CNI49200
      B0=A(1,1)*A(2,2)*A(3,3)+A(1,2)*A(2,3)*A(3,1)+A(1,3)*A(3,2)*A(2,1)-CNI49210
     1A(1,3)*A(3,1)*A(2,2)-A(1,1)*A(2,3)*A(3,2)-A(1,2)*A(2,1)*A(3,3)    CNI49220
C-----FIRST ROOT BY BISECTION-------------------------------------------CNI49230
      X=0.D0                                                            CNI49240
      Y=SIGMA                                                           CNI49250
      TEM=PHIF(SIGMA)                                                   CNI49260
      VNEW=0.D0                                                         CNI49270
      IF(B0)135,250,145                                                 CNI49280
  135 IF(TEM)140,140,165                                                CNI49290
  140 Y=-Y                                                              CNI49300
      GO TO 165                                                         CNI49310
  145 Y=0.D0                                                            CNI49320
      X=SIGMA                                                           CNI49330
      IF(TEM)165,165,150                                                CNI49340
  150 X=-X                                                              CNI49350
C-----NOW PHIF(X).LT.0.AND.PHIF(Y).GT.0.--------------------------------CNI49360
  165 VNEW=(X+Y)*.5D0                                                   CNI49370
      DO 225 I=1,40                                                     CNI49380
  175    IF(PHIF(VNEW))180,250,185                                      CNI49390
  180    X=VNEW                                                         CNI49400
         GO TO 200                                                      CNI49410
  185    Y=VNEW                                                         CNI49420
  200    VOLD=VNEW                                                      CNI49430
         VNEW=(X+Y)*.5D0                                                CNI49440
         TEM=DABS(VOLD-VNEW)                                            CNI49450
         IF(TEM-ERRND)250,250,205                                       CNI49460
  205    IF(VOLD)210,225,210                                            CNI49470
  210    IF (DABS(TEM/VOLD)-ERRND)250,250,225                           CNI49480
  225 CONTINUE                                                          CNI49490
C-----STORE FIRST ROOT -------------------------------------------------CNI49500
  250 U(3)=VNEW                                                         CNI49510
C-----DEFLATE ----------------------------------------------------------CNI49520
      C1=B2-VNEW                                                        CNI49530
      C0=B1+C1*VNEW                                                     CNI49540
C-----SOLVE QUADRATIC---------------------------------------------------CNI49550
      TEM=C1*C1+4.D0*C0                                                 CNI49560
      IF(TEM)255,265,260                                                CNI49570
C-----IGNORE IMAGINARY COMPONENT OF COMPLEX ROOT -----------------------CNI49580
  255 TEM=0.D0                                                          CNI49590
      GO TO 265                                                         CNI49600
  260 TEM=DSQRT(TEM)                                                    CNI49610
  265 U(1)=.5D0*(C1-TEM)                                                CNI49620
      U(2)=.5D0*(C1+TEM)                                                CNI49630
C-----SORT ROOTS--------------------------------------------------------CNI49640
      DO 275 J=1,2                                                      CNI49650
         IF(U(J)-U(3))275,275,270                                       CNI49660
  270    TEM=U(J)                                                       CNI49670
         U(J)=U(3)                                                      CNI49680
         U(3)=TEM                                                       CNI49690
  275 CONTINUE                                                          CNI49700
      LLL=-2                                                            CNI49710
      DO 375 III=1,2                                                    CNI49720
C--------CHECK FOR MULTIPLE ROOTS---------------------------------------CNI49730
         TEM=ERRND*100.D0                                               CNI49740
         NG=0                                                           CNI49750
         L=1                                                            CNI49760
         DO 305 I=1,2                                                   CNI49770
            IF(U(I+1)-U(I)-TEM)300,300,290                              CNI49780
  290       IF(U(I))295,305,295                                         CNI49790
  295       IF(DABS((U(I+1)-U(I))/U(I))-TEM)300,300,305                 CNI49800
  300       L=L-1                                                       CNI49810
            NG=NG-2*I                                                   CNI49820
  305    CONTINUE                                                       CNI49830
         IF(LLL-L)308,999,999                                           CNI49840
  308    LLL=L                                                          CNI49850
C--------EIGENVECTOR ROUTINE--------------------------------------------CNI49860
         DO 375 II=1,3                                                  CNI49870
            T1=U(II)                                                    CNI49880
            IF(L)315,310,322                                            CNI49890
C-----------TWO VECTORS NULL FOR DOUBLE ROOT----------------------------CNI49900
  310       IF(NG+5-II)315,322,315                                      CNI49910
C-----------ALL VECTORS NULL FOR TRIPLE ROOT----------------------------CNI49920
  315       DO 320 J=1,3                                                CNI49930
  320       VECT(J,II)=0.0D0                                            CNI49940
            GO TO 375                                                   CNI49950
  322       DO 325 J=1,3                                                CNI49960
  325       A(J,J)=W(J,J)-T1                                            CNI49970
            SMAX=0.D0                                                   CNI49980
            DO 355 I=1,3                                                CNI49990
               I1=1                                                     CNI50000
               IF(I-2)335,335,340                                       CNI50010
  335          I1=I+1                                                   CNI50020
  340          B(I,1)=A(I,2)*A(I1,3)-A(I,3)*A(I1,2)                     CNI50030
               B(I,2)=A(I,3)*A(I1,1)-A(I,1)*A(I1,3)                     CNI50040
               B(I,3)=A(I,1)*A(I1,2)-A(I,2)*A(I1,1)                     CNI50050
               TEM=B(I,1)**2+B(I,2)**2+B(I,3)**2                        CNI50060
               IF(TEM-SMAX)355,355,350                                  CNI50070
  350          SMAX=TEM                                                 CNI50080
               IMAX=I                                                   CNI50090
  355       CONTINUE                                                    CNI50100
            IF(SMAX)353,353,360                                         CNI50110
  353       NG=7                                                        CNI50120
            GO TO 375                                                   CNI50130
  360       SMAX=DSQRT(SMAX)                                            CNI50140
            DO 365 J=1,3                                                CNI50150
  365       V(J)=B(IMAX,J)/SMAX                                         CNI50160
C *** ------REFINE EIGENVECTOR -----------------------------------------CNI50170
            CALL AXEQB(A,V,V,1)                                         CNI50190
            TEM=DMAX1(DABS(V(1)),DABS(V(2)),DABS(V(3)))                 CNI50200
            DO 370 J=1,3                                                CNI50210
  370       V(J)=V(J)/TEM                                               CNI50220
            T1=DSQRT(V(1)*V(1)+V(2)*V(2)+V(3)*V(3))                     CNI50230
            VECT(1,II)=V(1)/T1                                          CNI50240
            VECT(2,II)=V(2)/T1                                          CNI50250
            VECT(3,II)=V(3)/T1                                          CNI50260
C-----------REFINE EIGENVALUE-------------------------------------------CNI50270
            T1=0.D0                                                     CNI50280
            DO 372 J=1,3                                                CNI50290
               T1=T1+VECT(J,II)*(W(J,1)*VECT(1,II)+                     CNI50300
     1         W(J,2)*VECT(2,II)+W(J,3)*VECT(3,II))                     CNI50310
  372       CONTINUE                                                    CNI50320
            U(II)=T1                                                    CNI50330
  375 VALU(II)=T1                                                       CNI50340
      GO TO 999                                                         CNI50350
C-----DIAGNOSTIC ERROR MESSAGES ----------------------------------------CNI50360
  901 WRITE (LOUTPT,902)                                                CNI50370
  902 FORMAT (' RUN ABORTED. FAULT IN EIG3. ERROR=6. DID NOT CONVERGE') CNI50380
      STOP                                                              CNI50400
  999 RETURN                                                            CNI50410
CE.27 END OF EIG3 (CNDOP)-----------------------------------------------CNI50420
      END                                                               CNI50430
      SUBROUTINE ORLOC (Q,QT,C,GAMA,IATNO,ICORE,IOR2AT,LIMU,LIML)       CNI50440
CB.28 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI50450
C     CALLED BY: MAIN  (03)                                             CNI50460
C     CALLS    : NONE                                                   CNI50470
C-----EDMISTON-RUEDENBERG LOCALISED MOLECULAR ORBITALS ROUTINE ---------CNI50480
C     QCPE 267  ORLOC= LOCALIZATION OF ORBITALS                         CNI50490
C     THE PROGRAM FINDS THE UNITARY TRANSFORMATION MATRIX WHICH         CNI50500
C     TRANSFORMS CNDOP MOLECULAR ORBITALS TO LOCALIZED ORBITALS         CNI50510
C     ACCORDING TO THE RECIPES OF:                                      CNI50520
C     C.TRINDLE AND O.SINANOGLU, J.CHEM.PHYS.49,65(1968)                CNI50530
C     C.EDMISTON AND K.RUEDENBERG, J.CHEM.PHYS.43,S97(1965)             CNI50540
C     C.EDMISTON AND K.RUEDENBERG, REV.MOD.PHYS.35,457(1963)            CNI50550
C     WRITTEN BY PAUL M.KUZNESOF, INSTITUTO DE QUIMICA, UNIVERSIDADE    CNI50570
C     ESTADUAL DE CAMPINAS, CAMPINAS, SP, BRAZIL.                       CNI50580
C     APRIL, 1974,FOR PDP-10 COMPUTER, THIS PROGRAM IS EASILY ADAPTABLE CNI50590
C-----TO OTHER SYSTEMS.-------------------------------------------------CNI50600
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI50610
      CHARACTER*4 ITITOL                                                CNI50615
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI50620
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI50630
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI50640
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI50650
      COMMON/INFOX/NATOMS,NCHARG,MULTIP,N,NELECS,NOCCA,NOCCB,LIMG,IPREC CNI50670
      DIMENSION Q(N,N),QT(N,N),C(N,N),GAMA(NATOMS,NATOMS),              CNI50680
     1IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS)   CNI50690
      DIMENSION T(10),TT(10),TTT(10),R(10),RR(10),RRR(10)               CNI50710
      NMOO=NOCCA                                                        CNI50720
      NMOMN1=NMOO-1                                                     CNI50730
      CONV=DSQRT(CONVRG)                                                CNI50740
C-----STORE INPUT MO,S IN MATRIX Q  ------------------------------------CNI50750
      DO 10 I=1,N                                                       CNI50760
         DO 10 J=1,N                                                    CNI50770
            Q(I,J)=C(J,I)                                               CNI50780
   10 CONTINUE                                                          CNI50790
      DO 20 I=1,N                                                       CNI50800
         DO 20 J=1,N                                                    CNI50810
            C(I,J)=Q(I,J)                                               CNI50820
   20 CONTINUE                                                          CNI50830
      WRITE (LOUTPT,30) NLOCIT                                          CNI50840
   30 FORMAT (' CALCULATION OF LOCALIZED MOS: LIMIT NLOCIT=',I4)        CNI50850
      NTERM=(NMOO*NMOO-NMOO)/2                                          CNI50860
      ICYC=0                                                            CNI50870
C-----BIG LOOP BEGINS --------------------------------------------------CNI50880
   40 CONTINUE                                                          CNI50890
      DO 140 I=1,NMOMN1                                                 CNI50900
         IPLUS1=I+1                                                     CNI50910
         DO 130 J=IPLUS1,NMOO                                           CNI50920
            ICYC=ICYC+1                                                 CNI50930
            IF (ICYC.GE.NLOCIT) GO TO 901                               CNI50940
            SRT= 0.0D0                                                  CNI50950
            SRT1=0.0D0                                                  CNI50960
            SRT2=0.0D0                                                  CNI50970
            SRT3=0.0D0                                                  CNI50980
            SRT4=0.0D0                                                  CNI50990
            SSIT=0.0D0                                                  CNI51000
            SSJT=0.0D0                                                  CNI51010
            DO 90 K=1,NATOMS                                            CNI51020
               MINK=LIML(K)                                             CNI51030
               MAXK=LIMU(K)                                             CNI51040
               DO 89 L=1,NATOMS                                         CNI51050
                  GKL=GAMA(K,L)                                         CNI51060
                  MINL=LIML(L)                                          CNI51070
                  MAXL=LIMU(L)                                          CNI51080
                  MN=0                                                  CNI51090
                  DO 60 M=MINK,MAXK                                     CNI51100
                     MN=1+MN                                            CNI51110
                     A=C(I,M)                                           CNI51120
                     B=C(J,M)                                           CNI51130
                     R(MN)=A*B                                          CNI51140
                     RR(MN)=A*A                                         CNI51150
                     RRR(MN)=B*B                                        CNI51160
   60             CONTINUE                                              CNI51170
                  NM=0                                                  CNI51180
                  DO 70 M=MINL,MAXL                                     CNI51190
                     NM=1+NM                                            CNI51200
                     A=C(I,M)                                           CNI51210
                     B=C(J,M)                                           CNI51220
                     T(NM)=A*B                                          CNI51230
                     TT(NM)=B*B                                         CNI51240
                     TTT(NM)=A*A                                        CNI51250
   70             CONTINUE                                              CNI51260
                  SUM1=0.0D0                                            CNI51270
                  SUM2=0.0D0                                            CNI51280
                  SUM3=0.0D0                                            CNI51290
                  SUM4=0.0D0                                            CNI51300
                  SUM5=0.0D0                                            CNI51310
                  SUM6=0.0D0                                            CNI51320
                  SUM7=0.0D0                                            CNI51330
                  DO 80 KK=1,MN                                         CNI51340
                     DO 79 LL=1,NM                                      CNI51350
                        A=R(KK)                                         CNI51360
                        B=RR(KK)                                        CNI51370
                        CC=RRR(KK)                                      CNI51380
                        E=T(LL)                                         CNI51390
                        F=TT(LL)                                        CNI51400
                        G=TTT(LL)                                       CNI51410
                        SUM1=SUM1+A*E                                   CNI51420
                        SUM2=SUM2+B*E                                   CNI51430
                        SUM3=SUM3+B*F                                   CNI51440
                        SUM4=SUM4+CC*G                                  CNI51450
                        SUM5=SUM5+B*G                                   CNI51460
                        SUM6=SUM6+CC*F                                  CNI51470
                        SUM7=SUM7+CC*E                                  CNI51480
   79                CONTINUE                                           CNI51490
   80             CONTINUE                                              CNI51500
                  SRT=SRT+SUM1*GKL                                      CNI51510
                  SSIT=SSIT+SUM2*GKL                                    CNI51520
                  SRT1=SRT1+SUM3*GKL                                    CNI51530
                  SRT2=SRT2+SUM4*GKL                                    CNI51540
                  SRT3=SRT3+SUM5*GKL                                    CNI51550
                  SRT4=SRT4+SUM6*GKL                                    CNI51560
                  SSJT=SSJT+SUM7*GKL                                    CNI51570
   89          CONTINUE                                                 CNI51580
   90       CONTINUE                                                    CNI51590
            A=SRT-0.25D0*(-SRT1-SRT2+SRT3+SRT4)                         CNI51600
            B=SSIT-SSJT                                                 CNI51610
            AB=DSQRT(A*A+B*B)                                           CNI51620
            C4AL=(-A/AB)                                                CNI51630
            S4AL=B/AB                                                   CNI51640
            QT(I,J)=S4AL                                                CNI51650
C-----------OBTAIN 2X2 TRANSFORMATION MATRIX AND TRANSFORMED MO"S-------CNI51660
            CSQP=0.5D0+0.5D0*DSQRT(0.5D0+0.5D0*C4AL)                    CNI51670
            CSQM=0.5D0-0.5D0*DSQRT(0.5D0+0.5D0*C4AL)                    CNI51680
            COSA=DSQRT(CSQP)                                            CNI51690
            SINA=DSQRT(1.D0-CSQP)                                       CNI51700
            COSB=DSQRT(CSQM)                                            CNI51710
            SINB=DSQRT(1.D0-CSQM)                                       CNI51720
            DFA=4.D0*COSA*SINA*(COSA*COSA-SINA*SINA) -S4AL              CNI51730
            DFB=4.D0*COSB*SINB*(COSB*COSB-SINB*SINB) -S4AL              CNI51740
            IF (DABS(DFA) .GT.DABS(DFB)) GO TO 100                      CNI51750
            SAL=SINA                                                    CNI51760
            CAL=COSA                                                    CNI51770
            GO TO 110                                                   CNI51780
  100       SAL=SINB                                                    CNI51790
            CAL=COSB                                                    CNI51800
  110       DO 120 K=1,N                                                CNI51810
               CIK=CAL*C(I,K)+SAL*C(J,K)                                CNI51820
               CJK=-SAL*C(I,K)+CAL*C(J,K)                               CNI51830
               C(I,K)=CIK                                               CNI51840
               C(J,K)=CJK                                               CNI51850
  120       CONTINUE                                                    CNI51860
  130    CONTINUE                                                       CNI51870
  140 CONTINUE                                                          CNI51880
C-----CONVERGENCE CHECK: START OVER AGAIN AT 40 IF NEEDED.--------------CNI51890
      DO 150 LI=1,NMOMN1                                                CNI51900
         LIM=LI+1                                                       CNI51910
         DO 149 LJ=LIM,NMOO                                             CNI51920
            IF (DABS(QT(LI,LJ)).GT.0.1D-05) GO TO 40                    CNI51930
  149    CONTINUE                                                       CNI51940
  150 CONTINUE                                                          CNI51950
C-----END OF BIG LOOP --------------------------------------------------CNI51960
  200 WRITE (LOUTPT,210) ICYC                                           CNI51970
  210 FORMAT ('0  NO. OF ITERATIONS',I6)                                CNI51980
C-----PRINT OUT LOCALIZED MO"S. CONVERGENCE HAS BEEN ACHIEVED.----------CNI51990
      WRITE (LOUTPT,220)                                                CNI52000
  220 FORMAT (//' LOCALIZED MOLECULAR ORBITALS......'/)                 CNI52010
      DO 250 K=1,NMOO                                                   CNI52020
         WRITE (LOUTPT,230)  K                                          CNI52030
  230    FORMAT (//'  MOLECULAR ORBITAL NO.',I3/)                       CNI52040
         WRITE (LOUTPT,240) (C(K,L), L=1,N)                             CNI52050
  240    FORMAT (8F10.5)                                                CNI52060
  250 CONTINUE                                                          CNI52070
      WRITE (LOUTPT,260)                                                CNI52080
  260 FORMAT (////)                                                     CNI52090
C-----CALCULATE UNITARY TRANSFORMATION MATRIX.--------------------------CNI52100
C     FIRST CALCULATE INVERSE OF ORIGINAL C MATRIX(STORED IN  Q).       CNI52110
C---- SINCE Q IS AN ORTHOGONAL MATRIX ITS INVERSE IS ITS TRANSPOSE,  QT.CNI52120
      DO 270 I=1,N                                                      CNI52130
         DO 270 J=1,N                                                   CNI52140
            QT(I,J)=0.0D0                                               CNI52150
  270 CONTINUE                                                          CNI52160
      DO 280 I=1,N                                                      CNI52170
         DO 280 J=1,N                                                   CNI52180
            QT(J,I)=Q(I,J)                                              CNI52190
  280 CONTINUE                                                          CNI52200
C---- USE ORIGINAL SET OF VACANT MO"S TO COMPLETE SET OF NEW MO"S, I.E.,CNI52210
C-----MAKE THE C MATRIX SQUARE. ----------------------------------------CNI52220
      NUO=NMOO+1                                                        CNI52230
      DO 290 I=NUO,N                                                    CNI52240
         DO 290 J=1,N                                                   CNI52250
            C(I,J)=Q(I,J)                                               CNI52260
  290 CONTINUE                                                          CNI52270
C-----CALCULATE TRANSFORMATION MATRIX,  STORE IN Q.---------------------CNI52280
      DO 310 I=1,N                                                      CNI52290
         DO 310 J=1,N                                                   CNI52300
            SUM=0.0D0                                                   CNI52310
            DO 300 K=1,N                                                CNI52320
               SUM=SUM+(C(I,K)*QT(K,J))                                 CNI52330
  300       CONTINUE                                                    CNI52340
            Q(I,J)=SUM                                                  CNI52350
  310 CONTINUE                                                          CNI52360
      WRITE (LOUTPT,320)                                                CNI52370
  320 FORMAT ('  TRANSFORMATION MATRIX'//)                              CNI52380
      DO 330 I=1,NMOO                                                   CNI52390
         WRITE (LOUTPT,240) (Q(I,J),J=1,NMOO)                           CNI52400
  330 CONTINUE                                                          CNI52410
C-----CALCULATE CHARGE DENSITY BOND ORDER MATRIX FOR ERROR CHECK--------CNI52420
      DO 360 K=1,N                                                      CNI52430
         DO 350 L=K,N                                                   CNI52440
            Q(K,L)=0.0D0                                                CNI52450
            DO 340 I=1,NMOO                                             CNI52460
               Q(K,L)=Q(K,L)+C(I,K)*C(I,L)*2.0D0                        CNI52470
  340       CONTINUE                                                    CNI52480
  350    CONTINUE                                                       CNI52490
  360 CONTINUE                                                          CNI52500
      WRITE (LOUTPT,370)                                                CNI52510
  370 FORMAT (////'   CHARGE DENSITY-BOND ORDER MATRIX CHECK'//)        CNI52520
      DO 390 K=1,N                                                      CNI52530
         WRITE (LOUTPT,380) (K,L,Q(K,L),L=K,N)                          CNI52540
  380    FORMAT (9(2I3,F8.4))                                           CNI52550
  390 CONTINUE                                                          CNI52560
C-----TRANSFER LOCALIZED MOS TO MATRIX QT FOR DIPOLE MOMENT CALCULATION-CNI52570
      DO 400 I=1,N                                                      CNI52590
         DO 400 J=1,N                                                   CNI52600
            QT(I,J)=Q(I,J)                                              CNI52610
  400 CONTINUE                                                          CNI52620
      GO TO 999                                                         CNI52630
  901 WRITE (LOUTPT,902)                                                CNI52640
  902 FORMAT(//,2X,                                                     CNI52650
     150H........CONVERGENCE CRITERION NOT ACHIEVED........,//)         CNI52660
      STOP                                                              CNI52670
  999 RETURN                                                            CNI52680
CE.28 END OF ORLOC (CNDOP)----------------------------------------------CNI52690
      END                                                               CNI52700
      SUBROUTINE DIAGON (IATOM,INOW,JNOW,BONDIJ,COSR,ONOMA,ALFATM,      CNI52710
     1ALFACH,ALGLOB,LOUT,LAUX,ITIT,ISYMS)                               CNI52720
CB.29 LAST CHANGE 28 SEP 2020 (CNDOP)-----------------------------------CNI52730
C     CALLED BY: DIPOLE(18)                                             CNI52740
C     CALLS    : EIG3  (27),WACOS (38)                                  CNI04140
C-----ATOM-IN-MOLECULE POLARIZABILITY ROUTINE---------------------------CNI52760
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI52770
      CHARACTER*4 ITITOL,ITIT                                           CNI52775
      REAL ALFOUT                                                       CNI52780
      LOGICAL ONOMA                                                     CNI52870
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI52790
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI52800
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI52810
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI52820
      DIMENSION COSR(3),ONOMA(3),ALFATM(3,3),ALFACH(3,3),ROOTS(3),      CNI52840
     1BETH(3,3),ALFSYM(3,3),ALASYM(6),ALFOUT(3,3),BETHAN(3,3),          CNI52850
     2ALGLOB(3,3),ALFSUM(3,3)                                           CNI52860
      LOUTPT=LOUT                                                       CNI52880
      I=INOW                                                            CNI52890
      J=JNOW                                                            CNI52900
      DO 1 M=1,3                                                        CNI52910
         ALFSYM(M,M)=ALGLOB(M,M)                                        CNI52920
    1 CONTINUE                                                          CNI52930
      IF (IATOM.EQ.1) WRITE (LOUTPT,2) I,((ONOMA(L),ONOMA(M),           CNI52940
     1ALGLOB(L,M),M=1,3),L=1,3)                                         CNI52950
    2 FORMAT (' ATOM NO.',I3,' UNSYMMETRICAL ATOM-IN-MOLECULE',         CNI52960
     1' POLARIZABILITY TENSOR (ANGSTROMS**3):'/                         CNI52970
     216X,3('(',2A1,')=',D13.6,1X)/2(16X,3('(',2A1,')=',D13.6,1X)/))    CNI52980
      IF (IATOM.EQ.0) WRITE (LOUTPT,30) I,((ONOMA(L),ONOMA(M),          CNI52940
     1ALGLOB(L,M),M=1,3),L=1,3)                                         CNI52950
   30 FORMAT (' ATOM NO.',I3,' UNSYMMETRICAL BOND-IN-MOLECULE',         CNI52960
     1' POLARIZABILITY TENSOR (ANGSTROMS**3):'/                         CNI52970
     216X,3('(',2A1,')=',D13.6,1X)/2(16X,3('(',2A1,')=',D13.6,1X)/))    CNI52980
      IF (IATOM.EQ.2) WRITE (LOUTPT,3) ((ONOMA(L),ONOMA(M),ALGLOB(L,M), CNI53000
     1M=1,3),L=1,3)                                                     CNI53010
    3 FORMAT (12X,' UNSYMMETRICAL SIMPLE RING POLARIZABILITY TENSOR'    CNI53020
     1/12X,' (ANGSTROMS**3):'/3(16X,(3('(',2A1,')=',D13.6,1X)/)))       CNI53050
      IF (IATOM.EQ.3) WRITE (LOUTPT,4) I,J,((ONOMA(L),ONOMA(M),         CNI53000
     1ALGLOB(L,M),M=1,3),L=1,3)                                         CNI53010
    4 FORMAT (12X,' UNSYMMETRICAL FUSED-RING POLARIZABILITY ',          CNI53020
     1'TENSOR'/12X,' BETWEEN ATOMS ',I3,' AND ',I3,' (ANGSTROMS**3) IS:'CNI53030
     2/3(16X,(3('(',2A1,')=',D13.6,1X)/)))                              CNI53050
C-----SUGGESTIONS OF JOHN A. POPLE AND GEORGE A.SEGAL-------------------CNI53070
C-----THROW AWAY THE UNSYMMETRICAL TENSOR COMPONENTS. ------------------CNI53080
      ALFSYM(1,2)=0.5D0*(ALGLOB(1,2)+ALGLOB(2,1))                       CNI53090
      ALFSYM(2,3)=0.5D0*(ALGLOB(2,3)+ALGLOB(3,2))                       CNI53100
      ALFSYM(3,1)=0.5D0*(ALGLOB(3,1)+ALGLOB(1,3))                       CNI53110
      ALFSYM(2,1)=ALFSYM(1,2)                                           CNI53120
      ALFSYM(3,2)=ALFSYM(2,3)                                           CNI53130
      ALFSYM(1,3)=ALFSYM(3,1)                                           CNI53140
      ALASYM(1)=0.5D0*(ALGLOB(1,2)-ALGLOB(2,1))                         CNI53150
      ALASYM(2)=0.5D0*(ALGLOB(2,3)-ALGLOB(3,2))                         CNI53160
      ALASYM(3)=0.5D0*(ALGLOB(3,1)-ALGLOB(1,3))                         CNI53170
      ALASYM(4)=-ALASYM(1)                                              CNI53180
      ALASYM(5)=-ALASYM(2)                                              CNI53190
      ALASYM(6)=-ALASYM(3)                                              CNI53200
      ALFACH(1,2)=ALFACH(1,2)+ALASYM(1)                                 CNI53210
      ALFACH(2,3)=ALFACH(2,3)+ALASYM(2)                                 CNI53220
      ALFACH(3,1)=ALFACH(3,1)+ALASYM(3)                                 CNI53230
      IF (IATOM.EQ.1) WRITE (LOUTPT,5) I,((ONOMA(L),ONOMA(M),           CNI53240
     1ALFSYM(L,M),M=1,3),L=1,3)                                         CNI53250
    5 FORMAT (' ATOM NO.',I3,' SYMMETRIZED ATOM-IN-MOLECULE',           CNI53355
     1' POLARIZABILITY TENSOR (ANGSTROMS**3):'/                         CNI53260
     216X,3('(',2A1,')=',D13.6,1X)/2(16X,3('(',2A1,')=',D13.6,1X)/))    CNI53270
      IF (IATOM.EQ.0) WRITE (LOUTPT,6) I,J,((ONOMA(L),ONOMA(M),         CNI53290
     1ALFSYM(L,M),M=1,3),L=1,3)                                         CNI53300
    6 FORMAT (12X,' SYMMETRIZED BOND-IN-MOLECULE POLARIZABILITY '       CNI53310
     1'TENSOR'/12X,' BETWEEN ATOMS ',I3,' AND ',I3,' (ANGSTROMS**3):'   CNI53320
     2/3(16X,3('(',2A1,')=',D13.6,1X)/))                                CNI53330
      IF (IATOM.EQ.2) WRITE (LOUTPT,7) I,J,((ONOMA(L),ONOMA(M),         CNI53290
     1ALFSYM(L,M),M=1,3),L=1,3)                                         CNI53300
    7 FORMAT (12X,' SYMMETRIZED SIMPLE RING POLARIZABILITY '            CNI53310
     1'TENSOR'/12X,' BETWEEN ATOMS ',I3,' AND ',I3,' (ANGSTROMS**3):'   CNI53320
     2/3(16X,3('(',2A1,')=',D13.6,1X)/))                                CNI53330
      IF (IATOM.EQ.3) WRITE (LOUTPT,8) I,J,((ONOMA(L),ONOMA(M),         CNI53290
     1ALFSYM(L,M),M=1,3),L=1,3)                                         CNI53300
    8 FORMAT (12X,' SYMMETRIZED FUSED-RING POLARIZABILITY '             CNI53310
     1'TENSOR'/12X,' BETWEEN ATOMS ',I3,' AND ',I3,' (ANGSTROMS**3):'   CNI53320
     2/3(16X,3('(',2A1,')=',D13.6,1X)/))                                CNI53330
C ***                                                                   CNI53350
      CALL EIG3 (ALFSYM,ROOTS,BETH)                                     CNI53360
      ROOTAV=(ROOTS(1)+ROOTS(2)+ROOTS(3))/3.0D0                         CNI53370
      IF (IATOM.EQ.1) WRITE (LOUTPT,10) I,ROOTAV,ROOTS(1),              CNI53380
     1ROOTS(2),ROOTS(3),ITIT                                            CNI53390
   10 FORMAT (' ATOM NO.',I3,' DIAGONALIZED ATOM-IN-MOLECULE',          CNI53400
     1' POLARIZABILITY (ANGSTROMS**3):'/' A(AVE)=',D13.6,' A1=',D13.6   CNI53420
     2,' A2=',D13.6,' A3=',D13.6/' NAME....',A4,9X,50('-'))             CNI53430
      IF (IATOM.EQ.0) WRITE (LOUTPT,11) I,J,ROOTAV,ROOTS(1),            CNI53450
     1ROOTS(2),ROOTS(3)                                                 CNI53460
   11 FORMAT (12X,' DIAGONALIZED BOND-IN-MOLECULE POLARIZABILITY',      CNI53470
     1' (ANGSTROMS**3):'/13X,'FOR ATOMS ',I3,' AND ',I3,' :'/           CNI53480
     2' A(AVE)=',D13.6,' A1=',D13.6,                                    CNI53490
     3' A2=',D13.6,' A3=',D13.6/22X,50('-'))                            CNI53500
      IF (IATOM.EQ.2) WRITE (LOUTPT,12) I,J,ROOTAV,ROOTS(1),            CNI53450
     1ROOTS(2),ROOTS(3)                                                 CNI53460
   12 FORMAT (12X,' DIAGONALIZED SIMPLE-RING POLARIZABILITY',           CNI53470
     1' (ANGSTROMS**3):'/13X,'FOR ATOMS ',I3,' AND ',I3,' :'/           CNI53480
     2' A(AVE)=',D13.6,' A1=',D13.6,                                    CNI53490
     3' A2=',D13.6,' A3=',D13.6/22X,50('-'))                            CNI53500
      IF (IATOM.EQ.3) WRITE (LOUTPT,13) I,J,ROOTAV,ROOTS(1),            CNI53450
     1ROOTS(2),ROOTS(3)                                                 CNI53460
   13 FORMAT (12X,' DIAGONALIZED FUSED-RING POLARIZABILITY',            CNI53470
     1' (ANGSTROMS**3):'/13X,'FOR ATOMS ',I3,' AND ',I3,' :'/           CNI53480
     2' A(AVE)=',D13.6,' A1=',D13.6,                                    CNI53490
     3' A2=',D13.6,' A3=',D13.6/22X,50('-'))                            CNI53500
      DO 14 N=1,3                                                       CNI53520
            BETHAN(M,N)=WACOS(BETH(M,N))/RAD2DG                         CNI53530
   14 CONTINUE                                                          CNI53540
      WRITE (LOUTPT,15) ((BETH(II,JJ),BETHAN(II,JJ),JJ=1,3),II=1,3)     CNI53550
   15 FORMAT (7X,'EIGENVECTORS      ',F8.5,F5.0,4X,F8.5,F5.0,4X,F8.5,   CNI53560
     1F5.0,2(/25X,F8.5,F5.0,4X,F8.5,F5.0,4X,F8.5,F5.0))                 CNI53570
      WRITE (LOUTPT,16) I,J,BONDIJ,(COSR(LL),LL=1,3)                    CNI53580
   16 FORMAT (22X,50('-')/                                              CNI53590
     112X,' VECTOR (',I3,' TO ',I3,')=',                                CNI53600
     2D19.10,' DIRECTION COSINES'/3(' ',52X,D17.10/)                    CNI53610
     322X,50('-'))                                                      CNI53620
      IF (IATOM.EQ.1) WRITE (LOUTPT,17) I,ALASYM(1),ALASYM(6),          CNI53630
     1ALASYM(4),ALASYM(2),ALASYM(3),ALASYM(5)                           CNI53640
   17 FORMAT (' ATOM NO.',I3,' ANTISYMMETRIC ATOM POLARIZABILITY ',     CNI53650
     1'TENSOR (ANGSTROMS**3):'/16X,'(XX)=      0.0',5X,'(XY)=',D13.6,   CNI53670
     2' (XZ)=',D13.6/16X,'(YX)=',D13.6,' (YY)=      0.0',4X,' (YZ)=',   CNI53700
     3D13.6/16X,'(ZX)=',D13.6,' (ZY)=',D13.6,' (ZZ)=      0.0'/         CNI53710
     4' ',71('='))                                                      CNI53720
      IF (IATOM.EQ.0) WRITE (LOUTPT,18) I,J,ALASYM(1),ALASYM(6),        CNI53730
     1ALASYM(4),ALASYM(2),ALASYM(3),ALASYM(5)                           CNI53740
   18 FORMAT (12X,' ANTISYMMETRIC BOND POLARIZABILITY ',                CNI53750
     1'TENSOR (ANGSTROMS**3):'/12X,' BETWEEN ATOMS',I3,                 CNI53760
     2' AND',I3,' IS:'/16X,'(XX)=',                                     CNI53770
     36X,'0.0',5X,'(XY)=',D13.6,' (XZ)=',D13.6/                         CNI53780
     416X,'(YX)=',D13.6,' (YY)=      0.0',5X,                           CNI53790
     5'(YZ)=',D13.6/                                                    CNI53800
     616X,'(ZX)=',D13.6,' (ZY)=',D13.6,                                 CNI53810
     7' (ZZ)=      0.0'/' ',71('='))                                    CNI53820
      IF (IATOM.EQ.2) WRITE (LOUTPT,19) I,J,ALASYM(1),ALASYM(6),        CNI53730
     1ALASYM(4),ALASYM(2),ALASYM(3),ALASYM(5)                           CNI53740
   19 FORMAT (12X,' ANTISYMMETRIC SIMPLE-RING POLARIZABILITY ',         CNI53750
     1'TENSOR (ANGSTROMS**3):'/12X,' BETWEEN ATOMS',I3,                 CNI53760
     2' AND',I3,' IS:'/16X,'(XX)=',                                     CNI53770
     36X,'0.0',5X,'(XY)=',D13.6,' (XZ)=',D13.6/                         CNI53780
     416X,'(YX)=',D13.6,' (YY)=      0.0',5X,                           CNI53790
     5'(YZ)=',D13.6/                                                    CNI53800
     616X,'(ZX)=',D13.6,' (ZY)=',D13.6,                                 CNI53810
     7' (ZZ)=      0.0'/' ',71('='))                                    CNI53820
      IF (IATOM.EQ.3) WRITE (LOUTPT,20) I,J,ALASYM(1),ALASYM(6),        CNI53730
     1ALASYM(4),ALASYM(2),ALASYM(3),ALASYM(5)                           CNI53740
   20 FORMAT (12X,' ANTISYMMETRIC FUSED-RING POLARIZABILITY ',          CNI53750
     1'TENSOR (ANGSTROMS**3):'/12X,' BETWEEN ATOMS',I3,                 CNI53760
     2' AND',I3,' IS:'/16X,'(XX)=',                                     CNI53770
     36X,'0.0',5X,'(XY)=',D13.6,' (XZ)=',D13.6/                         CNI53780
     416X,'(YX)=',D13.6,' (YY)=      0.0',5X,                           CNI53790
     5'(YZ)=',D13.6/                                                    CNI53800
     616X,'(ZX)=',D13.6,' (ZY)=',D13.6,                                 CNI53810
     7' (ZZ)=      0.0'/' ',71('='))                                    CNI53820
      DO 22 L=1,3                                                       CNI53830
         DO 21 M=1,3                                                    CNI53840
            ALFOUT(L,M)=ALFSYM(L,M)                                     CNI53850
C-----------IATOM=0+1: ALFSUM GETS THE SYMMETRIZED TENSOR FOR CHECKSUM--CNI32205
            ALFSUM(L,M)=ALFSUM(L,M)+ALFSYM(L,M)                         CNI32210
   21    CONTINUE                                                       CNI53860
   22 CONTINUE                                                          CNI53870
      IF (ISYMS.EQ.1) WRITE (LAUX,23) I,ITIT,ROOTAV                     CNI53880
   23 FORMAT (I3,A4/3(1X,D25.16))                                       CNI53890
      IF (ISYMS.EQ.1) WRITE (LAUX,24) I,ITIT,(ALFOUT(1,M),M=1,3),       CNI53900
     1I,ITIT,(ALFOUT(2,M),M=1,3),                                       CNI53910
     2I,ITIT,(ALFOUT(3,M),M=1,3)                                        CNI53920
   24 FORMAT (' ',I3,1X,A4,2X,3(F19.5,1X),' AXX AXY AXZ'/               CNI53930
     1I3,A4,2X,3(F19.5,1X),' AYX AYY AYZ'/                              CNI53940
     2I3,A4,2X,3(F19.5,1X),' AZX AZY AZZ')                              CNI53950
      RETURN                                                            CNI53960
CE.29 END OF DIAGON (CNDOP)---------------------------------------------CNI53970
      END                                                               CNI53980
      SUBROUTINE CFILES                                                 CNI53990
CB.30 LAST CHANGE 25 NOV 2020 (CNDOP)-----------------------------------CNI54000
C     CALLED BY: MAIN  (03)                                             CNI54010
C     CALLS    : ERRSET                                                 CNI54020
C-----DEFINE FORTRAN LOGICAL NUMBERS FOR READING AND WRITING,-----------CNI54030
C     SUPPRESS UNDERFLOW MESSAGES, AND                                  CNI54040
C-----DEFINE MACHINE-DEPENDENT PARAMETERS-------------------------------CNI64045
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI54050
      CHARACTER*4 ITITOL                                                CNI64051
      INTEGER DATE_TIME (8)                                             CNI64052
      CHARACTER*8 DATE                                                  CNI64053
      CHARACTER*10 B(3)                                                 CNI64055
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI54060
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI54070
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI54080
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI54090
      COMMON/INFOX/NATOMS,NCHARG,MULTIP,N,NELECS,NOCCA,NOCCB,LIMG,IPREC CNI54105
C-----CRAY SINGLE PRECISION: IPREC=1; IBM DOUBLE: IPREC=2               CNI54110
      IPREC=2                                                           CNI54115
CIBM  (VS FORTRAN 77):SUPPRESS CALLS TO ERROR MESSAGES 208 THROUGH 275  CNI54120
C-----CALL ERRSET (208,275,-5,0,1,210)                                  CNI54160
      LINPUT=05                                                         CNI54170
      OPEN (UNIT=LINPUT,FILE='desktop/FOR.05.DAT',STATUS='OLD')         CNI54175
      LOUTPT=06                                                         CNI54180
      OPEN (UNIT=LOUTPT,FILE='desktop/FOR.06',STATUS='REPLACE')         CNI54185
      LAUXOU=08                                                         CNI54190
C     OPEN (UNIT=LAUXOU,FILE='FOR.08',STATUS='REPLACE')                 CNI54195
      LPIECE=02                                                         CNI54200
C     OPEN (UNIT=LPIECE,FILE='FOR.02',STATUS='REPLACE')                 CNI54205
C     REWIND LAUXOU                                                     CNI54210
C     REWIND LPIECE                                                     CNI54220
C-----CALL DATE AND TIME: DATE COMES AS YYYYMMDD;-----------------------CNI54221
C     TIME COMES AS HHMMSS.SSS                                          CNI54222
C-***-------------------------------------------------------------------CNI54223
      CALL DATE_AND_TIME (B(1),B(2),B(3),DATE_TIME)                     CNI54225
      WRITE (LOUTPT,1) LINPUT,LOUTPT,LAUXOU,LPIECE,B(1),B(2)            CNI54230
    1 FORMAT (' CNDOP (UPDATED 25 NOV 2020)'/                           CNI54240
     1' R.M.METZGER, UNIV. OF ALABAMA'/' ',65('-')/                     CNI54250
     2' CARD READER  INPUT  ON FORTRAN LOGICAL LINPUT=',I3/             CNI54260
     3' LINE PRINTER OUTPUT ON FORTRAN LOGICAL LOUTPT=',I3/             CNI54270
     4' AUXILIARY    OUTPUT ON FORTRAN LOGICAL LAUXOU=',I3,             CNI54280
     5' (IPOLAR=1 RUNS)'/                                               CNI54290
     6' AUXILIARY    OUTPUT ON FORTRAN LOGICAL LPIECE=',I3,             CNI54300
     7' (PARTIAL ALPHA RUNS)'/' ',65('-')/' DATE (FORMAT:YYYYMMDD)=',   CNI54305
     8A8,' TIME (FORMAT:HHMMSS.SSS)=',A10/' ',65('-'))                  CNI54310
      RETURN                                                            CNI54320
CE.30 END OF CFILES (CNDOP)---------------------------------------------CNI54330
      END                                                               CNI54340
      SUBROUTINE CUNITS                                                 CNI54350
CB.31 LAST CHANGE 10 OCT 2020 (CNDOP)-----------------------------------CNI54360
C     CALLED BY: MAIN  (03)                                             CNI54370
C     CALLS    : NONE                                                   CNI54380
C-----DEFINES FUNDAMENTAL PHYSICAL CONSTANTS----------------------------CNI54390
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI54400
      CHARACTER*4 ITITOL                                                CNI54405
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI54410
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI54420
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI54430
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI54440
C-----FUNDAMENTAL PHYSICAL CONSTANTS, CF. HANDBOOK OF CHEMISTRY---------CNI54460
C     AND PHYSICS, (1970-71) 51ST EDITION, PAGES F-170 TO F-171         CNI54470
C     (BASED ON REVS. MOD. PHYS. 41, 375 (1969)                         CNI54480
C-----BOHR = BOHR RADIUS IN ANGSTROMS (1.0*10**(-10)METERS)-------------CNI54490
      BOHR=0.52917715D0                                                 CNI54500
C-----HARTRE=2*13.605826  CONVERTS ATOMIC UNITS (HARTREES) TO E.V.------CNI54510
      HARTRE=0.27211652D+02                                             CNI54520
C-----4.80325 DEBYES = 1.0 ELECTRON*ANGSTROM. --------------------------CNI54550
      DEBYE=0.4803250D+01                                               CNI54560
C-----RAD2DG CONVERTS RADIANS TO DEGREES.-------------------------------CNI54570
      RAD2DG=0.174532952 D-01                                           CNI54580
      DUNIT1=0.52917715D-10                                             CNI54590
      DUNIT3=0.4803250 D-09                                             CNI54600
      DUNIT4=0.4803250 D-19                                             CNI54610
      WRITE (LOUTPT,1) DUNIT1,HARTRE,DUNIT3,DUNIT4                      CNI54620
    1 FORMAT (' FUNDAMENTAL CONSTANTS USED (HANDBOOK OF CHEM.+PHYS.',   CNI54640
     1' 1970-71 (51.ST EDIT.) PAGES F-170,F-171):'/                     CNI54650
     2' 1 BOHR             =',D20.10,' METERS'/                         CNI54660
     3' 1 HARTREE          =',D20.10,' ELECTRON VOLTS'/                 CNI54670
     4' 1 ELECTRONIC CHARGE=',D20.10,' STATCOULOMBS'/                   CNI54680
     5' 1 DEBYE            =',D20.10,' ELECTRONS METERS'/' ',65('-'))   CNI54690
C-----BONMIN=MINIMUM ACCEPTED INTERATOMIC DISTANCE (ANGSTROMS)----------CNI54700
      BONMIN = 0.5D0                                                    CNI54720
      WRITE (LOUTPT,2) BONMIN                                           CNI54730
    2 FORMAT (' COVALENT BONDS MUST BE LONGER THAN BONMIN=',D17.7,      CNI54740
     1' ANGSTROMS'/' ',65('-'))                                         CNI54750
      RETURN                                                            CNI54760
CE.31 END OF CUNITS (CNDOP)---------------------------------------------CNI54770
      END                                                               CNI54780
      FUNCTION SSHASE(NN1,LL1,MM,NN2,LL2,ALPHA,BETA)                    CNI54790
CB.32 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI54800
C     CALLED BY: INTGRL(08) (IFF SS IS REPLACED BY SSHASE....)          CNI54810
C     CALLS    : AINTGS(14),BINTGS(13),COEFFS(34),                      CNI04470
C                COEFF (33),FACT  (12)                                  CNI04470
C-----HASE AND SCHWEIG VERSION OF FUNCTION SS (FOR GE,AS,SE, AND BR)    CNI54820
C     TO USE SSHASE,COEFF,COEFFS, AND BINOM, CALL SSHASE IN PLACE OF SS CNI54840
C-----IN INTGRL: THIS SAVES SPACE AT THE EXPENSE OF A SLIGHT BIT OF TIMECNI54850
C-----PROCEDURE FOR CALCULATING REDUCED OVERLAP INTEGRALS               CNI54870
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI54860
      CHARACTER*4 ITITOL                                                CNI54875
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI54880
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI54890
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI54900
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI54910
      COMMON/INFOX/II1(3),NN,II2(3),LIMG,IPREC                          CNI54930
      COMMON/AUXINT/A(17),B(17)                                         CNI54940
      INTEGER UL2                                                       CNI54950
      DO 2 I=1,17                                                       CNI54960
         A(I)=0.0D0                                                     CNI54970
         B(I)=0.0D0                                                     CNI54980
    2 CONTINUE                                                          CNI54990
      N1=NN1                                                            CNI55000
      L1=LL1                                                            CNI55010
      M=MM                                                              CNI55020
      N2=NN2                                                            CNI55030
      L2=LL2                                                            CNI55040
      P =(ALPHA + BETA)/2.D0                                            CNI55050
      PT=(ALPHA - BETA)/2.D0                                            CNI55060
      X = 0.D0                                                          CNI55070
      M=IABS(M)                                                         CNI55080
C-----REVERSE QUANTUM NUMBERS IF NECESSARY                              CNI55090
      IF ((L2.LT.L1).OR.((L2.EQ.L1).AND.(N2.LT.N1))) GO TO 20           CNI55100
   10 GO TO 30                                                          CNI55110
   20 K = N1                                                            CNI55120
      N1= N2                                                            CNI55130
      N2= K                                                             CNI55140
      K= L1                                                             CNI55150
      L1= L2                                                            CNI55160
      L2= K                                                             CNI55170
      PT=-PT                                                            CNI55180
   30 CONTINUE                                                          CNI55190
      K = MOD((N1+N2-L1-L2),2)                                          CNI55200
      NFILL=N1+N2                                                       CNI55210
C-----FIND A AND B INTEGRALS (AND FILL A,B MATRICES)                    CNI55220
C ***                                                                   CNI55230
      CALL AINTGS(P,NFILL)                                              CNI55240
C ***                                                                   CNI55250
      CALL BINTGS (PT,NFILL)                                            CNI55260
      LIML=1                                                            CNI55270
      LIMU=N1+N2+1                                                      CNI55280
      IF ((L1.GT.0).OR.(L2.GT.0)) GO TO 60                              CNI55290
C-----OVERLAP INTEGRALS INVOLVING S FUNCTIONS                           CNI55300
      DO 50 I1=LIML,LIMU                                                CNI55310
         ID1=I1                                                         CNI55320
         NNI1=N1+N2-I1+2                                                CNI55330
         X=X+COEFFS(N1,N2,ID1-1)*                                       CNI55340
     1   A(ID1)*B(NNI1)*0.5D0                                           CNI55350
   50 CONTINUE                                                          CNI55360
      SSHASE=X                                                          CNI55370
      GO TO 80                                                          CNI55380
C-----OVERLAPS INVOLVING NON-S FUNCTIONS                                CNI55390
   60 DO 70 I1=LIML,LIMU                                                CNI55400
         ID1=I1                                                         CNI55410
         UL2=LIMU/2+MOD(LIMU,2)                                         CNI55420
         DO 70 J1=LIML,UL2                                              CNI55430
            IIII=2*J1+MOD(K+I1+1,2)-1                                   CNI55440
            X=X+COEFF(N1,N2,L1,L2,M,ID1,IIII)*                          CNI55450
     1      A(ID1)*B(IIII)                                              CNI55460
   70 CONTINUE                                                          CNI55470
CIBM  SSHASE = X*(FACT(M+1)/8.D0)**2*DSQRT(DFLOAT(2*L1+1)*FACT(L1-M)*   CNI55480
CIBM 1 DFLOAT(2*L2+1)*FACT(L2-M)/(4.D0*FACT(L1+M)*FACT(L2+M)))          CNI55490
      SSHASE = X*(FACT(M+1)/8.D0)**2*DSQRT(DBLE(FLOAT(2*L1+1))*         CNI55480
     1 FACT(L1-M)*DBLE(FLOAT(2*L2+1))*FACT(L2-M)/(4.D0*                 CNI55490
     2 FACT(L1+M)*FACT(L2+M)))                                          CNI55490
   80 CONTINUE                                                          CNI55500
      RETURN                                                            CNI55510
CE.32 END OF SSHASE (CNDOP)---------------------------------------------CNI55520
      END                                                               CNI55530
      FUNCTION COEFF (NA,NB,LA,LB,M,KL,LL)                              CNI55540
CB.33 LAST CHANGE 13 JUN 1984 (CNDOP(-----------------------------------CNI55550
C     CALLED BY: SSHASE(32)                                             CNI55560
C     CALLS    : BINOM (35)                                             CNI55570
C-----PART OF HASE AND SCHWEIG REDUCED OVERLAP INTEGRAL ROUTINES--------CNI55580
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI55590
      DIMENSION CO(3,3,3)                                               CNI55600
      INTEGER A,B,C,D,P,U,V,BA,BE,BL,BMA,CA,CE,CL,CMA,BMI,UL,VL,DMA,CD  CNI55610
      INTEGER AU                                                        CNI55620
      DATA CO/ 8.,0.,-4.,0.,4.,0.,0.,0.,4.,0.,8.,0.,0.,0.,12.,0.,0.,0., CNI55630
     1   0.,0.,12.,0.,0.,0.,0.,0.,0./                                   CNI55640
      COEFF=0.0D0                                                       CNI55650
      K=KL-1                                                            CNI55660
      L=LL-1                                                            CNI55670
      KKLL=K+L                                                          CNI55680
      NNLL=NA+NB-LA-LB                                                  CNI55690
      IF (KKLL.LT.NNLL) RETURN                                          CNI55700
      LAM=LA-M+1                                                        CNI55710
      LBM=LB-M+1                                                        CNI55720
      DO 210 UL=1,LAM                                                   CNI55730
         DO 200 VL=1,LBM                                                CNI55740
            F=0.0D0                                                     CNI55750
            U=UL-1                                                      CNI55760
            V=VL-1                                                      CNI55770
            P=NA+NB-U-V                                                 CNI55780
            IAA=MOD(L+P-K,2)                                            CNI55790
            IF (IAA.NE.0) GO TO 200                                     CNI55800
            NAMU=NA-M-U                                                 CNI55810
            NBMV=NB-M-V                                                 CNI55820
            IMA=MIN0(L,U)                                               CNI55830
            JMA=MIN0(L,V)                                               CNI55840
            CMA=MIN0(L,NAMU)                                            CNI55850
            DMA=MIN0(L,NBMV)                                            CNI55860
            L2=INT(FLOAT(L)/2.)                                         CNI55870
            BMA=MIN0(L2,M)                                              CNI55880
            BMI=INT(FLOAT(L-IMA-JMA-CMA-DMA)/2.)                        CNI55890
            BMI=MAX0(0,BMI)                                             CNI55900
            BA=BMI+1                                                    CNI55910
            BE=BMA+1                                                    CNI55920
            IF (BE.LT.BA) GO TO 200                                     CNI55930
            DO 130 BL=BA,BE                                             CNI55940
               B=BL-1                                                   CNI55950
               IJCD=L-2*B                                               CNI55960
               IE=MIN0(U,IJCD)+1                                        CNI55970
               IA=IJCD-JMA-CMA-DMA                                      CNI55980
               IA=MAX0(0,IA)+1                                          CNI55990
               IF (IE.LT.IA) GO TO 130                                  CNI56000
               DO 120 IL=IA,IE                                          CNI56010
                  I=IL-1                                                CNI56020
                  JCD=IJCD-I                                            CNI56030
                  JE=MIN0(V,JCD)+1                                      CNI56040
                  JA=JCD-CMA-DMA                                        CNI56050
                  JA=MAX0(0,JA) + 1                                     CNI56060
                  IF (JE.LT.JA) GO TO 120                               CNI56070
                  DO 110 JL=JA,JE                                       CNI56080
                     J=JL-1                                             CNI56090
                     CD=JCD-J                                           CNI56100
                     CE=MIN0(NAMU,CD)+1                                 CNI56110
                     CA=CD-DMA                                          CNI56120
                     CA=MAX0(0,CA)+1                                    CNI56130
                     IF (CE.LT.CA) GO TO 110                            CNI56140
                     DO 100 CL=CA,CE                                    CNI56150
                        C=CL-1                                          CNI56160
                        D=CD-C                                          CNI56170
                        AU=MOD(P-K+I+J-C-D,2)                           CNI56180
                        IF (AU.NE.0) GO TO 100                          CNI56190
                        A=(P-K+I+J-C-D)/2                               CNI56200
                        IF (A.LT.0) GO TO 100                           CNI56210
                        IF (A.GT.M) GO TO 100                           CNI56220
                        F=F+BINOM(M,A)*BINOM(M,B)*BINOM(U,I)*           CNI56230
     1                  BINOM(V,J)*BINOM(NAMU,C)*BINOM(NBMV,D)*         CNI56240
     2                  (-1.0D0)**(A+B+J+D)                             CNI56250
  100                CONTINUE                                           CNI56260
  110             CONTINUE                                              CNI56270
  120          CONTINUE                                                 CNI56280
  130       CONTINUE                                                    CNI56290
            COEFF=COEFF+CO(LA+1,M+1,U+1)*CO(LB+1,M+1,V+1)*F             CNI56300
  200    CONTINUE                                                       CNI56310
  210 CONTINUE                                                          CNI56320
      RETURN                                                            CNI56330
CE.33 END OF COEFF (CNDOP)----------------------------------------------CNI56340
      END                                                               CNI56350
      FUNCTION COEFFS(NA,NB,K)                                          CNI56360
CB.34 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI56370
C     CALLED BY: SSHASE(32)                                             CNI56380
C     CALLS    : BINOM (35)                                             CNI56390
C-----PART OF HASE AND SCHWEIG REDUCED OVERLAP INTEGRAL ROUTINES--------CNI56400
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI56410
      COEFFS=0.0D0                                                      CNI56420
      L=NA+NB-K                                                         CNI56430
      IE=MIN0(L,NA)+1                                                   CNI56440
      JE=MIN0(L,NB)                                                     CNI56450
      IA=L-JE+1                                                         CNI56460
      DO 10 IL=IA,IE                                                    CNI56470
         I=IL-1                                                         CNI56480
         J=L-I                                                          CNI56490
   10 COEFFS=COEFFS+BINOM(NA,I)*BINOM(NB,J)*(-1.0D0)**J                 CNI56500
      RETURN                                                            CNI56510
CE.34 END OF COEFFS (CNDOP)---------------------------------------------CNI56520
      END                                                               CNI56530
      FUNCTION BINOM(N,I)                                               CNI56540
CB.35 LAST CHANGE 13 JUN 1984 (CNDOP)-----------------------------------CNI56550
C     CALLED BY: COEFF (33),COEFFS(34)                                  CNI56560
C     CALLS    : FACT  (12)                                             CNI56570
C-----PART OF HASE AND SCHWEIG ROUTINE FOR REDUCED OVERLAP INTEGRALS----CNI56580
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI56590
      J=N-I                                                             CNI56600
      BINOM=FACT(N)/(FACT(I)*FACT(J))                                   CNI56610
      RETURN                                                            CNI56620
CE.35 END OF BINOM (CNDOP)----------------------------------------------CNI56630
      END                                                               CNI56640
      SUBROUTINE MATPRT (LIMG,GAMMA)                                    CNI56650
CB.36 LAST CHANGE 25 FEB 1988 (CNDOP)-----------------------------------CNI56660
C     CALLED BY: INTGRL(08)                                             CNI56670
C     CALLS    : NONE                                                   CNI56680
C-----PRINTS COULOMB INTEGRAL MATRIX------------------------------------CNI56690
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI56700
      CHARACTER*4 ITITOL                                                CNI56705
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI56710
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI56720
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI56730
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI56740
      DIMENSION GAMMA(LIMG,LIMG)                                        CNI56760
      DO 80 M=1,LIMG,7                                                  CNI56770
         K=M+6                                                          CNI56780
         IF (K.LE.LIMG) GO TO 30                                        CNI56790
   20    K=LIMG                                                         CNI56800
   30    CONTINUE                                                       CNI56810
         WRITE (LOUTPT,40) (J,J=M,K)                                    CNI56820
   40    FORMAT(//,7X,7(4X,I2,3X),//)                                   CNI56830
         DO 60 I=1,LIMG                                                 CNI56840
            WRITE (LOUTPT,50) I,(GAMMA(I,J),J=M,K)                      CNI56850
   50       FORMAT(1X,I2,4X,50(F9.4))                                   CNI56860
   60    CONTINUE                                                       CNI56870
         WRITE (LOUTPT,70)                                              CNI56880
   70    FORMAT(//)                                                     CNI56890
   80 CONTINUE                                                          CNI56900
      RETURN                                                            CNI56910
CE.36 END OF MATPRT (CNDOP)---------------------------------------------CNI56920
      END                                                               CNI56930
      SUBROUTINE ATDATA                                                 CNI56940
CB.37 LAST CHANGE 20 NOW 2020-------------------------------------------CNI56950
C     CALLED BY: MAIN  (03)                                             CNI56960
C     CALLS    : NONE                                                   CNI56970
C-----DEFINES SEMI-EMPIRICAL PARAMETERS FOR CNDOP-----------------------CNI56980
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI56990
      INTEGER OPTION,CNDO,IVAL(3)                                       CNI57000
      CHARACTER*4 ITITOL                                                CNI57005
      CHARACTER*2 EL0(35)                                               CNI57006
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI57010
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI57020
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI57030
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI57040
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI57060
     1RKAPPA(35,6)                                                      CNI57070
      COMMON/CHOICE/OPTION,II1(2),CNDO,II4(3)                           CNI57080
      COMMON/FIXIT/FUDGE,IBIM                                           CNI57085
      DATA EL0/' H','HE','LI','BE',' B',' C',' N',' O',' F','NE','NA',  CNI09150
     1'MG','AL','SI',' P',' S','CL','AR',' K','CA','SC','TI',' V','CR', CNI09160
     2 'MN','FE','CO','NI','CU','ZN','GA','GE','AS','SE','BR'/          CNI09170
      DIMENSION NC(35,2),LC(9),MC(9),E(3)                               CNI13020
C-----ASSIGN ORBITAL EXPONENTS TO ATOMS BY SLATERS RULES----------------CNI14040
C     (EXCEPT FOR HYDROGEN....SEE POPLE AND BEVERIDGE BOOK)             CNI14050
C     MU = ORBITAL EXPONENT (1/BOHRS)                                   CNI14060
C     NC = PRINCIPAL QUANTUM NUMBER                                     CNI14070
C     LC = ORBITAL ANGULAR MOMENTUM QUANTUM NUMBER                      CNI14080
C-----MC = Z-COMPONENT OF ORBITAL ANGULAR MOMENTUM QUANTUM NUMBER-------CNI14090
      ZSLATR(2,1)=1.7D0                                                 CNI14100
      ZSLATR(1,1)=1.2D0                                                 CNI14110
      NC(1,1)=1                                                         CNI14120
      NC(2,1)=1                                                         CNI14130
      DO 1 I=3,10                                                       CNI14140
         NC(I,1)=2                                                      CNI14150
         ZSLATR(I,1)=.325D0*DBLE(FLOAT(I-1))                            CNI14160
    1 CONTINUE                                                          CNI14170
      DO 2 I=11,18                                                      CNI14180
         NC(I,1)=3                                                      CNI14190
         ZSLATR(I,1)=(.65D0*DBLE(FLOAT(I))-4.95D0)/3.D0                 CNI14200
    2 CONTINUE                                                          CNI14210
C-----STO ORBITAL EXPONENTS FOR NA,MG,AL,SI,P,S,CL----------------------CNI14220
C-----GORDON,BJORKE,MARSH AND KORTH, J.AM.CHEM.SOC.100,2670(1978)-------CNI14230
      IF (INUPAR.EQ.5) ZSLATR(11,1) = 1.21 D0                           CNI14240
      IF (INUPAR.EQ.5) ZSLATR(12,1) = 1.28 D0                           CNI14250
      IF (INUPAR.EQ.5) ZSLATR(13,1) = 1.39 D0                           CNI14260
      IF (INUPAR.EQ.5) ZSLATR(14,1) = 1.55 D0                           CNI14270
      IF (INUPAR.EQ.5) ZSLATR(15,1) = 1.74 D0                           CNI14280
      IF (INUPAR.EQ.5) ZSLATR(16,1) = 1.93 D0                           CNI14290
      IF (INUPAR.EQ.5) ZSLATR(17,1) = 2.14 D0                           CNI14300
C-----STO ORBITAL EXPONENTS FOR GE,AS,SE,BR-----------------------------CNI14310
      DO 3 I=32,35                                                      CNI14320
         NC(I,1)=4                                                      CNI14330
         NC(I,2)=4                                                      CNI14340
         ZSLATR(I,1)=(0.65D0*DBLE(FLOAT(I))-15.15D0)/3.7D0              CNI14350
    3 CONTINUE                                                          CNI14360
C-----SLATER-CONDON PARAMET.KERS, CF POPLE AND BEVERIDGE BOOK-----------CNI57090
      G1(3)=.092012        D0                                           CNI57100
      G1(4)=.1407          D0                                           CNI57110
      G1(5)=.199265        D0                                           CNI57120
      G1(6)=.267708        D0                                           CNI57130
      G1(7)=.346029        D0                                           CNI57140
      G1(8)=.43423         D0                                           CNI57150
      G1(9)=.532305        D0                                           CNI57160
      F2(3)=.049865        D0                                           CNI57170
      F2(4)=.089125        D0                                           CNI57180
      F2(5)=.13041         D0                                           CNI57190
      F2(6)=.17372         D0                                           CNI57200
      F2(7)=.219055        D0                                           CNI57210
      F2(8)=.266415        D0                                           CNI57220
      F2(9)=.31580         D0                                           CNI57230
C-----MORE SLATER-CONDON PARAMETERS, GORDON ET AL.JACS 100:2670(1978)---CNI57240
      F2(11) = 0.071957    D0                                           CNI57250
      F2(12) = 0.090701    D0                                           CNI57260
      F2(13) = 0.108090    D0                                           CNI57270
      F2(14) = 0.128450    D0                                           CNI57280
      F2(15) = 0.151521    D0                                           CNI57290
      F2(16) = 0.175202    D0                                           CNI57300
      F2(17) = 0.201492    D0                                           CNI57310
      G1(11) = 0.128648    D0                                           CNI57320
      G1(12) = 0.138735    D0                                           CNI57330
      G1(13) = 0.160025    D0                                           CNI57340
      G1(14) = 0.191790    D0                                           CNI57350
      G1(15) = 0.231907    D0                                           CNI57360
      G1(16) = 0.276683    D0                                           CNI57370
      G1(17) = 0.329070    D0                                           CNI57380
C-----ENEG=ORBITAL ELECTRONEGATIVITY = CORE INTEGRAL = -0.5*(I+A)-------CNI57390
C     CF. POPLE AND BEVERIDGE TABLE 3.4 FOR ALL ENTRIES EXCEPT FOR      CNI57400
C-----H2P, (LI,BE,B,C,N,O,F) 3D. ---------------------------------------CNI57410
      ENEG(1,1)=  7.1761   D0                                           CNI57420
      ENEG(1,2)=  1.70     D0                                           CNI57430
      ENEG(3,1)=  3.1055   D0                                           CNI57440
      ENEG(3,2)=  1.258    D0                                           CNI57450
      ENEG(3,3)=  0.756    D0                                           CNI57460
      ENEG(4,1)=  5.94557  D0                                           CNI57470
      ENEG(4,2)=  2.563    D0                                           CNI57480
      ENEG(4,3)=  0.777    D0                                           CNI57490
      ENEG(5,1)=  9.59407  D0                                           CNI57500
      ENEG(5,2)=  4.001    D0                                           CNI57510
      ENEG(5,3)=  0.754    D0                                           CNI57520
      ENEG(6,1)= 14.051    D0                                           CNI57530
      ENEG(6,2)=  5.572    D0                                           CNI57540
      ENEG(6,3)=  0.775    D0                                           CNI57550
      ENEG(7,1)= 19.31637  D0                                           CNI57560
      ENEG(7,2)=  7.275    D0                                           CNI57570
      ENEG(7,3)=  1.228    D0                                           CNI57580
      ENEG(8,1)= 25.39017  D0                                           CNI57590
      ENEG(8,2)=  9.111    D0                                           CNI57600
      ENEG(8,3)=  1.283    D0                                           CNI57610
      ENEG(9,1)= 32.2724   D0                                           CNI57620
      ENEG(9,2)= 11.08     D0                                           CNI57630
      ENEG(9,3)=  1.4      D0                                           CNI57640
      ENEG(11,1)= 2.804    D0                                           CNI57650
      ENEG(11,2)= 1.302    D0                                           CNI57660
      ENEG(11,3)= 0.150    D0                                           CNI57670
      ENEG(12,1)= 5.1254   D0                                           CNI57680
      ENEG(12,2)= 2.0516   D0                                           CNI57690
      ENEG(12,3)= 0.16195  D0                                           CNI57700
      ENEG(13,1)= 7.7706   D0                                           CNI57710
      ENEG(13,2)= 2.9951   D0                                           CNI57720
      ENEG(13,3)= 0.22425  D0                                           CNI57730
      ENEG(14,1)=10.0327   D0                                           CNI57740
      ENEG(14,2)= 4.1325   D0                                           CNI57750
      ENEG(14,3)= 0.337    D0                                           CNI57760
      ENEG(15,1)=14.0327   D0                                           CNI57770
      ENEG(15,2)= 5.4638   D0                                           CNI57780
      ENEG(15,3)= 0.500    D0                                           CNI57790
      ENEG(16,1)=17.6496   D0                                           CNI57800
      ENEG(16,2)= 6.989    D0                                           CNI57810
      ENEG(16,3)= 0.71325  D0                                           CNI57820
      ENEG(17,1)=21.5906   D0                                           CNI57830
      ENEG(17,2)= 8.7081   D0                                           CNI57840
      ENEG(17,3)= 0.97695  D0                                           CNI57850
      ENEG(32,1)=11.435    D0                                           CNI57860
      ENEG(32,2)= 4.080    D0                                           CNI57870
      ENEG(32,3)= 0.0      D0                                           CNI57880
      IF (IPLFCN.EQ.1)    ENEG(32,3)= 0.000   D0                        CNI57890
      ENEG(33,1)=13.335    D0                                           CNI57900
      ENEG(33,2)= 5.345    D0                                           CNI57910
      ENEG(33,3)= 0.0      D0                                           CNI57920
      ENEG(34,1)=16.315    D0                                           CNI57930
      ENEG(34,2)= 7.100    D0                                           CNI57940
      ENEG(34,3)= 0.600    D0                                           CNI57950
      ENEG(35,1)=19.630    D0                                           CNI57960
      ENEG(35,2)= 8.400    D0                                           CNI57970
      ENEG(35,3)= 0.800    D0                                           CNI57980
      BETA0(1)=  -9.       D0                                           CNI57990
      BETA0(3)=  -9.       D0                                           CNI58000
      BETA0(4)= -13.       D0                                           CNI58010
      BETA0(5)= -17.       D0                                           CNI58020
      BETA0(6)= -21.       D0                                           CNI58030
      BETA0(7)= -25.       D0                                           CNI58040
      BETA0(8)= -31.       D0                                           CNI58050
      BETA0(9)= -39.       D0                                           CNI58060
      BETA0(11)= -7.7203   D0                                           CNI58070
      BETA0(12)= -9.4471   D0                                           CNI58080
      BETA0(13)=-11.3011   D0                                           CNI58090
      BETA0(14)=-13.065    D0                                           CNI58100
      BETA0(15)=-15.070    D0                                           CNI58110
C-----BETAS FOR POLARIZATION FUNCTION RUNS ARE RESET BELOW--------------CNI58120
      BETA0(16)=-18.150    D0                                           CNI58130
      BETA0(17)=-22.330    D0                                           CNI58140
      BETA0(32)=-10.0      D0                                           CNI58150
      BETA0(33)=-13.0      D0                                           CNI58160
      BETA0(34)=-16.0      D0                                           CNI58170
      BETA0(35)=-22.0      D0                                           CNI58180
      BETAD    =  0.0      D0                                           CNI58190
C-----POLARIZATION FUNCTION SLATER ORBITAL EXPONENTS AND RKAPPA VALUES. CNI58200
C-----METZGER, 27 JUN 1985 -------------------------------------------- CNI58210
      IF (IPLFCN.EQ.0) GO TO 4                                          CNI58220
      ZSLATR( 1,2)=0.775   D0                                           CNI58230
      ZSLATR( 3,2)=0.0     D0                                           CNI58240
      ZSLATR( 4,2)=0.0     D0                                           CNI58250
      ZSLATR( 5,2)=0.0     D0                                           CNI58260
      ZSLATR( 6,2)=0.945   D0                                           CNI58270
      ZSLATR( 7,2)=1.210   D0                                           CNI58280
      ZSLATR( 8,2)=1.300   D0                                           CNI58290
      ZSLATR( 9,2)=1.550   D0                                           CNI58300
      ZSLATR(10,2)=0.0     D0                                           CNI58310
      ZSLATR(11,2)=0.0     D0                                           CNI58320
      ZSLATR(12,2)=0.0     D0                                           CNI58330
      ZSLATR(13,2)=0.0     D0                                           CNI58340
      ZSLATR(14,2)=0.0     D0                                           CNI58350
      ZSLATR(15,2)=0.825   D0                                           CNI58360
      ZSLATR(16,2)=0.978   D0                                           CNI58370
      ZSLATR(17,2)=1.033   D0                                           CNI58380
      ZSLATR(32,2)=0.000   D0                                           CNI58390
      ZSLATR(33,2)=0.000   D0                                           CNI58400
      ZSLATR(34,2)=1.000   D0                                           CNI58410
      ZSLATR(35,2)=1.041   D0                                           CNI58420
C-----ANY PROBLEMS HERE  ????????????????-------------------------------CNI58421
      RKAPPA( 1,1)=0.25    D0                                           CNI58430
      RKAPPA( 3,1)=0.05    D0                                           CNI58440
      RKAPPA( 4,1)=0.05    D0                                           CNI58450
      RKAPPA( 5,1)=0.05    D0                                           CNI58460
      RKAPPA( 6,1)=0.05    D0                                           CNI58470
      RKAPPA( 7,1)=0.05    D0                                           CNI58480
      RKAPPA( 8,1)=0.05    D0                                           CNI58490
      RKAPPA( 9,1)=0.05    D0                                           CNI58500
      RKAPPA(11,1)=0.05    D0                                           CNI58510
      RKAPPA(12,1)=0.05    D0                                           CNI58520
      RKAPPA(13,1)=0.05    D0                                           CNI58530
      RKAPPA(14,1)=0.05    D0                                           CNI58540
      RKAPPA(15,1)=0.05    D0                                           CNI58550
      RKAPPA(16,1)=0.05    D0                                           CNI58560
      RKAPPA(17,1)=0.05    D0                                           CNI58570
      RKAPPA(32,1)=0.05    D0                                           CNI58580
      RKAPPA(33,1)=0.05    D0                                           CNI58590
      RKAPPA(34,1)=0.05    D0                                           CNI58600
      RKAPPA(35,1)=0.05    D0                                           CNI58610
      BETA0(15)= -50.0     D0                                           CNI58620
      BETA0(16)= -48.0     D0                                           CNI58630
      BETA0(17)= -50.0     D0                                           CNI58640
      BETA0(34)= -40.0     D0                                           CNI58650
      BETA0(35)= -30.0     D0                                           CNI58660
      IF (INUPAR.NE.1) GO TO 5                                          CNI58670
C-----SABIN AND WEISS PARAMETRIZATION (INUPAR=1) FOLLOWS ---------------CNI58680
    4 ENEG(11,1)=  2.38    D0                                           CNI58690
      ENEG(11,2)=  1.18    D0                                           CNI58700
      ENEG(11,3)=  0.0     D0                                           CNI58710
      ENEG(12,1)=  4.34    D0                                           CNI58720
      ENEG(12,2)=  1.91    D0                                           CNI58730
      ENEG(12,3)=  0.0     D0                                           CNI58740
      ENEG(13,1)=  6.63    D0                                           CNI58750
      ENEG(13,2)=  2.73    D0                                           CNI58760
      ENEG(13,3)=  0.0     D0                                           CNI58770
      ENEG(14,1)=  9.0     D0                                           CNI58780
      ENEG(14,2)=  4.5     D0                                           CNI58790
      ENEG(14,3)=  0.0     D0                                           CNI58800
      ENEG(15,1)= 11.2     D0                                           CNI58810
      ENEG(15,2)=  5.2     D0                                           CNI58820
      ENEG(15,3)=  0.0     D0                                           CNI58830
      ENEG(16,1)= 13.0     D0                                           CNI58840
      ENEG(16,2)=  6.4     D0                                           CNI58850
      ENEG(16,3)=  0.0     D0                                           CNI58860
      ENEG(17,1)= 16.0     D0                                           CNI58870
      ENEG(17,2)=  7.0     D0                                           CNI58880
      ENEG(17,3)=  0.0     D0                                           CNI58890
      BETA0(11)=  -5.02    D0                                           CNI58900
      BETA0(12)=  -6.14    D0                                           CNI58910
      BETA0(13)=  -7.35    D0                                           CNI58920
      BETA0(14)=  -8.5     D0                                           CNI58930
      BETA0(15)= -10.0     D0                                           CNI58940
      BETA0(16)= -11.5     D0                                           CNI58950
      BETA0(17)= -12.2     D0                                           CNI58960
      BETAD=     -6.0      D0                                           CNI58970
    5 IF (INUPAR.NE.2.AND.INUPAR.NE.3) GO TO 6                          CNI58980
C-----SEE  ELLIS, KUEHNLENZ, & JAFFE,THEOR.CHIM.ACTA 26:131(1972)-------CNI58990
      ENEG(1,1)= 7.175     D0                                           CNI59010
      ENEG(6,1)=14.96      D0                                           CNI59020
      ENEG(6,2)= 5.805     D0                                           CNI59030
      ENEG(7,1)=20.485     D0                                           CNI59040
      ENEG(7,2)= 8.48      D0                                           CNI59050
      ENEG(8,1)=27.255     D0                                           CNI59060
      ENEG(8,2)=10.965     D0                                           CNI59070
      BETA0(1)=-12.        D0                                           CNI59080
      BETA0(6)=-17.5       D0                                           CNI59090
      BETA0(7)=-26.        D0                                           CNI59100
      BETA0(8)=-45.        D0                                           CNI59110
    6 IF (INUPAR.NE.4) GO TO 7                                          CNI59130
C-----INUPAR=4: KROGH-JESPERSEN & RATNER J.CHEM.PHYS.65:1305(1976)------CNI59150
C-----FOR OXYGEN, BORROW JAFFE PARAMETERS (JAN 1981)--------------------CNI59160
      ENEG( 1,1)=  7.171   D0                                           CNI59170
      ENEG( 1,2)=  0.000   D0                                           CNI59180
      ENEG( 3,1)=  3.155   D0                                           CNI59190
      ENEG( 3,2)=  2.050   D0                                           CNI59200
      ENEG( 3,3)=  0.0     D0                                           CNI59210
      ENEG( 4,1)=  6.550   D0                                           CNI59220
      ENEG( 4,2)=  3.035   D0                                           CNI59230
      ENEG( 4,3)=  0.0     D0                                           CNI59240
      ENEG( 5,1)= 10.305   D0                                           CNI59250
      ENEG( 5,2)=  4.370   D0                                           CNI59260
      ENEG( 5,3)=  0.0     D0                                           CNI59270
      ENEG( 6,1)= 14.962   D0                                           CNI59280
      ENEG( 6,2)=  5.806   D0                                           CNI59290
      ENEG( 6,3)=  0.775   D0                                           CNI59300
      ENEG( 7,1)= 20.359   D0                                           CNI59310
      ENEG( 7,2)=  8.114   D0                                           CNI59320
      ENEG( 7,3)=  1.228   D0                                           CNI59330
      ENEG( 8,1)= 27.255   D0                                           CNI59340
      ENEG( 8,2)= 10.965   D0                                           CNI59350
      ENEG( 8,3)=  1.283   D0                                           CNI59360
      ENEG( 9,1)= 28.48    D0                                           CNI59370
      ENEG( 9,2)= 12.18    D0                                           CNI59380
      ENEG( 9,3)=  1.4     D0                                           CNI59390
C-----J.HINZE AND H.H.JAFFE, J.AM.CHEM.SOC.84:540 (1962)----------------CNI59400
      ENEG(16,1)= 15.81    D0                                           CNI59410
      ENEG(16,2)=  8.415   D0                                           CNI59420
      ENEG(17,1)= 19.38    D0                                           CNI59430
      ENEG(17,2)=  8.3705  D0                                           CNI59440
      ENEG(17,3)=  0.60    D0                                           CNI59450
      ENEG(31,1)= 10.075   D0                                           CNI59460
      ENEG(31,2)=  4.265   D0                                           CNI59470
      ENEG(31,3)=  0.0     D0                                           CNI59480
      ENEG(32,1)= 12.715   D0                                           CNI59490
      ENEG(32,2)=  6.845   D0                                           CNI59500
      ENEG(32,3)=  0.0     D0                                           CNI59510
      ENEG(33,1)= 12.07    D0                                           CNI59520
      ENEG(33,2)=  7.77    D0                                           CNI59530
      ENEG(34,1)= 15.425   D0                                           CNI59540
      ENEG(34,2)=  8.24    D0                                           CNI59550
      ENEG(34,3)=  0.0     D0                                           CNI59560
      ENEG(35,1)=  0.0     D0                                           CNI59570
      ENEG(35,2)=  0.0     D0                                           CNI59580
      ENEG(35,3)=  0.0     D0                                           CNI59590
      ENEG(11,1)= 2.805    D0                                           CNI59600
      ENEG(11,2)= 1.565    D0                                           CNI59610
C-----ENEG(11,3)= PARAMETER---------------------------------------------CNI59620
      ENEG(12,1)= 5.875    D0                                           CNI59630
      ENEG(12,2)= 2.295    D0                                           CNI59640
C-----ENEG(12,3)= PARAMETER---------------------------------------------CNI59650
      ENEG(13,1)= 8.595    D0                                           CNI59660
      ENEG(13,2)= 3.920    D0                                           CNI59670
C-----ENEG(13,3)= PARAMETER---------------------------------------------CNI59680
      ENEG(14,1)=12.120    D0                                           CNI59690
      ENEG(14,2)= 6.005    D0                                           CNI59700
C-----ENEG(14,3)= PARAMETER---------------------------------------------CNI59710
      ENEG(15,1)=14.340    D0                                           CNI59720
      ENEG(15,2)= 7.230    D0                                           CNI59730
C-----ENEG(15,3)= PARAMETER---------------------------------------------CNI59740
      BETA0( 1)=-12.0      D0                                           CNI59750
      BETA0( 5)= -5.0      D0                                           CNI59760
      BETA0( 6)=-17.5      D0                                           CNI59770
      BETA0( 7)=-26.0      D0                                           CNI59780
C-----CHANG HWAN RHEE CHANGED BETA0 FOR O,F FROM -45,-50 TO -30,-40.----CNI59790
      BETA0( 8)=-30.0      D0                                           CNI59800
      BETA0( 9)=-40.0      D0                                           CNI59810
      BETA0(16)=-12.0      D0                                           CNI59820
      IF (IPLFCN.EQ.1)   BETA0(16)=-24.0  D0                            CNI59830
      BETA0(17)=-15.0      D0                                           CNI59840
      IF (IPLFCN.EQ.1)   BETA0(17)=-32.0  D0                            CNI59850
      ZSLATR( 1,2)= 0.714  D0                                           CNI59860
      ZSLATR( 6,2)= 0.400  D0                                           CNI59870
      ZSLATR( 7,2)= 0.528  D0                                           CNI59880
      ZSLATR( 8,2)= 0.600  D0                                           CNI59890
      ZSLATR( 9,2)= 0.720  D0                                           CNI59900
      ZSLATR(16,2)= 0.00   D0                                           CNI59910
      ZSLATR(17,2)= 0.84   D0                                           CNI59920
      ZSLATR(34,2)= 1.878378378    D0                                   CNI59930
      ZSLATR(35,2)= 2.054054054    D0                                   CNI59940
C-----------------------------------------------------------------------CNI59950
      RKAPPA( 1,1)= 0.00   D0                                           CNI59960
      RKAPPA( 3,1)= 0.12   D0                                           CNI59970
      RKAPPA( 4,1)= 0.12   D0                                           CNI59980
      RKAPPA( 5,1)= 0.12   D0                                           CNI59990
      RKAPPA( 6,1)= 0.12   D0                                           CNI60000
      RKAPPA( 7,1)= 0.12   D0                                           CNI60010
      RKAPPA( 8,1)= 0.12   D0                                           CNI60020
      RKAPPA( 9,1)= 0.12   D0                                           CNI60030
      RKAPPA(11,1)= 0.26   D0                                           CNI60040
      RKAPPA(12,1)= 0.26   D0                                           CNI60050
      RKAPPA(13,1)= 0.26   D0                                           CNI60060
      RKAPPA(14,1)= 0.26   D0                                           CNI60070
      RKAPPA(15,1)= 0.26   D0                                           CNI60080
      RKAPPA(16,1)= 0.26   D0                                           CNI60090
      RKAPPA(17,1)= 0.26   D0                                           CNI60100
      RKAPPA(34,1)= 0.20   D0                                           CNI60110
      RKAPPA(35,1)= 1.00   D0                                           CNI60120
    7 IF (INUPAR.NE.5) GO TO 8                                          CNI60130
C-----INUPAR=5:GORDON,BJORKE,MARSH & KORTH, J.AM.CHEM.SOC.100,2670(1978)CNI60160
      ENEG(11,1)=   2.804  D0                                           CNI60180
      ENEG(11,2)=   1.302  D0                                           CNI60190
      ENEG(12,1)=   5.125  D0                                           CNI60200
      ENEG(12,2)=   2.052  D0                                           CNI60210
      ENEG(13,1)=   7.771  D0                                           CNI60220
      ENEG(13,2)=   2.995  D0                                           CNI60230
      ENEG(14,1)=   7.50   D0                                           CNI60240
      ENEG(14,2)=   4.00   D0                                           CNI60250
      ENEG(15,1)=  16.20   D0                                           CNI60260
      ENEG(15,2)=   4.10   D0                                           CNI60270
      ENEG(16,1)=  17.51   D0                                           CNI60280
      ENEG(16,2)=   3.45   D0                                           CNI60290
      ENEG(17,1)=  25.11   D0                                           CNI60300
      ENEG(17,2)=   6.34   D0                                           CNI60310
      BETA0(11)=   -4.0    D0                                           CNI60320
      BETA0(12)=   -7.0    D0                                           CNI60330
      BETA0(13)=   -9.0    D0                                           CNI60340
      BETA0(14)=   -8.0    D0                                           CNI60350
      BETA0(15)=  -13.0    D0                                           CNI60360
      BETA0(16)=  -16.5    D0                                           CNI60370
      BETA0(17)=  -18.0    D0                                           CNI60380
    8 IF (OPTION.EQ.CNDO) GO TO 10                                       CNI60400
    9 ATENG(1)=  -0.6387302462  D0                                      CNI60410
      ATENG(3)=  -0.2321972405  D0                                      CNI60420
      ATENG(4)=  -1.1219620354  D0                                      CNI60430
      ATENG(5)=  -2.8725750048  D0                                      CNI60440
      ATENG(6)=  -5.9349548261  D0                                      CNI60450
      ATENG(7)= -10.6731741251  D0                                      CNI60460
      ATENG(8)= -17.2920850650  D0                                      CNI60470
      ATENG(9)= -26.2574377875  D0                                      CNI60480
      GO TO 11                                                          CNI60490
   10 ATENG(1)=  -0.6387302462  D0                                      CNI60500
      ATENG(3)=  -0.2321972405  D0                                      CNI60510
      ATENG(4)=  -1.1454120355  D0                                      CNI60520
      ATENG(5)=  -2.9774239048  D0                                      CNI60530
      ATENG(6)=  -6.1649936261  D0                                      CNI60540
      ATENG(7)= -11.0768746252  D0                                      CNI60550
      ATENG(8)= -18.0819658651  D0                                      CNI60560
      ATENG(9)= -27.5491302880  D0                                      CNI60570
      ATENG(11)= -0.1977009568  D0                                      CNI60580
      ATENG(12)= -0.8671913833  D0                                      CNI60590
      ATENG(13)= -2.0364557744  D0                                      CNI60600
      ATENG(14)= -3.8979034686  D0                                      CNI60610
      ATENG(15)= -6.7966009163  D0                                      CNI60620
      ATENG(16)=-10.7658174341  D0                                      CNI60630
      ATENG(17)=-16.0467017940  D0                                      CNI60640
      ATENG(32)= -3.594790      D0                                      CNI60650
      ATENG(33)= -5.843210      D0                                      CNI60660
      ATENG(34)= -9.034325      D0                                      CNI60670
      ATENG(35)=-13.097552      D0                                      CNI60680
C05---READ IN ATOM PARAMETER DATA CARD TYPE 5 (12 OCT 2020)-------------CNI60690
   11 READ (LINPUT,12) NPARAM,FUDGE,IBIM                                CNI60700
   12 FORMAT (7X,I1,6X,F10.0,5X,I2)                                     CNI60710
      IF (FUDGE.EQ.0) FUDGE=1.0D0                                       CNI60711
      WRITE (LOUTPT,13) FUDGE,IBIM                                      CNI60712
   13 FORMAT (/' TO BETTER FIT THE SUM OF ALL ATOM-IN-MOLECULE (OR BON',CNI60713
     1'D-IN-MOLECULE)'/' POLARIZABILITIES TO THE COMPUTED MOLECULAR PO',CNI60714
     2'LARIZABILITIES'/' THE MINIMUM BOND DISTANCE USED IS MULTIPLIED ',CNI60715
     3'BY THE ARBITRARY PARAMETER'/' FUDGE=',F7.4,' (FUDGE MUST BE',    CNI60716
     4' NON-ZERO; FUDGE=1.0 MEANS ZERO FITTING)'//' ATOM IBIM='         CNI60717
     5,I3,' IS OMITTED FROM THE LIST OF BOND-IN-MOLECULE POLARIZABILIT',CNI60718
     6'IES'/)                                                           CNI60719
      WRITE (LOUTPT,14)                                                 CNI60720
   14 FORMAT (' ',72('-')                                               CNI60721
     1/' EL. ORB.     ATOM    BETA     ELECTRO SLATER    SLATER-CONDON' CNI60722
     2/'              ENERGY           NEGATIV EXPON.    PARAMETERS'    CNI60723
     3/'              EV      EV       EV      1/BOHR    F(1)    G(2)'  CNI60724
     4/' --------     -------  ------- ------- -------   ------  ----- 'CNI60725
     5/'                              POLARIZABILITY MIX PARAMETERS'    CNI60726
     6/' --------     -------  ------- -------  ------    ------- ')    CNI60727
      DO 27 I=1,NPARAM                                                  CNI60728
         K=I                                                            CNI60729
C06------READ PATCH SLATER ORBITAL DATA CARDS TYPE 6 FOR ATOMS----------CNI60730
         READ (LINPUT,15) K,ZSLATR(K,2),ENEGG,RKAPPA(K,1),RKAPPA(K,2),  CNI60731
     1   RKAPPA(K,3),RKAPPA(K,4),RKAPPA(K,5),RKAPPA(K,6)                CNI60731
   15    FORMAT (7X,I2,2X,F5.3,2X,F5.3,6(3X,F5.3))                      CNI60732
         IF (K.EQ.1) ENEG(K,2)=ENEGG                                    CNI60733
         IF (K.GT.1) ENEG(K,3)=ENEGG                                    CNI60734
C--------HYDROGEN-------------------------------------------------------
         IF (K.EQ.1) WRITE (LOUTPT,16) K,EL0(K),ATENG(K),BETA0(K),      CNI60761
     1   ENEG(K,1),ZSLATR(K,1),F2(K),G1(K)                              CNI60764
   16    FORMAT (' ',I2,1X,A2,' 1S',4X,6F8.4)                           CNI60762
         IF (K.EQ.1.AND.IPOLAR.GE.1) WRITE (LOUTPT,17) EL0(K),          CNI60766
     1   ENEG(K,2),ZSLATR(K,2),RKAPPA(K,1),RKAPPA(K,2),RKAPPA(K,3),     CNI60769
     2   RKAPPA(K,4),RKAPPA(K,5),RKAPPA(K,6)                            CNI60770
   17    FORMAT (' ',3X,A2,' 2P*',19X,2F8.4/29X,6F8.4)                  CNI60767
C--------LITHIUM THROUGH FLUORINE---------------------------------------
         IF (K.GT.1.AND.K.LE.8) WRITE (LOUTPT,18) K,EL0(K),             CNI60761
     1   ATENG(K),BETA0(K),ENEG(K,1),ZSLATR(K,1),F2(K),G1(K)            CNI60764
   18    FORMAT (' ',I2,1X,A2,' 2S',4X,6F8.4)                           CNI60762
         IF (K.GT.1.AND.K.LE.8) WRITE (LOUTPT,19) EL0(K),               CNI60761
     1   ENEG(K,2),ZSLATR(K,2)                                          CNI60764
   19    FORMAT (' ',3X,A2,' 2P',20X,2F8.4)                             CNI60762
         IF (K.GT.1.AND.K.LE.8.AND.IPOLAR.GE.1) WRITE (LOUTPT,20) EL0(K)CNI60761
     1   ,ENEG(K,3),ZSLATR(K,2),RKAPPA(K,1),RKAPPA(K,2),                CNI60769
     2   RKAPPA(K,3),RKAPPA(K,4),RKAPPA(K,5),RKAPPA(K,6)                CNI60764
   20    FORMAT (' ',3X,A2,' 3D*',19X,2F8.4/29X,6F8.4)                  CNI60762
C--------SODIUM THROUGH CHLORINE----------------------------------------
         IF (K.GT.8.AND.K.LE.18) WRITE (LOUTPT,21) K,EL0(K),            CNI60761
     1   ATENG(K),BETA0(K),ENEG(K,1),ZSLATR(K,1),F2(K),G1(K)            CNI60764
   21    FORMAT (' ',I2,1X,A2,' 3S',4X,6F8.4)                           CNI60762
         IF (K.GT.8.AND.K.LE.18) WRITE (LOUTPT,22) EL0(K),ATENG(K),     CNI60761
     1   BETA0(K),ENEG(K,1),ZSLATR(K,2),F2(K),G1(K)                     CNI60764
   22    FORMAT (' ',3X,A2,' 3P',6F8.4)                                 CNI60762
         IF (K.GT.8.AND.K.LE.18.AND.IPOLAR.GE.1) WRITE (LOUTPT,23)      CNI60761
     1   EL0(K),ENEG(K,2),ZSLATR(K,2),RKAPPA(K,1),RKAPPA(K,2),          CNI60769
     2   RKAPPA(K,3),RKAPPA(K,4),RKAPPA(K,5),RKAPPA(K,6)                CNI60764
   23    FORMAT (' ',3X,A2,' 4D*',6F8.4)                                CNI60762
C--------POTASSIUM THROUGH BROMINE--------------------------------------
         IF (K.GT.18.AND.K.LE.35) WRITE (LOUTPT,24) K,EL0(K),           CNI60761
     1   ATENG(K),BETA0(K),ENEG(K,1),ZSLATR(K,1),F2(K),G1(K)            CNI60764
   24    FORMAT (' ',I2,1X,A2,' 4S',4X,6F8.4)                           CNI60762
         IF (K.GT.18.AND.K.LE.35) WRITE (LOUTPT,25) EL0(K),ATENG(K),    CNI60761
     1   BETA0(K),ENEG(K,1),ZSLATR(K,2),F2(K),G1(K)                     CNI60764
   25    FORMAT (' ',3X,A2,' 4P',6F8.4)                                 CNI60762
         IF (K.GT.18.AND.K.LE.35.AND.IPOLAR.GE.1) WRITE (LOUTPT,26)     CNI60761
     1   EL0(K),ENEG(K,2),ZSLATR(K,2),RKAPPA(K,1),RKAPPA(K,2),          CNI60769
     2   RKAPPA(K,3),RKAPPA(K,4),RKAPPA(K,5),RKAPPA(K,6)                CNI60764
   26    FORMAT (' ',3X,A2,' 5D*',6F8.4)                                CNI60762
   27 CONTINUE                                                          CNI60779
      WRITE (LOUTPT,28)
   28 FORMAT (' ',72('-')/' * = POLARIZABILITY FUNCTIONS')

      RETURN                                                            CNI60780
CE.37 END OF ATDATA (CNDOP)---------------------------------------------CNI60790
      END                                                               CNI60800
      DOUBLE PRECISION FUNCTION WACOS(X)                                CNI60810
CB.38 LAST CHANGE 08 SEP 1980                                           CNI60820
C     CALLED BY: DIPOLE(18),DIAGON(29)                                  CNI60830
C     CALLS    : NONE                                                   CNI60840
C-----COMPUTES DOUBLE PRECISION ARC COSINE                              CNI60850
      DOUBLE PRECISION X                                                CNI60860
      Y=X                                                               CNI60870
      Z=ACOS(Y)                                                         CNI60880
      WACOS=Z                                                           CNI60890
      RETURN                                                            CNI60900
CE.38 END OF WACOS (CNDOP)----------------------------------------------CNI60910
      END                                                               CNI60920
      SUBROUTINE ON (Q,B,C,ORB,GRO,XX7,EIGVAL,XX9,GAMMA,BOLD,ALPH2F,    CNI60930
     1ATLCHF,XXY,XXZ,IATNO,ICORE,IOR2AT,LIMU,LIML,IGAM,IPOSV,IVPOS,IORD)CNI60940
CB.39 LAST CHANGE 17 JUL 1998 (CNDOP)-----------------------------------CNI60950
C     CALLED BY: SCFCLO(16),SCFOPN(20)                                  CNI60960
C     CALLS    : INTGRL(08),EIGN  (22),SCFOUT(23)                       CNI04350
C-----ROALD HOFFMAN CNDO/ON SCHEME, FROM J.PHYS.CHEM.74,420(1970)-------CNI60980
C     USING PROGRAM CNDOTWO, SUBROUTINES EIGEN,MATHOM.                  CNI60990
C     INPUT : B= EIGENVECTOR MX OF FOCK MATRIX                          CNI61150
C-----OUTPUT: B= HOFFMAN COMPLETE CHARGE MATRIX-------------------------CNI61160
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI61000
      CHARACTER*4 ITITOL,EL                                             CNI61005
      INTEGER IATNO                                                     CNI61130
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI61060
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI61070
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI61080
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI61090
      COMMON/INFOX/NATOMS,II1(2),N,II2(1),NOCCA,NOCCB,LIMG,IPREC        CNI61110
      COMMON/PERTBL/ALPHAT(35),EL(35)                                   CNI07920
      DIMENSION Q(N,N),B(N,N),C(NATOMS,3),ORB(N),GRO(N),                CNI61010
     1XX7(N),EIGVAL(N),XX9(N),GAMMA(LIMG,LIMG),BOLD(N,N),               CNI61020
     2ALPH2F(NATOMS,3,3),ATLCHF(NATOMS,3),XXY(N),XXZ(N),                CNI61030
     3IATNO(NATOMS),ICORE(NATOMS),IOR2AT(N),LIMU(NATOMS),LIML(NATOMS),  CNI61040
     4IGAM(N),IPOSV(N),IVPOS(N),IORD(N)                                 CNI61050
      IHOFMN=IHOFMN+1                                                   CNI61140
C *** COMPUTE INTEGRALS AGAIN: OUTPUT: Q= ATOMIC OVERLAP MATRIX---------CNI61170
      CALL INTGRL (Q,C,GRO,EIGVAL,GAMMA,ALPH2F,ATLCHF,IATNO,            CNI61180
     1ICORE,IOR2AT,LIMU,LIML,IGAM)                                      CNI61190
C-----DIAGONALIZE MULLIKEN OVERLAP MATRIX-------------------------------CNI61210
C     INPUT:  Q     = ATOMIC OVERLAP MATRIX                             CNI61220
C     OUTPUT: EIGVAL= DIAGONAL OVERLAP EIGENVALUES                      CNI61230
C             BOLD  = EIGENVECTOR MX OF OVERLAP MX                      CNI61240
C *** CLOBBERED BY EIGN: Q.---------------------------------------------CNI61250
      CALL EIGN(N,RHO,Q,BOLD,ORB,GRO,XX7,EIGVAL,XX9,XXY,XXZ,IPOSV,IVPOS,CNI
     1IORD)                                                             CNI61260
      WRITE (LOUTPT,98)                                                 CNI61280
   98 FORMAT (' DIAGONALIZED MULLIKEN OVERLAP ')                        CNI61290
C *** PRINT MULLIKEN OVERLAP MATRIX-------------------------------------CNI
      IF (IBRIEF.EQ.0)CALL SCFOUT (0,BOLD,EIGVAL,IATNO,IOR2AT,LIMU,LIML)CNI61300
C-----COMPUTE WAVEFUNCTIONS, STO BASIS----------------------------------CNI61310
C     INPUT: BOLD  = EIGENVECTOR MX OF OVERLAP MX                       CNI61320
C            EIGVAL= DIAGONALIZED OVERLAP                               CNI61330
C            B     = EIGENVECTOR MX OF FOCK MATRIX                      CNI61340
C-----OUTPUT:BOLD  = WAVEFUNCTIONS, STO BASIS                           CNI61350
      DO 1 I=1,N                                                        CNI61360
         EIGVAL(I)=1.D0/DSQRT(EIGVAL(I))                                CNI61370
    1 CONTINUE                                                          CNI61380
      DO 4 I=1,N                                                        CNI61390
         DO 3 J=1,N                                                     CNI61400
            Q(I,J)=0.D0                                                 CNI61410
            DO 2 K=1,N                                                  CNI61420
               Q(I,J)=Q(I,J)+BOLD(I,K)*EIGVAL(K)*BOLD(J,K)              CNI61430
    2       CONTINUE                                                    CNI61440
    3    CONTINUE                                                       CNI61450
    4 CONTINUE                                                          CNI61460
      DO 7 I=1,N                                                        CNI61470
         DO 6 J=1,N                                                     CNI61480
            BOLD(I,J)=0.D0                                              CNI61490
            DO 5 K=1,N                                                  CNI61500
               BOLD(I,J)=BOLD(I,J)+Q(I,K)*B(K,J)                        CNI61510
    5       CONTINUE                                                    CNI61520
    6    CONTINUE                                                       CNI61530
    7 CONTINUE                                                          CNI61540
      WRITE (LOUTPT,8)                                                  CNI61550
    8 FORMAT (' WAVEFUNCTIONS, STO BASIS')                              CNI61560
C *** PRINT STO BASIS WAVEFUNCTIONS-------------------------------------CNI61570
      CALL SCFOUT (0,BOLD,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                CNI61580
C *** RECOMPUTE OVERLAP IN S -------------------------------------------CNI61590
      CALL INTGRL (Q,C,GRO,EIGVAL,GAMMA,ALPH2F,ATLCHF,IATNO,            CNI61600
     1ICORE,IOR2AT,LIMU,LIML,IGAM)                                      CNI61610
C-----COMPUTE COMPLETE CHARGE MATRIX------------------------------------CNI61620
C     INPUT : BOLD =WAVEFUNCTIONS, STO BASIS                            CNI61630
C             Q    =OVERLAP MATRIX                                      CNI61640
C-----OUTPUT: B    =COMPLETE CHARGE MATRIX------------------------------CNI61650
      DO 35 I=1,N                                                       CNI61660
         DO 34 J=1,N                                                    CNI61670
            B(I,J)=0.D0                                                 CNI61680
            DO 33 K=1,N                                                 CNI61690
               B(I,J)=B(I,J)+Q(I,K)*BOLD(K,J)                           CNI61700
   33       CONTINUE                                                    CNI61710
   34    CONTINUE                                                       CNI61720
   35 CONTINUE                                                          CNI61730
      DO 41 I=1,N                                                       CNI61740
         DO 40 J=1,N                                                    CNI61750
            B(I,J)=2.D0*B(I,J)*BOLD(I,J)                                CNI61760
   40    CONTINUE                                                       CNI61770
   41 CONTINUE                                                          CNI61780
      WRITE (LOUTPT,42)                                                 CNI61790
   42 FORMAT (///' COMPLETE CHARGE MATRIX')                             CNI61800
C *** PRINT COMPLETE CHARGE MATRIX--------------------------------------CNI61810
      CALL SCFOUT (0,B,EIGVAL,IATNO,IOR2AT,LIMU,LIML)                   CNI61820
      DO 64 I=1,N                                                       CNI61830
         DO 62 J=I,N                                                    CNI61840
            ORB(J)=0.D0                                                 CNI61850
            DO 61 K=1,NOCCA                                             CNI61860
               ORB(J)=ORB(J)+B(I,K)                                     CNI61870
   61       CONTINUE                                                    CNI61880
   62    CONTINUE                                                       CNI61890
         DO 63 J=I,N                                                    CNI61900
            B(I,J)=ORB(J)                                               CNI61910
   63    CONTINUE                                                       CNI61920
   64 CONTINUE                                                          CNI61930
      DO 66 I=1,N                                                       CNI61940
         DO 65 J=1,N                                                    CNI61950
            B(J,I)=B(I,J)                                               CNI61960
   65    CONTINUE                                                       CNI61970
   66 CONTINUE                                                          CNI61980
  999 RETURN                                                            CNI61990
CE.39 END OF ON (CNDOP)-------------------------------------------------CNI62000
      END                                                               CNI62010
      SUBROUTINE SOLPUL (PULAY,PLAM)                                    CNI62020
CB.40 LAST CHANGE 14 MAR 1986 (CNDOP)-----------------------------------CNI62030
C     CALLED BY: SCFCLO(16),SCFOPN(20)                                  CNI62040
C     CALLS    : DETPUL(41)                                             CNI62050
C-----PULAY DIIS METHOD (WRITTEN BY R.E.SCHMIEG, JR., 1984)             CNI62060
C     THIS SUBROUTINE ACCEPTS THE PULAY ERROR MATRIX                    CNI62070
C-----AND COMPUTES THE COEFFICIENTS FOR THE HYBRID FOCK MATRIX          CNI62080
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI62090
      DIMENSION PULAY(6,6),PLAM(6)                                      CNI62100
      DIMENSION ADAM(6,6),BOB(6,6),ADPUL(6)                             CNI62110
C-----SET UP THRESHOLD VALUE FOR ILL-CONDITIONING CRITERION             CNI62120
      RTHRS=0.1D-07                                                     CNI62130
C-----FIRST SEE IF PULAY TRICK WILL WORK WITH 6*6 MATRIX                CNI62140
C-----IF NOT, THROW OUT OLDEST TRACES IN PULAY                          CNI62150
      N=6                                                               CNI62160
      DO 10 I=1,6                                                       CNI62170
        ADAM(1,I)=PULAY(1,I)                                            CNI62180
        ADAM(I,1)=PULAY(I,1)                                            CNI62190
   10 CONTINUE                                                          CNI62200
C-----CREATE WORKING PULAY MATRIX IN ADAM                               CNI62210
   20 NN=8-N                                                            CNI62220
      KK=6-N                                                            CNI62230
      DO 40 I=NN,6                                                      CNI62240
        II=I-KK                                                         CNI62250
        DO 30 J=NN,6                                                    CNI62260
          JJ=J-KK                                                       CNI62270
          ADAM(II,JJ)=PULAY(I,J)                                        CNI62280
   30   CONTINUE                                                        CNI62290
   40 CONTINUE                                                          CNI62300
C-----CHECK ADAM FOR ILL-CONDITIONING-----------------------------------CNI62310
C-----SEE CONTE,S.D., ELEM. NUMERICAL ANALYSIS, P.164-167, EQ.(5.17)    CNI62320
      ADPUL(1)=DBLE(FLOAT(N-1))                                         CNI62340
      PUDIV=ADPUL(1)                                                    CNI62350
      DO 60 I=2,N                                                       CNI62360
         ADPUL(I)=0.0D0                                                 CNI62370
         DO 50 J=2,N                                                    CNI62380
            ADPUL(I)=ADPUL(I)+ADAM(I,J)*ADAM(I,J)                       CNI62390
   50    CONTINUE                                                       CNI62400
         PUDIV=PUDIV*ADPUL(I)                                           CNI62410
   60 CONTINUE                                                          CNI62420
      PUDIV=DSQRT(PUDIV)                                                CNI62430
C-----CREATE BOB -------------------------------------------------------CNI62440
      DO 80 I=1,N                                                       CNI62450
         DO 70 J=1,N                                                    CNI62460
            BOB(I,J)=ADAM(I,J)                                          CNI62470
   70    CONTINUE                                                       CNI62480
   80 CONTINUE                                                          CNI62490
C ***                                                                   CNI62500
      DETA=DETPUL (BOB,N)                                               CNI62510
      IF (DABS(PUDIV).LT.0.1D-30) GO TO 199                             CNI62520
      DETA=DABS(DETA/PUDIV)                                             CNI62530
C-----CHECK IF DETA IS GREATER THAN ILL-CONDITIONING CRITERION----------CNI62540
      IF (DETA.GT.RTHRS) GO TO 210                                      CNI62550
C-----CURRENT WORKING PULAY MATRIX IN ADAM IS ILL-CONDITIONED-----------CNI62560
C-----TRY AGAIN, THROWING AWAY OLDEST SET OF TRACES IN PULAY------------CNI62570
  199 N=N-1                                                             CNI62580
      IF (N.GT.2) GO TO 20                                              CNI62590
C-----HAVE COME TO TRIVIAL CONSIDERATIONS-------------------------------CNI62600
C-----HYBRID FOCK MATRIX IS MERELY THE CURRENT FOCK MATRIX--------------CNI62610
      DO 200 I=1,5                                                      CNI62620
         PLAM(I)=0.0D0                                                  CNI62630
  200 CONTINUE                                                          CNI62640
      PLAM(6)=1.0D0                                                     CNI62650
      GO TO 999                                                         CNI62660
C-----CURRENT MATRIX IN ADAM IS WELL-CONDITIONED------------------------CNI62670
C     SOLVE FOR LAMBDA VALUES FOR HYBRID FOCK MATRIX                    CNI62680
C-----CREATE INITIAL VALUES IN PLAM-------------------------------------CNI62690
  210 DO 220 I=2,6                                                      CNI62700
         PLAM(I)=0.0D0                                                  CNI62710
  220 CONTINUE                                                          CNI62720
      PLAM(1)=-1.0D0                                                    CNI62730
C-----SOLVE WITH MAXIMUM-PIVOT POINT STRATEGY                           CNI62740
C-----PERFORM PROCEDURE FOR EACH COLUMN OF ADAM                         CNI62750
      DO 360 K=1,N                                                      CNI62760
C--------FIND ROW WITH MAXIMUM ELEMENT FOR CURRENT COLUMN               CNI62770
         COLMAX=DABS(ADAM(K,K))                                         CNI62780
         MAXROW=K                                                       CNI62790
         DO 300 I=K,N                                                   CNI62800
            COL=DABS(ADAM(I,K))                                         CNI62810
            IF (COL.LE.COLMAX) GO TO 300                                CNI62820
            COLMAX=COL                                                  CNI62830
            MAXROW=I                                                    CNI62840
  300    CONTINUE                                                       CNI62850
         IF (MAXROW.EQ.K) GO TO 320                                     CNI62860
C--------NEED TO SWITCH ROWS                                            CNI62870
         DO 310 J=1,N                                                   CNI62880
            TEMP=ADAM(K,J)                                              CNI62890
            ADAM(K,J)=ADAM(MAXROW,J)                                    CNI62900
            ADAM(MAXROW,J)=TEMP                                         CNI62910
  310    CONTINUE                                                       CNI62920
         TEMP=PLAM(K)                                                   CNI62930
         PLAM(K)=PLAM(MAXROW)                                           CNI62940
         PLAM(MAXROW)=TEMP                                              CNI62950
C--------FINISHED SWITCHING ROWS                                        CNI62960
C--------NORMALIZE K-TH ROW BY DIVIDING BY (K,K) ELEMENT                CNI62970
  320    TEMP=ADAM(K,K)                                                 CNI62980
         DO 330 J=1,N                                                   CNI62990
            ADAM(K,J)=ADAM(K,J)/TEMP                                    CNI63000
  330    CONTINUE                                                       CNI63010
         PLAM(K)=PLAM(K)/TEMP                                           CNI63020
C--------FINISHED NORMALIZATION OF K-TH ROW                             CNI63030
C--------PERFORM GAUSSIAN ELIMINATION FOR THE K-TH COLUMN               CNI63040
         DO 350 I=1,N                                                   CNI63050
            IF (I.EQ.K) GO TO 350                                       CNI63060
            TEMP=ADAM(I,K)                                              CNI63070
            DO 340 J=1,N                                                CNI63080
               ADAM(I,J)=ADAM(I,J)-ADAM(K,J)*TEMP                       CNI63090
  340       CONTINUE                                                    CNI63100
            PLAM(I)=PLAM(I)-PLAM(K)*TEMP                                CNI63110
  350    CONTINUE                                                       CNI63120
  360 CONTINUE                                                          CNI63130
      IF (N.EQ.6) GO TO 999                                             CNI63140
C-----ELEMENTS IN PLAM NOT IN CORRECT ORDER (N=3,4,5)                   CNI63150
C-----MOVE PLAM ELEMENTS TO PROPER PLACES                               CNI63160
      DO 400 I=2,N                                                      CNI63170
         II=N-I+2                                                       CNI63180
         JJ=8-I                                                         CNI63190
         PLAM(JJ)=PLAM(II)                                              CNI63200
  400 CONTINUE                                                          CNI63210
      NN=7-N                                                            CNI63220
      DO 410 I=2,NN                                                     CNI63230
         PLAM(I)=0.0D0                                                  CNI63240
  410 CONTINUE                                                          CNI63250
  999 CONTINUE                                                          CNI63260
      RETURN                                                            CNI63270
CE.40 END OF SOLPUL (CNDOP)---------------------------------------------CNI63280
      END                                                               CNI63290
      DOUBLE PRECISION FUNCTION DETPUL (BOB,N)                          CNI63300
CB.41 LAST CHANGE 06 JUN 1984 (CNDOP)-----------------------------------CNI63310
C     CALLED BY: SOLPUL(40)                                             CNI63320
C     CALLS    : NONE                                                   CNI63330
C-----COMPUTES DETERMINANT OF N X N MATRIX, N.LE.6 (R.E.SCHMIEG, JR.)   CNI63340
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI63350
C-----USES MAXIMAL-PIVOT POINT GAUSSIAN ELIMINATION                     CNI63360
      DIMENSION BOB(6,6)                                                CNI63370
      DET=1.0D0                                                         CNI63380
C-----PERFORM MAX. PIVOT POINT STRAT. FOR EACH COLUMN                   CNI63390
      DO 160 K=1,N                                                      CNI63400
         COLMAX=DABS(BOB(K,K))                                          CNI63410
         MAXROW=K                                                       CNI63420
C--------FIND THE MAXIMUM ELEMENT IN THE KTH COLUMN                     CNI63430
         DO 100 I=K,N                                                   CNI63440
            IF (DABS(BOB(I,K)).LE.COLMAX) GO TO 100                     CNI63450
            COLMAX=DABS(BOB(I,K))                                       CNI63460
            MAXROW=I                                                    CNI63470
100      CONTINUE                                                       CNI63480
C--------DEVELOPING UPPER DIAGONAL MATRIX                               CNI63490
C--------DET= PRODUCT OF DIAGONAL ELEMENTS                              CNI63500
         DET=DET*COLMAX                                                 CNI63510
         IF (DET.EQ.0.0D0) GO TO 160                                    CNI63520
C--------SWITCH ROWS IF NECESSARY                                       CNI63530
         IF (MAXROW.EQ.K) GO TO 120                                     CNI63540
         DO 110 J=1,N                                                   CNI63550
            TEMP=BOB(K,J)                                               CNI63560
            BOB(K,J)=BOB(MAXROW,J)                                      CNI63570
            BOB(MAXROW,J)=TEMP                                          CNI63580
  110    CONTINUE                                                       CNI63590
C--------DIVIDE ALL ELEMENTS OF THE KTH ROW BY                          CNI63600
C--------THE ELEMENT IN THE KTH COLUMN                                  CNI63610
  120    TEMP=BOB(K,K)                                                  CNI63620
         DO 130 J=1,N                                                   CNI63630
            BOB(K,J)=BOB(K,J)/TEMP                                      CNI63640
  130    CONTINUE                                                       CNI63650
C--------GAUSSIAN ELIMINATION                                           CNI63660
         DO 150 I=K,N                                                   CNI63670
            IF (I.EQ.K) GO TO 150                                       CNI63680
            TEMP=BOB(I,K)                                               CNI63690
            DO 140 J=1,N                                                CNI63700
               BOB(I,J)=BOB(I,J)-BOB(K,J)*TEMP                          CNI63710
  140       CONTINUE                                                    CNI63720
  150    CONTINUE                                                       CNI63730
  160 CONTINUE                                                          CNI63740
      DETPUL=DABS(DET)                                                  CNI63750
      RETURN                                                            CNI63760
CE.41 END OF DETPUL (CNDOP)---------------------------------------------CNI63770
      END                                                               CNI63780
      SUBROUTINE REPUL (R,K,ANK,L,ANL,N1,K1,N2,K2,GAMMAS,COUL)          CNI63790
CB.42 LAST CHANGE 22 MAR 1985 (CNDOP)-----------------------------------CNI63800
C     CALLED BY: INTGRL(08)                                             CNI63810
C     CALLS    : SS    (09),FACT  (12),COULJE(43)                       CNI04410
C-----COULOMB REPULSION INTEGRALS (JAMES E.EILERS, EASTMAN KODAK, 1985) CNI63830
C-----WRITTEN 22 MAR 1985 AT EASTMAN KODAK RESEARCH LABORATORY----------CNI63840
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI63850
      CHARACTER*4 ITITOL                                                CNI63855
      INTEGER ANK,ANL                                                   CNI63860
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI63870
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI63880
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI63890
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI63900
      COMMON/INFOX/NATOMS,NCHARG,II1(1),N,NELECS,NOCCA,II2(1),LIMG,IPRECCNI63920
      COMMON/AUXINT/A(17),B(17)                                         CNI63930
      COMMON/ATOMIC/ENEG(35,3),BETA0(35),G1(35),F2(35),ATENG(35),BETAD, CNI63940
     1RKAPPA(35,6)                                                      CNI63950
      DIMENSION GAMMAS(35)                                              CNI63960
      DOUBLE PRECISION K1,K2,KOLD                                       CNI63970
      IF (K.NE.L) GO TO 290                                             CNI63980
      IF (INUPAR.LE.1) GO TO 270                                        CNI63990
C-----DEL BENE AND JAFFE 1-CENTER REPULSION INTEGRAL                    CNI64000
      IF (INUPAR.EQ.2.OR.INUPAR.EQ.3) COUL=GAMMAS(ANK)/HARTRE           CNI64010
C-----KROGH-JESPERSEN AND RATNER 1-CENTER REPULSION INTEGRAL            CNI64020
      IF (INUPAR.EQ.4) COUL=GAMMAS(ANK)/HARTRE                          CNI64030
      GO TO 319                                                         CNI64040
C-----POPLE: COMPUTE GAMMA AS IF IT WERE BETWEEN S ORBITALS             CNI64050
  270 CONTINUE                                                          CNI64060
C ***                                                                   CNI64070
      CALL COULJE (N1,N2,K1,K2,EGAM)                                    CNI64080
      GO TO 311                                                         CNI64090
C-----COMPUTE 2-CENTER COULOMB INTEGRALS OVER SLATER S FUNCTIONS        CNI64100
  290 IF (INUPAR.EQ.2) GO TO 318                                        CNI64110
      IF (INUPAR.EQ.3) GO TO 318                                        CNI64120
      IF (INUPAR.EQ.4) GO TO 318                                        CNI64130
      TERM1=(R/2.D0)**(2*N2)*SS(0,0,0,2*N2-1,0,0.D0,2.D0*K2*R)          CNI64140
      TERM2=0.D0                                                        CNI64150
      LIM=2*N1                                                          CNI64160
      DO 300 J=1,LIM                                                    CNI64170
CIBM     TERM2=TERM2+(DFLOAT(J)*(2.D0*K1)**(2*N1-J)*(R/2.D0)            CNI64180
CIBM 1   **(2*N1-J+2*N2))/(FACT(2*N1-J)*2.D0*DFLOAT(N1))*               CNI64190
CIBM 2   SS(2*N1-J,0,0,2*N2-1,0,2.D0*K1*R,2.D0*K2*R)                    CNI64200
         TERM2=TERM2+(DBLE(FLOAT(J))*(2.D0*K1)**(2*N1-J)*(R/2.D0)       CNI64180
     1   **(2*N1-J+2*N2))/(FACT(2*N1-J)*2.D0*DBLE(FLOAT(N1)))*          CNI64190
     2   SS(2*N1-J,0,0,2*N2-1,0,2.D0*K1*R,2.D0*K2*R)                    CNI64200
  300 CONTINUE                                                          CNI64210
  310 COUL=(((2.D0*K2)**(2*N2+1))/FACT(2*N2))*(TERM1-TERM2)             CNI64220
      GO TO 319                                                         CNI64230
  311 COUL=EGAM                                                         CNI64240
      GO TO 319                                                         CNI64250
C-----2-CENTER REPULSION INTEGRALS: R.L.ELLIS, G.KUEHNLENZ, AND H.H.    CNI64260
C     JAFFE, THEOR.CHIM.ACTA 26,131 (1972)                              CNI64270
C     K.KROGH-JESPERSEN AND M.RATNER, J.CHEM.PHYS.65,1305(1976)         CNI64280
C     AND THEOR.CHIM.ACTA 47,283(1978);                                 CNI64290
C     MATAGA-NISHIMOTO INTERPOLATION FORMULA, GIVEN BY N.O.LIPARI,      CNI64300
C-----AND C.B.DUKE, J.CHEM.PHYS.63,1748(1975) EQ.(4A)                   CNI64310
  318 COUL=1.D0/(2.D0*HARTRE/(GAMMAS(ANK)+GAMMAS(ANL))+R)               CNI64320
  319 RETURN                                                            CNI64330
CE.42 END OF REPUL (CNDOP)----------------------------------------------CNI64340
      END                                                               CNI64350
      SUBROUTINE COULJE (NA,NB,ZA,ZB,COUL)                              CNI64360
CB.43 LAST CHANGE 13 MAY 1985 (CNDOP)-----------------------------------CNI64370
C     CALLED BY: REPUL (42)                                             CNI64380
C     CALLS    : FACT  (12)                                             CNI64390
C-----PART OF COULOMB INTEGRAL - JAMES E.EILERS (KODAK, 17 APR 1985)    CNI64400
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI64410
      DOUBLE PRECISION NORMA,NORMB                                      CNI64420
      TWOZA=2.D0*ZA                                                     CNI64430
      TWOZB=2.D0*ZB                                                     CNI64440
      NATWO=2*NA                                                        CNI64450
      NBTWO=2*NB                                                        CNI64460
      NORMA=((TWOZA)**(NATWO+1))/FACT(NATWO)                            CNI64470
      NORMB=((TWOZB)**(NBTWO+1))/FACT(NBTWO)                            CNI64480
      NB2M1=NBTWO-1                                                     CNI64490
      NA2M1=NATWO-1                                                     CNI64500
      NB2P1=NBTWO+1                                                     CNI64510
      NSUM=NATWO+NBTWO                                                  CNI64520
      NSUMM1=NSUM-1                                                     CNI64530
      ZSUM=TWOZA+TWOZB                                                  CNI64540
      FAC1=FACT(NB2M1)/(TWOZB**NBTWO)                                   CNI64550
      SUM1=0.D0                                                         CNI64560
      DO 1 LL=1,NBTWO                                                   CNI64570
         L=LL-1                                                         CNI64580
         NFAC=NATWO+L                                                   CNI64590
         NDEXP=NATWO+LL                                                 CNI64600
         SUM1=SUM1+(TWOZB**L)*FACT(NFAC)/                               CNI64610
     1   (FACT(L)*(ZSUM**NDEXP))                                        CNI64620
    1 CONTINUE                                                          CNI64630
      GOUTER=FAC1*SUM1                                                  CNI64640
      TERM1=FACT(NBTWO)*FACT(NA2M1)/((TWOZB**NB2P1)*(TWOZA**NATWO))     CNI64650
      SUM2=0.D0                                                         CNI64660
      DO 2 KK=1,NB2P1                                                   CNI64670
         K=KK-1                                                         CNI64680
         NUMFAC=NSUM-K-1                                                CNI64690
         NDEXP=NSUM-K                                                   CNI64700
         NDFAC=NBTWO-K                                                  CNI64710
         SUM2=SUM2+FACT(NBTWO)*FACT(NUMFAC)/                            CNI64720
     1   ((TWOZB**KK)*FACT(NDFAC)*(ZSUM**NDEXP))                        CNI64730
    2 CONTINUE                                                          CNI64740
      GINNER=TERM1-1.D0*SUM2                                            CNI64750
      COUL=NORMA*NORMB*(GINNER+GOUTER)                                  CNI64760
      RETURN                                                            CNI64770
CE.43 END OF COULJE (CNDOP)---------------------------------------------CNI64780
      END                                                               CNI64790
      SUBROUTINE MATPRS (NATOMS,GAMMA,LIMG)                             CNI64800
CB.44 LAST CHANGE 13 MAY 1985 (CNDOP)-----------------------------------CNI64810
C     CALLED BY: INTGRL(08)                                             CNI64820
C     CALLS    : NONE                                                   CNI64830
C-----PRINT INTERATOMIC DISTANCES (J.E.EILERS, 1985)--------------------CNI64840
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               CNI64850
      CHARACTER*4 ITITOL                                                CNI64855
      COMMON/RMM/BOHR,HARTRE,DEBYE,FIELD,ZSLATR(35,2),CONVRG,RHO,RAD2DG,CNI64860
     1BONMIN,BONDMX,POLMU(17),SHIFTR,LINPUT,LOUTPT,LAUXOU,IHOFMN,       CNI64870
     2NLOCIT,IBRIEF,IPOLAR,IFIELD,NCYCLE,IPIECE,LPIECE,IPLFCN,          CNI64880
     3INUPAR,INODEE,ISHIFT,ISHORT,ITITOL(20),NPULAY,IRN,IDM,NHOMO       CNI64890
      DIMENSION GAMMA(LIMG,LIMG)                                        CNI64910
      DO 7 M=1,NATOMS,11                                                CNI64920
         K=M+10                                                         CNI64930
         IF (K.LE.NATOMS) GO TO 2                                       CNI64940
    1    K=NATOMS                                                       CNI64950
    2    WRITE (LOUTPT,3) (J,J=M,K)                                     CNI64960
    3    FORMAT (//7X,11(4X,I2,3X),//)                                  CNI64970
         DO 5 I=1,NATOMS                                                CNI64980
            WRITE (LOUTPT,4) I,(GAMMA(I,J),J=M,K)                       CNI64990
    4       FORMAT (1X,I2,4X,50(F9.4))                                  CNI65000
    5    CONTINUE                                                       CNI65010
         WRITE (LOUTPT,6)                                               CNI65020
    6    FORMAT (//)                                                    CNI65030
    7 CONTINUE                                                          CNI65040
      RETURN                                                            CNI65050
CE.44 END OF MATPRS (CNDOP)---------------------------------------------CNI65060
      END                                                               CNI65070
