C 11 APR 08 - PP,MW,JRG,TN,KI,DDK,LVS,JMM,RKC,HN,MC,SHY,SS,BNJ,SAN,HPTI-
C                         NEW DATE IN BOX IN HONOR OF:
C                   OPEN SHELL CC, CEEIS EXTRAP, MP2/IMS GRADIENT,
C                   EFP CHANGES FOR OPEN SHELL, EWALD SUMS, AND MD RUNS,
C                   IVO-CAS, GMCPT, TDDFT GRADIENT, UTDDFT ENERGY,
C                   META-GGA'S, INTERNAL COORD VSCF, G3MP2 THERMOCHEM,
C                   DFT GRID CHANGES AND PARALLELIZATION
C  4 MAR 08 - SPW - CHANGES FOR NEO GRADIENT
C  4 MAR 08 - HN  - WFNMP2: ADD CALL TO THE GMC-QDPT PROGRAM
C  4 MAR 08 - SHY - WFNTDDFT: ALLOW FOR UNRESTRICTED REFERENCE STATE
C  7 DEC 07 - MWS - BRNCHX: ADD BONDING ANALYSIS RUN TYPE
C 28 AUG 07 - HL  - HFGRAD: CHANGES FOR PCM GRADIENTS
C 20 AUG 07 - RKC - WFNMP2: IVO-CASCI RUN MAKES CALL TO MCQDPT
C 20 AUG 07 - DGF - VARIOUS CHANGES FOR FMO 3.1 RELEASE
C 27 JUL 07 - MC  - ADD TDDFT GRADIENT
C 25 JUN 07 - MWS - WFNCC: PRINT WARNING IF LARGE LCAO COEF EXISTS
C 21 MAY 07 - MWS - WFNCC: CALL EITHER CLOSED OR OPEN SHELL DRIVERS
C 24 MAR 07 - HM,TN,DGF,LVS,KI,PEA,SPW,BN,GMC,SS,RP,MC,AA -
C                         NEW DATE IN BOX IN HONOR OF:
C                   MCP GRAD; FMO+EFP; FMO3: PIEDA, 3-BODY MP2, ETC.,
C                   EFP SCREENING; NEO: POSITRONS, CI; DISK-BASED
C                   PARALLEL MP2 ENERGY; VSCF: INT. COORD, SUBGROUPS,
C                   COMBINATION BANDS; MANY NEW DFT FUNCTIONALS;
C                   TD-DFT AND LC-DFT; PARALLEL ORMAS-CI.
C 22 DEC 06 - ST,NK,MC,DGF,TN - LC EXCHANGE, FMO 3.0, FMO/EFP GRADIENT
C 19 NOV 06 - PEA - WFN: CALL FOR POSITRON PROPERTIES
C  6 NOV 06 - MWS - WFN: CALLS WFNTDDFT
C 25 OCT 06 - SPW - WFNCI: CHANGES TO CALL NEO-CI
C  7 SEP 06 - RMO,JLB,TJD,NM,FLG,YA,SPW,MWS,SS -
C                   NEW DATE IN BOX IN HONOR OF PARALLEL CCSD(T),
C                   DDI V3, SOUPED UP MCSCF HESSIANS, MEX SEARCH,
C                   ELONGATION METHOD, NEO INTERFACE, QUAMBO/VVO,
C                   AND POLARIZABILITY DECOMPOSITION
C 10 JUL 06 - MWS - SAVE NUCLEAR REPULSION FOR PURE CI JOBS
C  8 MAY 06 - BSD - SAVE VB2000 ENERGY CORRECTLY
C 29 MAR 06 - FLG - CHANGES FOR LOCALIZATION FOR ELONGATION METHOD
C 13 MAR 06 - NM  - INCLUDE MEX EXECUTION PATHWAY
C 22 FEB 06 - YA,TLW,SG,MK,MWS,HMN,OQ,MW,PP,HL,DGF,TN,LVS -
C                   NEW DATE IN BOX IN HONOR OF: DDI CPHF, NUM. POLAR.,
C                   MCP LIBRARY, RYS QUAD, MD TRAJ., TDHFX, CR-CCL,
C                   EFP+PCM GRAD, FMO+EFP AND FMO+PCM, PROPERTY REORG.,
C                   MAKEFP SOUPUPS (MULT.SCREEN, DYN.POL.SOLVERS)
C  2 FEB 06 - MWS - WFN,WFNMP2,WFNCI,WFNCIS: REORGANIZE PROPERTY CALLS
C 17 JAN 06 - MWS - WFNCC: ADD CR-CCSD(T)_L PATHWAY
C 14 NOV 05 - DGF - SOME PCM CLEANUP TOUCHES
C 19 SEP 05 - SPW - GAMESS,ENERGX,WFNCIS: ADD NEO HOOKS, FIX CISVEC READ
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - CMA,JI,PP,MW,KK,IA,JS,HL,HMN,PA,SPW,DMC,DGF,FRJ -
C                   NEW DATE IN BOX IN HONOR OF ZAPT2 GRAD, DET. MRPT,
C                   CCSD DENSITY AND (Q), EFP CHANGES, CIS TRANS.MOM,
C                   SVP SOLVATION, FMO V.2, SYSTEMATIC BASIS SETS
C  1 JUN 05 - CMA,JI - ADD ZAPT2 GRADIENT, DETERMINANT MRPT ENERGY
C 30 APR 05 - DGF - ADD RUNTYP=FMO0, UPDATE SEVERAL FMO METHODS AND GDDI
C 14 MAR 05 - MWS - WFNCIS: DO HF PROPS/DIPOLE INTS BEFORE CIS GRAD
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 13 FEB 05 - MWS - PAD COMMON BLOCK HERMIT, WERMIT, NSHEL, FRGINF
C  5 FEB 05 - MWS - PAD COMMON FMORUN
C 22 NOV 04 - MWS - NEW DATE IN BOX IN HONOR OF QFF-VSCF, ROT.AX. SPDL
C                   AND ERIC AO INTEGRAL CODES, AND QFMM GRADIENT CODE
C  7 SEP 04 - CHC - HFGRAD: ADD LINEAR SCALING GRADIENT OPTION
C 23 JUL 04 - DGF - PRINT RELAXED DENSITY CI PROPERTIES AFTER GRADIENTS
C 23 JUL 04 - MWS - WFNMP2: MCQDPT MUST OPEN AOINTS ON ALL CPUS
C 19 MAY 04 - DGF,RMO - NEW DATE IN BOX IN HONOR OF FMO AND GROUP DDI
C  7 APR 04 - MWS - NEW DATE IN BOX IN HONOR OF SMP-OPTIMIZED DDI,
C                   MCSCF ANALYTIC HESSIANS, TRIPLES CORRECTED EOM-CCSD,
C                   GEPOL-AS PCM GRADIENTS, AND MANY BODY SCF-MI.
C 22 DEC 03 - MWS - WFNMP2: FIX ENERGY ONLY CALCULATIONS
C 12 DEC 03 - MWS - NEW DATE IN BOX IN HONOR OF PARALLEL CIS GRADIENT,
C                   NMR SPECTRA, SPIN-ORBIT WITH MODEL CORE POTENTIALS,
C                   DOUGLAS-KROLL 3RD ORDER, NUMERICAL DERIVATIVES
C  9 DEC 03 - OQ,RMO - EXTENDED TDHF AND NUMERICAL GRADIENT CALLS
C  4 NOV 03 - MWS - DROP NMR STUB ROUTINE
C  3 SEP 03 - SPW - ADD WFNCIS DRIVER FOR CI-SINGLES CODE
C 14 AUG 03 - MWS - IMPROVE ACCURACY OF HERMITE ROOTS/WEIGHTS
C  3 JUL 03 - MWS - NEW DATE IN BOX IN HONOR OF PCM GRAD, PARALLEL UMP2
C 16 JUN 03 - HL  - ENERGX,HFGRAD: PCM GRADIENT CHANGES
C 15 MAY 03 - CMA - WFNMP2: CALLS TO PARALLEL DISTRIBUTED MEMORY
C 26 MAR 03 - MWS - WFNMP2: IGNORE DIRTRF/DIRSCF FOR MCQDPT RUNS
C 28 JAN 03 - MWS - WFNCC: GENERATE C2 INTEGRAL LIST FOR NON-ABEL GROUPS
C 14 JAN 03 - JI  - NEW DATE IN BOX IN HONOR OF ORMAS
C 12 DEC 02 - MWS - GAMESS: INTERFACING TO GVVPT OPTION INCLUDED
C  7 AUG 02 - MWS - REMOVE CHARGE PENETRATION STUBS
C 20 JUN 02 - MWS - NEW DATE IN BOX IN HONOR OF MSU'S COUPLED CLUSTER
C 22 MAY 02 - MAF - DUMMY INTERFACE TO NMR PROPERTY
C 17 APR 02 - MWS - ADD WFNCC DRIVER
C 16 FEB 02 - CMA,JI - NEW DATE IN BOX IN HONOR OF UMP2 GRAD, DET SOCI
C 24 JAN 02 - CMA - HFGRAD,WFNMP2: CHANGES FOR MP2 GRADIENT
C 21 DEC 01 - MWS - WFN,WFNCI,WFNMP2: SET PSI LEVEL FLAG
C 16 NOV 01 - MWS - WFNMP2: SAVE EMP2 TO /ENRGYS/, PARALLEL MP2PRP
C 25 OCT 01 - MWS - STUB OUT MODEL CORE POTENTIAL CALLS
C 19 SEP 01 - MWS - WFNMP2: NO REGENERATION OF AO INTEGRALS FOR MCQDPT
C  6 SEP 01 - CHC,HU,JI - NEW DATE IN BOX IN HONOR OF QFMM, PARALLEL
C                   MCQDPT, GENERAL DETERMINANT CI, AND JACOBI MCSCF
C  1 AUG 01 - JI  - TWEAKS FOR GENERAL CI
C 25 JUN 01 - DGF - NEW DATE IN BOX IN HONOR OF GRID DFT, SO-MCQDPT,
C                   RESC INTERNAL UNCONTRACTION
C 13 JUN 01 - DGF - GAMESS: STUFF ALL RUNTYP BRANCHING INTO ONE ROUTINE
C 26 APR 01 - JPI - WFNCI: PERMIT GENERAL CI CALL
C 20 FEB 01 - PND - GAMESS: CALL TO MONTE CARLO GLOBAL OPTIMIZER
C 26 OCT 00 - MWS - NEW DATA IN BOX IN HONOR OF SYMMETRY DETERMINANT CI,
C                   NEW PCM, EFP+PCM INTERFACE, AND RAMAN DEVELOPMENTS
C 11 OCT 00 - BM  - ADDED IEF SOLVATION MODEL
C 28 JUL 00 - MWS - ADD NEW ARG TO CALL TO INIDEN
C 11 JUN 00 - MWS - GEN C1 INT LIST FOR NON-ABEL MCSCF (FIX DEC 99 BUG)
C  1 MAY 00 - MWS - CALL RAMAN DRIVER
C 10 APR 00 - MWS - REMOVE STATIC MEMORY FROM COSMO COMMONS
C 25 MAR 00 - MWS - NEW DATE IN BOX IN HONOR OF VSCF, ESC GRADIENTS,
C                   COVALENT EFP, COSMO, GRID-FREE DFT
C 13 MAR 00 - KKB/LNB - WFNMP2: ADD COSMO
C 16 FEB 00 - VK  - GAMESS,ORTHDN: CHANGES DUE TO MO TRUNCATION/FREEZING
C 10 JAN 00 - MWS - GAMESS: NEW DATE IN BOX IN HONOR OF GENERAL SPIN
C                   ORBIT COUPLING, RESC AND NESC, AND MCQDPT WEIGHTS
C 29 DEC 99 - MWS - WFNMP2: CORRECTLY LABEL SCF VS. MP2 PROPS
C 21 DEC 99 - DGF - INIDEN: ADD ORB. PURIF. ARG, REMOVE RUNTYP=SPINORBT
C 29 AUG 99 - CHC - QMMM MMONLY KEYWORDS IN $CONTROL BY JRS
C 10 JUN 99 - MWS - WFNMP2: FIX DDI/NONDDI INTEGRAL REGENERATION
C  6 JUN 99 - MWS - NEW DATE IN BOX IN HONOR OF PARALLEL MP2 GRADIENT,
C                   OPEN SHELL ZAPT MP2, AND SPHERICAL HARMONICS
C  9 APR 99 - MWS - WFNMP2: CALL THE NEW MP2 CODE
C 13 MAR 99 - KRG - ENERGX: ADD CALL TO DFT INTEGRALS
C  1 DEC 98 - MWS - NEW DATE IN BOX IN HONOR OF ECP HESS AND DLC COORDS
C 12 NOV 98 - MAF - WFNMP2: ALLOW FOR USE OF SPHERICAL HARMONICS
C  6 MAY 98 - MWS - NEW DATE IN BOX IN HONOR OF DETERMINANT FULL CI
C  6 JAN 98 - DGF - NEW DATE IN BOX IN HONOR OF GENERAL SOC ACTIVE SPACE
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 14 AUG 97 - MWS - GRADX: RESTORE MISSING CALL TO PUVIB
C 24 JUL 97 - MWS - WFNCI: FIX IREST/LREST CONFUSION
C 16 JUL 97 - GNM - ENERGX,GRADX: CHANGES FOR FRAGONLY RUNS
C 18 MAR 97 - MWS - NEW DATE IN BOX IN HONOR OF PCM CODE
C 22 FEB 97 - MWS - GAMESS,ENERGX,HFGRAD: CALLS TO PCM CODE
C 19 FEB 97 - MWS - WFN: SAVE ELECTRONIC ENERGY OF MCSCF FUNCTIONS
C 14 FEB 97 - MWS - ENERGX,WFNCI: POSTPONE 2E- INTS FOR STRAIGHT CI
C  8 JAN 97 - GMC - WFN: CALL TO FULL QUADRATIC MCSCF
C 18 DEC 96 - JHJ - GAMESS: MAKEFP RUNTYP ADDED
C 26 NOV 96 - SPW - GAMESS: ALLOW FROZEN CORE CI GRADIENTS
C 31 OCT 96 - MWS - NEW DATE IN BOX IN HONOR OF MCQDPT AND CI GRADIENT
C 23 OCT 96 - HN  - ENERGZ,WFN,WFNMP2: CHANGES FOR MCSCF+MP2
C 17 OCT 96 - SPW - ENERGX,GRADX,WFNCI: CHANGE FOR CI GRADS; ADD CIGRAD
C 29 SEP 96 - MWS - GRADX USES STANDARD ROUTINE PUVIB
C 11 SEP 96 - MWS - NEW DATE IN BOX IN HONOR OF EFP CODE, FINALLY.
C 13 AUG 96 - MWS - WFN,WFNCI: FIX SCFTYP=NONE OPTION
C 11 JUL 96 - MWS - BRING WFNMP2 ROUTINE TO THIS FILE
C 22 JUN 96 - SPW,GMC - NEW DATE IN BOX IN HONOR OF FROZEN CORE MP2
C                   GRADIENT AND APPROXIMATE SOSCF MCSCF
C 13 JUN 96 - VAG - WRITE WFN ROUTINE TO REPLACE WFN,SCF,MCCI MESS
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C  9 JAN 95 - WC  - CHANGE CALL TO INIDEN
C  3 JAN 96 - MWS - USE NEW ONE ELECTRON INTEGRAL DRIVER
C 20 NOV 95 - SPW,FRJ - NEW DATE IN BOX IN HONOR OF MP2 GRADIENT AND
C                   GRADIENT EXTREMALS
C  9 OCT 95 - SPW - GAMESS,HFGRAD: PERMIT MP2 GRADIENT COMPUTATION
C 14 SEP 95 - SPW - GAMESS: ONLY MCSCF RUNS NEED TO READ LOCAL INPUT
C 16 AUG 95 - MWS - ENSURE THAT MP2 IS NOT CHOSEN FOR NEW RUN TYPES
C 26 JUL 95 - MWS - NEW DATE IN BOX IN HONOR OF UHF/ROHF/GVB SOSCF
C 24 MAY 95 - MWS - ENERGX: ALLOW DISTRIBUTED AO INTS DURING CI/MCSCF
C 10 MAR 95 - GMC,MWS - NEW DATE IN BOX IN HONOR OF SOSCF
C  1 FEB 95 - WC,RM: NEW DATE IN BOX IN HONOR OF MOROKUMA AND SURFACE
C 24 JAN 95 - MWS - WFNCI: USE C1 DURING NON-ABELIAN TRANSFORMATIONS
C 17 NOV 94 - TT  - NEW DATE IN BOX IN HONOR OF DRC RUN TYPE
C 11 AUG 94 - HAK - NEW DATE IN BOX IN HONOR OF TDHF NLO PROPERTIES
C 22 JUL 94 - BMB,JHJ - NEW DATE IN BOX IN HONOR OF FAST SPDFG GRADIENT,
C                   AND IN HONOR OF LOCALIZED CHARGE DECOMPOSITION
C  6 JUN 94 - MWS - NEW DATE IN BOX IN HONOR OF PARALLEL CI, HESSIANS,
C                   LOCALIZATION, USING PARALLEL TRANS.SRC
C  1 JUN 94 - MWS - ENERGX,WFNCI: ADAPT TO PARALLEL CI
C 27 MAY 94 - SPW - GRADX: FIX FOR FRAGMENT GRADIENTS
C  5 APR 94 - NM,SPW - NEW DATE IN BOX IN HONOR OF SCRF AND NEW MP2
C 10 MAR 94 - FRJ - ENERGX: RESTRICT VTSCAL CHANGES
C 25 JAN 94 - MWS - NEW DATE IN BOX IN HONOR OF PARALLEL MCSCF,
C                   ENERGX: MCSCF INTEGRALS IN C1 IF NON-ABELIAN GRP
C 13 DEC 93 - TLW - ENERGX: MCSCF RUNS USE SYMMETRY FOR INTEGRALS
C  3 NOV 93 - MH  - GAMESS: ADD HOOKS TO CHARMM PACKAGE
C  2 NOV 93 - MWS - ADD GAMESS PAPER REFERENCE TO THE BOX
C 17 JUL 93 - MWS - NEW DATE IN BOX IN HONOR OF LANTHANIDES
C 11 MAR 93 - FJ  - ADD VIRIAL SCALING
C  4 MAR 93 - JHJ - NEW DATE IN BOX IN HONOR OF SCRF OPTION
C 26 JAN 93 - MWS - COMMENT OUT PTIMIT TO REMOVE SND/RCV CALLS
C 11 DEC 92 - MWS - CHANGE ARG LIST FOR HESSX
C 13 NOV 92 - NM,SJS,TLW - NEW DATE IN BOX IN HONOR OF ROHF-MP2,
C                   SCHLEGEL IRC, SEMI-PARALLEL HESSIAN CALCULATION
C 10 NOV 92 - MK  - ADD CALL TO ZEALOT INTERFACE, CHANGE /INTRFC/
C 22 JUN 92 - MWS - ADD 2ND ARG TO GUESMO CALLS
C 28 APR 92 - MWS - INCLUDE FINITE FIELD CALC OF POLARIZABILITY
C  2 APR 92 - MWS,TLW - COMMON ENRGYS MADE PURE FLOATING POINT
C 18 MAR 92 - TLW,JHJ,MWS - NEW DATE IN BOX IN HONOR OF PARALLEL
C                   SCF ENERGY AND GRADIENT, MOPAC WITHIN GAMESS,
C                   AND MICHEL'S SYMMETRY CODE
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C  9 MAR 92 - JHJ - HFGRAD,ORTHDN: CHANGES FOR MOPAC INTERFACE
C  2 MAR 92 - MWS - ORTHDN: USE QMTSYM, SAVE -Q- ON DAF EARLY IN RUN
C 29 JAN 92 - TLW - GAMESS: PARALLEL STUFF MOVED TO BEGING AND ENDING
C 25 JAN 92 - MWS - GAMESS,ENERGX: GUESMO TAKES ONLY 1 ARGUMENT
C 10 JAN 92 - TLW - CHANGE REWIND TO CALL SEQREW
C 10 JAN 92 - MWS,TLW - MAKE OPENIP, OPENIR AND OPENIW TO SEQOPN
C  4 JAN 92 - TLW - MAKE WRITES PARALLEL; ADD COMMON PAR
C  5 DEC 91 - MWS - GAMESS: CALL LMOINP AFTER CALL TO DRTGEN.
C  3 DEC 91 - TLW - ENERGX: ALLOW F AND G PROPERTIES TO BE CALCULATED
C 11 NOV 91 - NM,JHJ - NEW DATE IN BOX IN HONOR OF UMP2 + EFP INTERFACE
C 31 OCT 91 - JHJ - MCCI: WRITE COMMON ENRGYS TO DAF 2.
C 28 OCT 91 - JHJ - MCCI: ITERATE INDUCED DIPOLES FOR MCSCF/CI.
C 18 OCT 91 - TLW,MWS - NEW DATE IN BOX IN HONOR OF SPDFG INTEGRALS,
C                   AND DIRECT SCF.
C 20 AUG 91 - MWS - NEW DATE IN BOX IN HONOR OF RHF-DEM, POPULATION
C                   LOCALIZATION, AND PROJECTED HUCKEL GUESS.
C 10 AUG 91 - MWS - GAMESS: GENERATE DRT EARLY IN THE RUN
C  9 AUG 91 - TLW - ENERGX: STOP CALCULATION AFTER ENERGY IF F AND G
C                   FUNCTIONS ARE INPUT
C  2 JUL 91 - MWS - ORTHDN: CHANGE USAGE OF ORTHO ROUTINE
C 24 JUN 91 - MWS - ENERGX: DON'T TURN SYMMETRY OFF FOR GVB RUNS
C 13 JUN 91 - MWS - NEW DATE IN BOX IN HONOR OF SBK BASIS SETS
C  8 APR 91 - MWS - CHANGE CALLS TO GUESMO.
C  4 APR 91 - MWS - NEW DATE IN BOX IN HONOR OF ENERGY LOCALIZATION,
C                   PROP RUNS ALWAYS GENERATE DISTINCT ROW TABLE.
C  1 MAR 91 - MWS - CHANGE CALL TO HESSX
C 23 JAN 91 - JAB - GRADX DRIVER NOW CALLS EGPUN.
C 12 NOV 90 - MWS - NEW DATE IN BOX IN HONOR OF COORD=ZMT INPUT
C 10 OCT 90 - MWS - NEW DATE IN BOX IN HONOR OF OUT OF CORE CPHF.
C                   PUNCH OF MOLPLT AND PLTORB FILES AT END OF JOB.
C 15 AUG 90 - TLW - ADD 7 ELEMENTS TO COMMONS HERMIT AND WERMIT AND
C                   INITIALIZED THEM.
C 30 JUL 90 - MWS - NEW DATE IN BOX IN HONOR OF OS-TCSCF HESSIANS,
C                   INTERFACE TO RPAC (AND AIMPAC) IN MAIN PROGRAM
C  5 JUN 90 - MWS - NEW DATE IN BOX IN HONOR OF FREE FORMAT $DATA,
C                   AND TRUDGE OPTIMIZATION OF CI ENERGY
C 16 APR 90 - MK  - ADD WFNCI AS SEPARATE CI CALCULATION DRIVER
C 30 MAR 90 -MK,SK- NEW DATE IN BOX IN HONOR OF TRUDGE OPTIMIZATIONS,
C                   AND ONE ELECTRON SPIN-ORBIT COUPLING
C  8 MAR 90 - MWS - NEW DATE IN BOX IN HONOR OF GRAPHICS
C  7 JAN 90 - MWS - NEW DATE IN BOX IN HONOR OF FREE FORMAT DRT INPUT
C  9 DEC 89 - MWS - GRADX: CORRECT NUCLEAR CHARGE FOR ECP CASE
C  6 DEC 89 - MWS - NEW DATE IN BOX IN HONOR OF ROHF HESSIANS AND ECPS
C 23 OCT 89 - MWS - DELETE COMMON FUNCT SAVES
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO COMMON CIFILS
C  5 AUG 89 - MWS - NEW DATE IN BOX (A BUG FIX, NEW HARDWARE RELEASE),
C                   TIMIT FLUSHES OUTPUT BUFFER FOR IW,IP,
C                   MOVE UNPORTABLE CODE INTO NEW MODULE UNPORT
C 28 MAR 89 - MWS - GRADX: ALLOW EXETYP=CHECK TO FEEL OUT GRADIENT.
C 16 MAR 89 - MWS - GRADX: PRINT FINAL TIME MESSAGE
C  6 MAR 89 - MWS - HFGRAD: TRF2DM CALL MOVED TO DDEBUT
C 25 FEB 89 - MWS - ADD FLSHBF ROUTINE, /IOFILE/ TO HFGRAD
C  7 FEB 89 - MWS - CHANGE INIDEN CALL
C  1 FEB 89 - MWS - NEW DATE IN BOX IN HONOR OF MP2 AND ORBITAL
C                   SYMMETRY LABELS, CHANGE OPENCI CALL IN HFGRAD,
C                   INCREASE DYNAMIC MEMORY FROM 500,000 TO 750,000.
C 18 JAN 89 - MWS - NEW DATE IN BOX IN HONOR OF MICHEL'S ANALYTIC
C                   RHF HESSIAN CODE, WHICH WAS ADAPTED FROM HONDO7,
C                   CHANGE RUNTYP=FORCE TO RUNTYP=HESSIAN
C 15 DEC 88 - MWS - CHANGE CALL TO TRNSF
C 30 NOV 88 - JAM - ADD *ALL LINES TO SUPPORT ALLIANT MACHINES
C 15 NOV 88 - KF  - CHANGE ETA TIMING
C 13 OCT 88 - MWS - NEW DATE IN BOX IN HONOR OF MICHEL'S MCSCF CODE,
C                   MCCI: REMOVE MOST $CIINP, CHANGE MCSCF,TRNSF CALLS
C 27 AUG 88 - MWS - NEW DATE IN BOX FOR VIBANL,BAKER,IRC,BIG DIMS
C 17 AUG 88 - MWS - DON'T ATTEMPT CRAY TRACEBACK IN ABRT ANYMORE
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 10 JUL 88 - MWS - NEW DATE IN BOX IN HONOR OF NEW GVB DIIS CODE
C 30 JUN 88 - MWS - FULL *OS2 AND *CVX (CONVEX) VERSIONS.
C 21 JUN 88 - JAB - PUNCH $GRAD AND $VIB GROUPS FOR RUNTYP=GRADIENT
C 19 JUN 88 - MWS - GENERATE MO GUESS FOR RUNTYP=PROP JOBS
C  4 JUN 88 - MWS - NEW DATE IN BOX IN HONOR OF NEW GRADIENT LOGIC
C 30 MAY 88 - MWS - ROUTINE HFGRAD CALLS JKDER ONLY, NO MORE SPCHK
C                   USE PARAMETER TO DIMENSION COMMON
C 23 MAY 88 - MWS - NEW DATE IN BOX IN HONOR OF NEW INTEGRAL LOGIC
C  8 MAY 88 - MWS - UP AO-S FROM 255 TO 2047
C  4 MAY 88 - MWS - ADD OS/2 TIMING CODE (AS *OS2 LINES)
C 22 APR 88 - MWS - REMOVE NCONF ARG TO INIDEN, USE /GVBWFN/ IN ENERGX
C 18 APR 88 - MWS - NEW DATE IN BOX IN HONOR OF NEW SCF CODE
C  7 APR 88 - MWS - IBM VERSION TO 2,000,000 WORDS.
C  2 APR 88 - MWS - DELETE ROUTINE TIMREM, IT'S NO LONGER USED,
C                   PUT INITAL ORBITAL GUESS AFTER 1E- INTEGRALS.
C 29 FEB 88 - STE - MCCI: RNAM>>DRTINP(1)
C 19 FEB 88 - MWS - ADD RUNTYP=SPINORBT/TRANSITN, CHANGE DRTGEN CALL,
C                   READ INPUT FOR FROZEN ORB. MCSCF, NEW DATE IN BOX
C  3 DEC 87 - STE - NEW DATE IN BOX
C 19 NOV 87 - STE - PUT EXETYP IN COMMON RUNOPT; SAVE COMMON FUNCT
C  5 OCT 87 - MWS - CHANGE UNIX CPU TIMING MECHANISM
C 10 AUG 87 - MWS - INCLUDE ETA VERSION, NEW DATE IN BOX
C  1 JUL 87 - STE - MCCI: SAVE NRNFG,NPFLG FOR OVERLAY
C 20 MAY 87 - MWS - PERIODIC FLUSH OF CELERITY OUTPUT, FIX ABRT TIMSTR,
C                   USE XUFLOW INSTEAD OF ASSEMBLER ZUNDFL FOR IBM.
C 10 MAY 87 - STE - ABRT: PRINT FINAL TIMING INFO;  NEW DATE IN BOX
C  4 MAY 87 - STE - ORTHDN: INIDEN,ORTHO NO LONGER USE IA/IWRK IN QMATRX
C 12 FEB 87 - MWS - DELETE MSWRIT CALL IN ENERGX
C 30 NOV 86 - STE - CTSS: MATHLIB ROUTINE FOR TRACEBACK,  NEW DATE
C 18 NOV 86 - MWS - CTSS: CORRECT SPELLING OF MSGFRR
C  4 NOV 86 - STE - ROHF BUG FIXED, FPS VERSION CHECKED,  NEW DATE
C 15 OCT 86 - MWS - FIX CRAY TIMING, ADD DROPFILE, NEW DATE IN BOX,
C                   ADD CRAY/CTSS SPECIFIC CALLS TO GAMESS,
C                   REMOVE EXTRA ARGUMENT FROM MSWRIT CALL IN ENERGX
C 12 SEP 86 - MWS - ADD CELERITY TRACEBACK INSTRUCTION PRINTOUT
C 15 AUG 86 - MWS - MOVE SETFM BEHIND MAIN PROGRAM SO TRUE SIZE
C                   OF /FMCOM/ GETS LOADED FIRST, NEW DATE IN BOX.
C 30 JUL 86 - MWS - PAD COMMON ENRGYS
C  9 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS, BRING TMDATE,
C                   TSECND(NEE SECOND),ABRT,MCHPAR FROM IOLIB,
C                   ADD CODE FOR CRAY AND CELERITY VERSIONS.
C 20 JUN 86 - MWS - CHANGE DATE IN BOX, IBM VERSION DESCRIPTION
C  8 JAN 86 - STE - COUNT ENERGY EVALUATIONS, CALL ORTHDN 1X PER E
C 17 DEC 85 - STE - NEW DATE IN BOX; USE NEW TRANSFORMATION ROUTINES
C  4 DEC 85 - STE - HFGRAD: USE TEXIT AFTER CALLS TO JKD...
C 13 NOV 85 - STE - SETFM: USE FPS MEMORY MANAGEMENT ROUTINES
C                   DEFINE ALL LOGICAL UNIT NUMBERS IN MAIN PROG.
C 24 OCT 85 - STE - IMPROVE GRADIENT RESTART (ENERGX,HFGRAD)
C 14 OCT 85 - STE - USE GENERIC SQRT,ABS,MAX
C 10 OCT 85 - STE - ENERGX: ADD /ORDOPT/,/OUTPUT/ TO TURN OFF SYMMETRY
C                   WHEN NOPK=NORDER=1 BUT NOT AN MC OR CI RUN
C 10 SEP 85 - STE - INITIALIZE SOME VARIABLES, CHANGE FPS MEMORY
C 16 JUL 85 - MWS - PRINT FEWER INPUT CARDS, NEW DATE IN BOX
C 10 JUL 85 - MWS - HOLLERITH VERSION SPECIFICATION
C  9 MAR 85 - MWS - MISC CHANGES IN MAIN PROGRAM, NEW DATE IN BOX
C 27 JUL 84 - STE - NEW DATE: REMOVE MUCH REDUNDANT CODE,
C                   IMPROVE RESTART CAPABILITY
C 26 APR 84 - STE - ALLOW CI RESTARTS
C  8 MAR 84 - STE - NEW DATE:FIXES IN GUGDG,SIGMA,ZMATRX
C 26 FEB 84 - STE - PUT NEW DATE IN BOX (NEW GUGDG MODULE)
C  2 FEB 84 - STE - PUT NEW DATE IN BOX
C 17 JAN 84 - STE - HAVE TIMIT PRINT TOTAL REAL TIMES TOO
C 11 JAN 84 - STE - PRINT MAXIMUM MEMORY USED
C 27 DEC 83 - STE - INCLUDE MCCI AND WFN ROUTINES
C 26 DEC 83 - STE - FIX RMS GRADIENT VALUE IN GRADX
C 16 DEC 83 - STE - MOVE OPEN FOR UNITS 8 AND 9 TO START
C 29 NOV 83 - STE - DEFINE LOGICAL UNITS 7,8 AND 9 IN MAIN
C  4 NOV 83 - STE - ADD TIMIT,TIMREM,TEXIT AND SETFM TO MAIN MODULE
C                   MOVE CALL TO SETFM FROM START TO MCHPAR AND RETURN
C                   MEMSIZ TO MCHPAR TO SET LIMFM. PUT ERROR
C                   CONTROL IN MCHPAR WHICH WITH SECOND,TMDATE,ABRT
C                   GO TO IOLIB MODULE. MOVE BLOCK DATA INSIDE MAIN
C  8 JUN 83 - MWS - ADD INTRINSIC REACTION COORDINATE PATHFINDER
C  8 MAY 83 - MWS - RECOMPILED, MOVE IO STUFF TO IOLIB
C  7 MAY 83 - MWS - NEW SINGLE POINT GRADIENT DRIVER, SINCE THE
C                   OLD OPTX WAS TOSSED, MANY ROUTINES MOVED
C                   FROM THIS SEGMENT TO IOLIB, MTHLIB, ETC.
C  8 MAR 83 - MWS - ENERGX CALLS NEW ORTHDN TO ORTHOG OLD MO-S
C                   AND FIND DENSITY ON MULTIPLE GEOMETRY RUNS
C  2 MAR 83 - MWS - DEAD CODE ABORT AND ISOUT2 DELETED
C 22 FEB 83 - MWS - CALL TO ZUNDFL TO PREVENT UNDERFLOW COUNTING
C 18 DEC 82 - MWS - FOR RUNTYP CHECK, CALL TO DRTGEN
C DEC 14 82 - MWS - PRINT CPU MINUTES
C NOV  7 82 - MWS - NEW ROUTINE TMDATE, ELIMINATE ALL TRACES
C                   OF THAT IDIOT TIME FILE
C NOV  4 82 - MWS - DEFINE FILE INSTEAD OF CALL TO ZDFILE
C  3 NOV 82 - MWS - ECHO INPUT CARDS ON PAGE ONE OF OUTPUT
C 30 OCT 82 - MWS - PRINT TIME AND DATE AT JOB START,END
C  5 OCT 82 - MWS - CONVERT FOR IBM
C JUN 30 82 - MWS - KILL TIME SCALE FILE IN -TIMIT-
C 20 JUN 82 - MWS - QUENCH OUTPUT CONVERSION ERROR MESSAGE
C MAR 23 82 - MWS - PUT HSTARX ROUTINES IN THE SCF SECTIONS,
C
C GAMESS CAME ORIGINALLY WITH 400,000 WORDS OF FAST MEMORY
C
C*MODULE GAMESS  *DECK GAMESS
      PROGRAM GAMESS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TIMSTR(3),CARD(10)
C
      LOGICAL AIMPAC,RPAC,PLTORB,MOLPLT
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*40 VERSN
      DOUBLE PRECISION MOROKM
C
      PARAMETER (MXCHRM=1)
C
      COMMON /CHMGMS/ XCHM(MXCHRM),YCHM(MXCHRM),ZCHM(MXCHRM),
     *                DXELMM(MXCHRM),DYELMM(MXCHRM),DZELMM(MXCHRM),
     *                QCHM(MXCHRM),NCHMAT,KCHRMM
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ELGPMT/ NELONG,NATM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /ELGRST/ IRSTRT,I2EA,IGOOD
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMDIM/ MXSP,MXTS,MEMPCM1,MEMPCM2,NTS
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F,NFMOPCM
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA CHECK  /8HCHECK   /
      DATA SURF   /8HSURFACE /,OPTFMO/8HOPTFMO  /,FMO0/8HFMO0    /
      DATA MOROKM /8HMOROKUMA/,GLOBOP /8HGLOBOP  /,ENERGY/8HENERGY  /
      DATA TDHF   /8HTDHF    /,OPTMIZ /8HOPTIMIZE/, SADPT  /8HSADPOINT/
      DATA BNDANA /8HBONDANAL/
C
      DATA FSODCI,GENCI/8HFSOCI   ,8HGENCI   /
      DATA BLANK,RNONE /8H        ,8HNONE    /
C
      CALL BEGING(VERSN)
C
C     ----- CHARMM INTERFACE -----
C     TO USE GAMESS FROM INSIDE OF CHARMM, YOU MUST
C     1. INITIALIZE KCHRMM JUST BELOW TO 1, AND COMMENT OUT NCHMAT=0
C     2. CHANGE "PROGRAM GAMESS" ABOVE TO "SUBROUTINE GAMESS"
C     3. CHANGE THE "STOP" STATEMENT BELOW TO "RETURN"
C     4. DELETE DUMMY SUBROUTINES -CHGMIU- AND -CHMDAT- FROM IOLIB.SRC
C     5. CHANGE -MXCHRM- FROM 1 TO 25120 IN ALL PARAMETER DEFINITIONS
C        FOUND IN GAMESS,GRD1,INPUTB,INPUTC,INT1 MODULES
C
      KCHRMM=0
      NCHMAT=0
C
C     ----- ASSUME THIS IS NOT A NEO RUN -----
C
      NEORUN=0
      NELERM=0
C           ELONGATION FLAG
      IGOOD = 1
C
C        ----- DEFINE LOGICAL UNIT NUMBERS -----
C
      IR = 5
      IW = 6
      IP = 7
      IS = 8
      IPK= 9
      NFT11 = 11
      NFT12 = 12
      NFT13 = 13
      NFT14 = 14
      NFT15 = 15
      NFT16 = 16
      IDAF20= 20
C
C     ----- OPEN THE INPUT, OUTPUT AND PUNCH FILES -----
C
      IF(KCHRMM.EQ.0) THEN
         CALL SEQOPN(IR,'INPUT', 'OLD',.TRUE., 'FORMATTED')
         CALL SEQOPN(IW,'OUTPUT','NEW',.FALSE.,'FORMATTED')
         CALL SEQOPN(IP,'PUNCH', 'NEW',.FALSE.,'FORMATTED')
      ELSE
         CALL CHGMIU(IR,IW)
         CALL SEQOPN(IP,'PUNCH', 'NEW',.FALSE.,'FORMATTED')
      END IF
C
C     ----- PRINT THE GAMESS VERSION BANNER -----
C     ----- START THE CLOCK TICKING -----
C
      IF (MASWRK) THEN
         WRITE(IW,9050) VERSN
         WRITE(IW,9051)
         WRITE(IW,9052)
         CALL DDI_NNODE(NNODE,MYNODE)
         IF (GOPARR) WRITE(IW,9055) NPROC,NNODE
      END IF
      TI=ZERO
      TX=ZERO
      CALL TIMIT(0)
      CALL TMDATE(TIMSTR)
      IF (MASWRK) WRITE(IW,9001) TIMSTR
C
C     ---- ECHO INPUT TO OUTPUT FILE
C
      IF (MASWRK) WRITE(IW,9010)
      CALL SEQREW(IR)
      IF (MASWRK) THEN
         DO 20 I=1,50
            READ(IR,9020,END=30) CARD
            WRITE(IW,9030)       CARD
   20    CONTINUE
   30    CONTINUE
      END IF
C
C        SET UP PRIMITIVE FACTORS FOR ONE-ELECTRON INTEGRALS
C        INITIALIZE FOR THE INTEGRAL QUADRATURES
C
      CALL SETPNRM
      CALL SETRYS
      CALL SETHERMITE
C
C     ----- READ IN BASIS SET AND GET INITIAL MO'S -----
C
      CALL START
C
      CALL VALFM(INITFM)
C
C     ----- MP2 RUNS SHOULD NOT BE TOO EXOTIC -----
C
      IF((RUNTYP.EQ.MOROKM .OR. RUNTYP.EQ.TDHF) .AND.  MPLEVL.GT.0) THEN
         IF (MASWRK) WRITE(IW,9070) RUNTYP
         CALL ABRT
      END IF
C
C                     CHECK IF PARALLEL CI IS ENABLED
      IF((CITYP.EQ.FSODCI .OR. CITYP.EQ.GENCI) .AND.  GOPARR) THEN
         IF(MASWRK) WRITE(IW,9090) CITYP
         CALL ABRT
      END IF
C
      IF (TIM .GE. TIMLIM) THEN
         IF (MASWRK) WRITE(IW,*) 'OUT OF TIME, SEE TIMLIM IN $SYSTEM'
         CALL ABRT
      END IF
C
C     GET MEMORY FOR IN CORE 2E INTEGRALS
C
      CALL INT2EIC(0)
C
C     IF RUNTYP.EQ.'SURFACE ', SCAN POTENTIAL ENERGY SURFACE FOR THE
C     RUNTYP GIVEN IN $SURF.  MOST RUNS CAN PROCEED DIRECTLY TO THE
C     BRANCHING OFF ROUTINE, TO DO THE RUNTYP SELECTED IN $CONTRL.
C
      IF(NFG.NE.0) THEN
C              THE FIRST CALLS READS IN DATA AND DOES E+GRAD
C              FOR ENERGY/GRADIENT RUNS
C              SIGX NEED BE CALLED EXPLICITLY, AS IT CALLS FMOX ITSELF.
         RUNEFP=RUNTYP
         IF (RUNTYP.EQ.GLOBOP) THEN
            RUNTYP  = ENERGY
            CALL FMOX(0)
            RUNTYP = RUNEFP
         ELSE
            IF(RUNTYP.NE.OPTFMO.AND.RUNTYP.NE.FMO0) CALL FMOX(0)
         END IF
C
         IF(RUNTYP.EQ.OPTMIZ.OR.RUNTYP.EQ.SADPT.OR.RUNTYP.EQ.OPTFMO.OR.
     *      RUNTYP.EQ.FMO0.OR.RUNTYP.EQ.GLOBOP) CALL BRNCHX(RUNTYP)
C
C     --- A NUCLEAR/ELECTRONIC ORBITAL RUN HAS ITS OWN BRANCHER ---
C
      ELSE IF(NEORUN.EQ.1) THEN
         CALL NEOCAL(RUNTYP)
      ELSE IF(RUNTYP.EQ.SURF) THEN
         CALL SURFX
      ELSE
         CALL BRNCHX(RUNTYP)
      END IF
C
C     ----- PCM SOLUTION MODEL -----
C     CALCULATE CAVITATION AND/OR DISPERSION-REPULSION ENERGIES
C
      IF(IPCM.EQ.1) THEN
         IF(IFIELD.NE.0) CALL EFIELDM
         IF(ICAV.EQ.1) CALL CAVITM
         IF(IDISP.EQ.1) CALL DISRPM
         CALL SOLPRT
      END IF
C
C        ----- POSSIBLE ORBITAL LOCALIZATION -----
C        ----- POSSIBLE MO TRUNCATION/LOCALIZATION -----
C
      IF(RUNTYP.NE.BNDANA) CALL LMOX
      CALL TRUNC
C
C             ELONGATION METHOD SPECIAL LOCALIZATION
      IF(IGOOD.EQ.0) THEN
         IF(MASWRK) THEN
            WRITE(IW,*) 'SOMETHING WRONG, HALT FURTHER RLMO CALCULATION'
         END IF
         CALL ABRT
      END IF
      IF(NELONG.GE.2.AND.RUNTYP.NE.TDHF) THEN
         IF(MASWRK) WRITE(IW,*) 'STARTING LOCALIZATIONS FOR ELONGATION'
         CALL GULOCL
         IF(MASWRK) WRITE(IW,*)
     *        '....DONE WITH ELONGATION METHOD LOCALIZATION...'
        CALL TIMIT(1)
      END IF
C
C     RETURN MEMORY FOR IN CORE 2E INTEGRALS AND PCM
C     THE CALL ORDER TO INT2EIC(1), RETFM(MEMPCM2) AND RETFM(MEMPCM1)
C     IS IMPORTANT AND MUST BE EXACTLY OPPOSITE TO THE CALLING SEQUENCE.
C
      CALL INT2EIC(1)
      IF(IPCM.NE.0) THEN
        CALL RETFM(MEMPCM2)
        CALL RETFM(MEMPCM1)
        INITFM=INITFM-MEMPCM1-MEMPCM2
C          INITFM AS COMPUTED ABOVE DID NOT KNOW ABOUT PCM MEMORY
C          ALLOCATED IN START
      END IF
C
C        ----- INTERFACES TO OTHER PROGRAMS -----
C     FOR FMO RUNS THE CALLS BELOW WILL GENERATE DATA ONLY FOR THE LAST
C     PIECE COMPUTED (SOME DIMER USUALLY), WHICH NORMALLY DOES NOT MAKE
C     SENSE. NOTE THAT PLTORB DATA IS GENERATED IN MONOSCF FOR CERTAIN
C     OPTIONS AND FOR CERTAIN FRAGMENTS (MONOMERS).
C
      IF(NFG.EQ.0) THEN
         IF(PLTORB) CALL PLTMEM
         IF(MOLPLT) CALL MOLMEM
         IF(AIMPAC  .AND.  EXETYP.NE.CHECK) CALL AIMMEM
         IF(RPAC    .AND.  EXETYP.NE.CHECK) CALL RPACX
         IF(FRIEND.NE.BLANK) CALL ZEALX
      END IF
C             PRINT WARNING AT END OF LOG FILE IF GRID IS SUBSTANDARD.
      IF(DFTYPE.NE.RNONE  .AND.  MASWRK) CALL CHKRGRID
C
C        ----- ALL DONE -----
C
      CALL VALFM(LASTFM)
      IF(LASTFM.NE.INITFM  .AND.  MASWRK) WRITE(IW,9100) LASTFM-INITFM
      CALL BIGFM(MAXMEM)
      CALL TMDATE(TIMSTR)
      IF (MASWRK) WRITE(IW,9002) TIMSTR
      CALL ENDING
      STOP
C
 9001 FORMAT(' EXECUTION OF GAMESS BEGUN ',3A8)
 9002 FORMAT(' EXECUTION OF GAMESS TERMINATED NORMALLY ',3A8)
 9010 FORMAT(/1X,11X,'ECHO OF THE FIRST FEW INPUT CARDS -')
 9020 FORMAT(10A8)
 9030 FORMAT(1X,'INPUT CARD>',10A8)
 9050 FORMAT(10X,54(1H*)/
     *     10X,1H*,9X,'GAMESS VERSION = 11 APR 2008 (R1)',10X,1H*/
     *     10X,1H*,13X,'FROM IOWA STATE UNIVERSITY',13X,1H*/
     *     10X,1H*,1X,
     *  'M.W.SCHMIDT, K.K.BALDRIDGE, J.A.BOATZ, S.T.ELBERT,',1X,1H*/
     *     10X,1H*,3X,
     *  'M.S.GORDON, J.H.JENSEN, S.KOSEKI, N.MATSUNAGA,',3X,1H*/
     *     10X,1H*,10X,
     *  'K.A.NGUYEN, S.J.SU, T.L.WINDUS,',11X,1H*/
     *     10X,1H*,7X,
     *  'TOGETHER WITH M.DUPUIS, J.A.MONTGOMERY',7X,1H*/
     *     10X,1H*,9X,
     *  'J.COMPUT.CHEM.  14, 1347-1363(1993)',8X,1H*/
     *     10X,7(1H*),A40,7(1H*))
 9051 FORMAT(/5X,'SINCE 1993, STUDENTS AND POSTDOCS',
     *     ' WORKING AT IOWA STATE UNIVERSITY'/
     *  5X,'AND ALSO IN THEIR VARIOUS JOBS AFTER LEAVING ISU HAVE MADE',
     *     ' IMPORTANT'/
     *  5X,'CONTRIBUTIONS TO THE CODE:'/
     *  5X,'IVANA ADAMOVIC, CHRISTINE AIKENS, YURI ALEXEEV,',
     *     ' POOJA ARORA, ROB BELL,'/
     *  5X,'PRADIPTA BANDYOPADHYAY, JONATHAN BENTZ, BRETT BODE,',
     *     ' GALINA CHABAN,'/
     *  5X,'WEI CHEN, CHEOL HO CHOI, PAUL DAY, TIM DUDLEY,',
     *     ' DMITRI FEDOROV,'/
     *  5X,'GRAHAM FLETCHER, MARK FREITAG, KURT GLAESEMANN,',
     *     ' DAN KEMP, GRANT MERRILL,'/
     *  5X,'JONATHAN MULLIN, TAKESHI NAGATA, SEAN NEDD,',
     *     ' HEATHER NETZLOFF,'/
     *  5X,'BOSILJKA NJEGIC, RYAN OLSON, MIKE PAK, JIM SHOEMAKER,',
     *     ' LYUDMILA SLIPCHENKO,'/
     *  5X,'SAROM SOK, JIE SONG, TETSUYA TAKETSUGU, SIMON WEBB,',
     *     ' SOOHAENG YOO.')
 9052 FORMAT(/5X,'ADDITIONAL CODE HAS BEEN PROVIDED BY COLLABORATORS',
     *     ' IN OTHER GROUPS:'/
     *  5X,'IOWA STATE UNIVERSITY: JOE IVANIC, KLAUS RUEDENBERG'/
     *  5X,'UNIVERSITY OF TOKYO: KIMIHIKO HIRAO, TAKAHITO NAKAJIMA,'/
     * 10X,'TAKAO TSUNEDA, MUNEAKI KAMIYA, SUSUMU YANAGISAWA,'/
     * 10X,'KIYOSHI YAGI, MAHITO CHIBA, SEIKEN TOKURA, NAOAKI KAWAKAMI'/
     *  5X,'UNIVERSITY OF AARHUS: FRANK JENSEN'/
     *  5X,'UNIVERSITY OF IOWA: VISVALDAS KAIRYS, HUI LI'/
     *  5X,'NATIONAL INST. OF STANDARDS AND TECHNOLOGY: WALT STEVENS,',
     *     ' DAVID GARMER'/
     *  5X,'UNIVERSITY OF PISA: BENEDETTA MENNUCCI, JACOPO TOMASI'/
     *  5X,'UNIVERSITY OF MEMPHIS: HENRY KURTZ, PRAKASHAN KORAMBATH'/
     *  5X,'UNIVERSITY OF ALBERTA: MARIUSZ KLOBUKOWSKI'/
     *  5X,'UNIVERSITY OF NEW ENGLAND: MARK SPACKMAN'/
     *  5X,'MIE UNIVERSITY: HIROAKI UMEDA'/
     *  5X,'MICHIGAN STATE UNIVERSITY:'/
     * 10X,'KAROL KOWALSKI, MARTA WLOCH, JEFFREY R. GOUR,',
     *     ' PIOTR PIECUCH'/
     *  5X,'UNIVERSITY OF SILESIA: MONIKA MUSIAL, STANISLAW KUCHARSKI'/
     *  5X,'FACULTES UNIVERSITAIRES NOTRE-DAME DE LA PAIX:'/
     * 10X,'OLIVIER QUINET, BENOIT CHAMPAGNE'/
     *  5X,'UNIVERSITY OF CALIFORNIA - SANTA BARBARA: BERNARD KIRTMAN'/
     *  5X,'INSTITUTE FOR MOLECULAR SCIENCE:',
     *     ' KAZUYA ISHIMURA AND SHIGERU NAGASE'/,
     *  5X,'UNIVERSITY OF NOTRE DAME: DAN CHIPMAN'/
     *  5X,'KYUSHU UNIVERSITY:'/
     *    10X,'HARUYUKI NAKANO,'/
     *    10X,'FENG LONG GU, JACEK KORCHOWIEC,',
     *     ' MARCIN MAKOWSKI, AND YURIKO AOKI,'/
     *    10X,'HIROTOSHI MORI AND EISAKU MIYOSHI'/
     *  5X,'PENNSYLVANIA STATE UNIVERSITY:'/10X,'TZVETELIN IORDANOV,',
     *     ' CHET SWALINA, JONATHAN SKONE,'/
     * 10X,'SHARON HAMMES-SCHIFFER'/)
 9055 FORMAT(/1X,'PARALLEL VERSION RUNNING ON',I6,' PROCESSORS IN',
     *        I6,' NODES.'/)
 9070 FORMAT(/1X,'***** ERROR ***** GAMESS DOES NOT PERMIT RUNTYP=',
     *       A8,' WITH MP2')
 9090 FORMAT(/1X,'**** ERROR *****'/
     *        1X,'CI PROGRAM CITYP=',A8,' DOES NOT RUN IN PARALLEL.'/
     *        1X,'PARALLEL CI IS $CONTRL CITYP=CIS/ALDET/ORMAS/GUGA.')
 9100 FORMAT(///'* * * * ERROR * * * *'/
     *      1X,'MEMORY LEAK DETECTED.',I10,
     *         ' WORDS ARE STILL ALLOCATED SOMEWHERE'///)
      END
C*MODULE GAMESS  *DECK BRNCHX
      SUBROUTINE BRNCHX(RUNTYP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MOROKM,MD,MAKEFP,NMR,NACME
C
      DATA ENERGY /8HENERGY  /, GRAD   /8HGRADIENT/, HSSIAN /8HHESSIAN /
      DATA PROP   /8HPROP    /, OPTMIZ /8HOPTIMIZE/, SADPT  /8HSADPOINT/
      DATA AIRC   /8HIRC     /, DRC    /8HDRC     /, AMEX   /8HMEX     /
      DATA MOROKM /8HMOROKUMA/, TRNSTN /8HTRANSITN/, TRUDGE /8HTRUDGE  /
      DATA FFIELD /8HFFIELD  /, TDHF   /8HTDHF    /, XTDHF  /8HTDHFX   /
      DATA GRDXTR /8HGRADEXTR/, MAKEFP /8HMAKEFP  /, MD     /8HMD      /
      DATA VSCF   /8HVSCF    /, RAMAN  /8HRAMAN   /, GLOBOP /8HGLOBOP  /
      DATA PIMC   /8HPIMC    /, NMR    /8HNMR     /
      DATA FMO0   /8HFMO0    /, OPTFMO /8HOPTFMO  /, BNDANA /8HBONDANAL/
      DATA NACME  /8HNACME   /, G3MP2  /8HG3MP2   /
C
C     ----- BRANCH ACCORDING TO RUNTYP TO APPROPRIATE DRIVER -----
C
C     IF RUNTYP.EQ.'ENERGY  ', CALCULATE ENERGY
C     IF RUNTYP.EQ.'GRADIENT', CALCULATE ENERGY+GRADIENT
C     IF RUNTYP.EQ.'HESSIAN ', CALCULATE ENERGY+GRADIENT+HESSIAN
C     IF RUNTYP.EQ.'OPTIMIZE', OPTIMIZE MOLECULAR GEOMETRY
C     IF RUNTYP.EQ.'SADPOINT', LOCATE A TRANSITION STATE
C     IF RUNTYP.EQ.'MEX     ', MINIMUM ENERGY CROSSING POINT SEARCH
C     IF RUNTYP.EQ.'TRUDGE  ', NONGRADIENT GEOMETRY/EXPONENT OPTIM.
C     IF RUNTYP.EQ.'GLOBOP  ', RUN MONTE CARLO GLOBAL OPTIMIZATION
C     IF RUNTYP.EQ.'IRC     ', TRACE REACTION PATH
C     IF RUNTYP.EQ.'DRC     ', FOLLOW DYNAMIC REACTION COORDINATE
C     IF RUNTYP.EQ.'GRADEXTR', FOLLOW A GRADIENT EXTREMAL
C     IF RUNTYP.EQ.'MOROKUMA', PERFORM MOROKUMA ANALYSIS
C     IF RUNTYP.EQ.'SPINORBT', COMPUTE SPIN-ORBIT COUPLING
C     IF RUNTYP.EQ.'TRANSITN', COMPUTE TRANSITION MOMENT
C     IF RUNTYP.EQ.'FFIELD  ', COMPUTE POLARIZABILITY
C     IF RUNTYP.EQ.'TDHF    ', FREQUENCY DEPENDENT OPTICAL PROPERTIES
C     IF RUNTYP.EQ.'TDHFX   ', EXTENDED PACKAGE FOR ADDITIONAL
C                              FREQUENCY DEPENDENT OPTICAL PROPERTIES
C     IF RUNTYP.EQ.'RAMAN   ', COMPUTE RAMAN SPECTRUM INTENSITY
C     IF RUNTYP.EQ.'PROP    ', CALCULATE PROPERTIES ONLY
C     IF RUNTYP.EQ.'MAKEFP  ', MAKE AN EFFECTIVE FRAGMENT POTENTIAL
C     IF RUNTYP.EQ.'OPTFMO  ', OPTIMISE MOLECULAR GEOMETRY FOR FMO
C     IF RUNTYP.EQ.'FMO0    ', 0-BODY FMO
C     IF RUNTYP.EQ.'BONDANAL', AUTOMATED BONDING ANALYSIS
C
C     THE RUNTYP OF 'SURFACE' IS HANDLED ELSEWHERE.
C
      IF(RUNTYP.EQ.ENERGY) CALL ENERGX
      IF(RUNTYP.EQ.GRAD  ) CALL GRADX
      IF(RUNTYP.EQ.HSSIAN) CALL HESSX(.FALSE.,.FALSE.)
      IF(RUNTYP.EQ.OPTMIZ) CALL SIGX(.FALSE.)
      IF(RUNTYP.EQ.SADPT ) CALL SIGX(.FALSE.)
      IF(RUNTYP.EQ.AMEX)   CALL MEXNGX
      IF(RUNTYP.EQ.TRUDGE) CALL TRUDGX
      IF(RUNTYP.EQ.GLOBOP) CALL GLOPDR
      IF(RUNTYP.EQ.PIMC)   CALL PIMCX
      IF(RUNTYP.EQ.AIRC  ) CALL IRCX
      IF(RUNTYP.EQ.DRC)    CALL DRCX
      IF(RUNTYP.EQ.MD)     CALL MDX
      IF(RUNTYP.EQ.GRDXTR) CALL GRADEX
      IF(RUNTYP.EQ.VSCF)   CALL VSCFX
      IF(RUNTYP.EQ.MOROKM) CALL MOROX
      IF(RUNTYP.EQ.TRNSTN) CALL TRNMOMX
      IF(RUNTYP.EQ.FFIELD) CALL FFLDX
      IF(RUNTYP.EQ.TDHF)   CALL TDHFX
      IF(RUNTYP.EQ.XTDHF)  CALL TDHFXMAIN
      IF(RUNTYP.EQ.RAMAN)  CALL RAMANX
      IF(RUNTYP.EQ.NMR)    CALL NMRX
      IF(RUNTYP.EQ.PROP  ) THEN
         CALL ONEEI
         CALL GUESMO(GUESS)
         CALL PROPTY('PROP')
      END IF
      IF(RUNTYP.EQ.MAKEFP) CALL EFPX
      IF(RUNTYP.EQ.OPTFMO) CALL OPTFMOX
      IF(RUNTYP.EQ.FMO0)   CALL FMO0X
      IF(RUNTYP.EQ.BNDANA) CALL BNDANX
      IF(RUNTYP.EQ.G3MP2)  CALL G3MP2X
      IF(RUNTYP.EQ.NACME)  CALL NACMEX
C
      RETURN
      END
C*MODULE GAMESS  *DECK ENERGX
      SUBROUTINE ENERGX
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,VTSCAL,VIROK,LVCLN,SVGPAR,
     *        DIRTRF,MMONLY,QMMM,ABEL,ABELPT,LCFLAG,LRINT,LCFLAGS,LRINTS
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXRT=100)
C
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /EFPOTD/ METHOD, INABIO, MOVE
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /FUNCT / E,EG(3*MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MEXOPT/ MEXSKPGES,MEXSTATE
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),MIN(MXSH),MAX(MXSH),NSHELL
      COMMON /ORDOPT/ NORDER,NDAR,LDAR,NBOXMX,NWORD,NOMEM,NSQUAR
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMITR/ RCUT(2),THRES,IPCMIT,IMUL,MXDIIS,NREG,MXITR1,
     *                MXITR2,MODPAP
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F,NFMOPCM
      COMMON /PCMPRT/ GCAVP,GCAVS,GDISP,GREP,EHFGAS
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TINOPT/ MMONLY, QMMM
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      DATA RMC    /8HMCSCF   /
      DATA RNONE  /8HNONE    /
      DATA GUGA   /8HGUGA    /
      DATA ENERGY /8HENERGY  /
      DATA OPTMIZ /8HOPTIMIZE/
      DATA SADPT  /8HSADPOINT/
      DATA AMEX   /8HMEX     /
      DATA GLOBOP /8HGLOBOP  /
      DATA TWO /2.0D+00/, OLDHSS/0.0D+00/, ISCF/0/
      DATA SCALTX/0.0D+00/
C
C     ----- CALCULATE THE ENERGY OF THE MOLECULE -----
C     IREST = 0     NORMAL START AND NORMAL RUNNING CONDITION.
C     IREST = 1     2E-INTEGRAL RESTART ( 1E + MO'S SAVED)
C     IREST = 2     SCF RESTART ( 1E + MO'S SAVED; 2E SAVED)
C     IREST = 5     MP2 RESTART (SKIP SCF, DO ONLY MP2: USED BY FMO-MP2)
C
C     TINKER MM ENERGY CALCULATION
C
      IF ((QMMM .OR. MMONLY) .AND. (RUNTYP .EQ. ENERGY)) THEN
         IF(MASWRK) CALL ANALYZE
         IF(MMONLY) RETURN
      END IF
C
C          OPTION TO SUPPRESS PRINTING DURING MONTE CARLO RUNS
      IF(RUNTYP.EQ.GLOBOP) THEN
         NPRTGO=2
      ELSE
         NPRTGO=1
      END IF
C
      IF(LVCLN) THEN
         ISCF=1
         GO TO 80
      END IF
  50  ISCF=ISCF+1
      E = ETOT
C
C     ----- FRAGMENT ONLY OR POTENTIAL RUN -----
C
      IF(ICOORD .EQ. 4) THEN
         IF (METHOD .GE. 4) THEN
            CALL POTNRG (METHOD)
         ELSE
            CALL EFSP
         END IF
         RETURN
      END IF
C
      LCFLAGS=LCFLAG
      LRINTS=LRINT
      IF(DFTYPE.EQ.RNONE) THEN
        LCFLAG=.FALSE.
        LRINT=.FALSE.
      ENDIF
C
C     ----- 1E- INTEGRALS -----
C
      IF(RUNTYP.NE.AMEX) THEN
         IF(IREST.LE.1) CALL ONEEI
      ELSE
         IF(MEXSTATE.EQ.1) CALL ONEEI
      END IF
      IF(TIM.GE.TIMLIM) GO TO 120
C
C     ----- PREPARE INITIAL ORBITALS -----
C     THIS IS EITHER DOING THE FIRST GUESS, OR ORTHONORMALIZING
C     ORBITALS FROM A PREVIOUS GEOMETRY, MAKING NEW DENSITY MATRIX.
C     NOTE: BOTH CALLS GENERATE THE -Q- MATRIX AT THE CURRENT GEOMETRY.
C
      IF(RUNTYP.NE.AMEX) THEN
         IF(NEVALS.EQ.0) THEN
            CALL GUESMO(GUESS)
         ELSE
            CALL ORTHDN
         END IF
      ELSE
         IF(MEXSKPGES.EQ.1) THEN
            CALL ORTHDN
         ELSE
            CALL GUESMO(GUESS)
         END IF
      END IF
C
C     ----- 1E- INTEGRALS FOR DFT -----
C     THIS REQUIRES ONE KNOW THE ORBITALS, SO AFTER ORBITAL SELECTION
C
      IF (DFTTYP(1) .NE. 0.0D+00) CALL DFTINT
C
C     ----- RESET SYMMETRY IF USER REQUESTED INTEGRAL ORDERING -----
C
      NTSAVE = NT
      IF(NOPK.EQ.1  .AND.  NORDER.EQ.1) NT=1
C
C     ----- 2E- INTEGRALS -----
C
      ABEL = ABELPT()
      SVGPAR = GOPARR
      IF(SCFTYP.EQ.RMC  .AND.  ITRFAO.EQ.1) GOPARR=.FALSE.
      IF(SCFTYP.EQ.RMC  .AND.  .NOT.ABEL) NT=1
      IF(LCFLAG) THEN
          LRINT=.TRUE.
          IF(IREST.LE.1  .AND.  SCFTYP.NE.RNONE) CALL JANDK
          LRINT=.FALSE.
      END IF
      IF(RUNTYP.NE.AMEX) THEN
         IF(IREST.LE.1  .AND.  SCFTYP.NE.RNONE) CALL JANDK
      ELSE
         IF(MEXSTATE.EQ.1) CALL JANDK
      END IF
      GOPARR = SVGPAR
      NT     = NTSAVE
      IF(TIM.GE.TIMLIM) GO TO 120
C
C     --- NEO RUN MAY REQUIRE INTEGRAL AND INITIAL GUESS SET UP ---
C
      IF(NEORUN.EQ.1) THEN
         IF(NEVALS.EQ.0) THEN
            CALL NEOSET(.TRUE.,.TRUE.)
         ELSE
            CALL NEOSET(.TRUE.,.FALSE.)
         END IF
      END IF
C
C     ----- PCM CALCULATION, STEP 1 -----
C           REASON: CAV+DIS+REP CAN BE ADDED TO SCF ENERGY
C
      IF(IPCM.EQ.1) THEN
        NPRTBK=NPRINT
        NPRINT=817
        GCAVP=0.0D+00
        GDISP=0.0D+00
        GREP=0.0D+00
        IF(ICAV.EQ.1) THEN
          CALL CAVITM
          IF(MASWRK)WRITE(IW,*)' '
          IF(MASWRK)WRITE(IW,*)'DONE CAVITATION ENERGY'
          IF(MASWRK)CALL TIMIT(1)
        END IF
        IF(IDISP.EQ.1) THEN
          CALL DISRPM
          IF(MASWRK)WRITE(IW,*)' '
          IF(MASWRK)WRITE(IW,*)
     *      'DONE DISPERSION-REPULSION ENERGY'
          IF(MASWRK)CALL TIMIT(1)
        END IF
        NPRINT=NPRTBK
      END IF
C
C     FOR SINGLE POINT ENERGY JOBS, IT IS BETTER TO DO A GAS PHASE
C     ENERGY AND THEN THE PCM, SO WE HAVE CORRECT SOLVATION ENERGY
C     MODPAP=2 OMITS RUNNING GAS PHASE ENERGY
C
      IF(RUNTYP.EQ.ENERGY.AND.IAND(MODPAP,2).EQ.0.AND.IPCM.EQ.1) IPCM=10
 130  CONTINUE
C
      IF(IPCM.EQ.1) CALL SOLVNT
C
C     ----- CALCULATE WAVEFUNCTION -----
C
      IF(IREST.LE.2.OR.IREST.EQ.5) CALL WFN
      NEVALS = NEVALS + 1
      IF(TIM.GE.TIMLIM) GO TO 120
C
      IF(IPCM.EQ.10) THEN
          EHFGAS = ETOT
          IF(MPLEVL.EQ.2) EHFGAS=EMP2
          IPCM = 1
          GO TO 130
      END IF
C
C     MOST JOBS NOW EXIT FROM THIS ROUTINE
C
      IF(.NOT.VTSCAL) GO TO 120
C
C     ----- OPTIONAL VIRIAL SCALING -----
C
      IF(MPLEVL.GT.0 .OR.  CITYP.NE.RNONE .OR. CCTYP.NE.RNONE
     *               .OR. DFTYPE.NE.RNONE .OR. VBTYP.NE.RNONE) THEN
         IF(MASWRK) WRITE(IW,*) ' VTSCAL IS IMPLEMENTED FOR SCF ONLY'
         CALL ABRT
      END IF
      IF(RUNTYP.NE.OPTMIZ  .AND.  RUNTYP.NE.SADPT
     *                     .AND.  RUNTYP.NE.ENERGY) THEN
         IF(MASWRK) WRITE(IW,9000)
         CALL ABRT
      END IF
      IF((RUNTYP.EQ.OPTMIZ.OR.RUNTYP.EQ.SADPT) .AND.  .NOT.LVCLN) THEN
         IF(MASWRK) WRITE(IW,9010)
         SCALTE=(-EPOT/(TWO*EKIN))**2
         SCALTT = SCALTT*SCALTE
      END IF
      IF(RUNTYP.EQ.ENERGY .OR. LVCLN) THEN
         IF(.NOT.LVCLN  .AND.  MASWRK) WRITE(IW,9020)
         IF(E.EQ.0.0D+00) THEN
            IF(MASWRK) WRITE(IW,9030)
            CALL ABRT
         END IF
         CALL VCLR(EG,1,3*NAT)
         IF(CITYP.EQ.GUGA) THEN
            CALL CIGRAD
         ELSE
            CALL HFGRAD
         END IF
      END IF
C
C     OLDHSS IS USED IF IN A GEOMETRY OPTIMIZATION, THE GEOMETRY
C     CONVERGES, THE VIRIAL IS CLEANED UP FOR FIXED GEOMETRY,
C     AND THE NEW SCALED BASIS THEN CAUSES THE GEOMETRY TO NO
C     LONGER BE CONVERGED. THE GEOMETRY WILL THEN BE CONVERGED,
C     AND ONLY IF THE VIRIAL AGAIN NEED TO BE CLEANED UP DOES
C     OLDHSS COME INTO PLAY. IN THIS CASE IT ESSENTIALLY SAVES
C     ONE GRADIENT CALCULATION BY NOT STARTING AGAIN FROM THE
C     DEFAULT VIRHSS VALUE OF 200.
C
   80 CONTINUE
      IF((VTSCAL .AND. RUNTYP.EQ.ENERGY) .OR. LVCLN) THEN
         IF(ISCF.EQ.1) THEN
            GRD2=0.0D+00
            SCALTE=1.0D+00
            VIRHSS=2.0D+02
            IF(OLDHSS.NE.0.0D+00) VIRHSS=OLDHSS
         END IF
         GRD1=GRD2
         GVIR  = DDOT(3*NAT,C,1,EG,1)
         GRD2 = GVIR +TWO*EKIN+EPOT
         IF(MASWRK) WRITE(IW,9040) GRD2
         IF(ABS(GRD2).LT.VTCONV) GO TO 100
         IF(ISCF.GT.1) VIRHSS=(GRD2-GRD1)/(SCALTE-SCALTX)
C
C        RFO STEP, SAFEGUARD AGAINST NEGATIVE OR SMALL VIRHSS
C
         BILBO = VIRHSS**2 + 4.0D+00*(GRD2**2)
         FRODOP = (VIRHSS + SQRT(BILBO))/2.0D+00
         FRODOM = (VIRHSS - SQRT(BILBO))/2.0D+00
         FRODO = FRODOM
         IF(FRODOP.LT.FRODO) FRODO=FRODOP
         ASTEP = GRD2/(FRODO-VIRHSS)
C          NEVER ALLOW CHANGES BY MORE THAN 0.05 IN ONE STEP
         IF(ABS(ASTEP).GT.0.05D+00)ASTEP=0.05D+00*ASTEP/ABS(ASTEP)
         SCALTX = SCALTE
         SCALTE = SCALTE+ASTEP
         RATIO = SCALTE*SCALTE/(SCALTX*SCALTX)
         SCALTT = SCALTT*RATIO
         CALL NORMAO(1)
         DO 90 I=1,MXGTOT
            EX(I)=EX(I)*RATIO
   90    CONTINUE
         IF(MASWRK) WRITE(IW,9050) RATIO,SCALTT
         CALL NORMAO(2)
         IF(ISCF.LT.MAXVT) GO TO 50
            IF(MASWRK) WRITE(IW,9060) MAXVT
            CALL ABRT
  100    CONTINUE
         IF(MASWRK) WRITE(IW,9070) ABS(GRD2),VTCONV
         IF(LVCLN) OLDHSS=VIRHSS
         IF(LVCLN) RETURN
         VTSCAL = .FALSE.
         NPRINT = 7
         CALL ORBKIN
      END IF
C
  120 CONTINUE
      LCFLAG=LCFLAGS
      LRINT=LRINTS
      RETURN
C
 9000 FORMAT(1X,'VIRIAL SCALING ONLY WORKS WITH RUNTYP = ENERGY',
     *        'OPTIMIZE OR SADPOINT')
 9010 FORMAT(/,1X,'VIRIAL SCALING FOR RUNTYP = OPTIMIZE OR SADPOINT')
 9020 FORMAT(/,1X,'VIRIAL SCALING FOR RUNTYP = ENERGY')
 9030 FORMAT(1X,'SCF HAS APPARENTLY NOT CONVERGED')
 9040 FORMAT(/,1X,'CURRENT VIRIAL ERROR =',F12.8)
 9050 FORMAT(/,1X,'SCALING EXPONENTS BY',F12.8,' TOTAL SCALING SO FAR',
     *          F12.8)
 9060 FORMAT(1X,'EXCESS NUMBER OF VIRIAL ITERATIONS, MAX GIVEN =',I3)
 9070 FORMAT(1X,'VIRIAL ERROR',F12.8,' IS LESS THAN VTCONV',
     *          F12.8,' CONVERGED')
      END
C*MODULE GAMESS  *DECK CIGRAD
      SUBROUTINE CIGRAD
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF,EFLDL
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFLDC / EVEC(3),EFLDL
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /FUNCT / EHF,EG(3*MXATM)
      COMMON /GRAD  / DE(3,MXATM)
      COMMON /HSSPAR/ FIRST,SECND,CPHF,BOTH,MFIRST,MSECND,MCPHF
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /ZRFPAR/ GZRF,FIND(3),GNUCF,EBORN,DIELEC,IZRF,ICALC
C
      DATA CHECK/8HCHECK   /
C
C     ----- CALCULATE GRADIENT OF THE CI ENERGY -----
C        WITH RESPECT TO THE NUCLEAR COORDINATES
C
C     AT PRESENT, ANALYTIC COMPUTAITON IS POSSIBLE ONLY FOR CITYP=GUGA.
C
C     IREST = 3  1E-GRADIENT RESTART(MO'S SAVED; NO GRADIENT SAVED)
C     IREST = 4  2E-GRADIENT RESTART(MO'S SAVED; PARTIAL GRADIENT SAVED)
C
C     ----- NUMERICAL FIRST DERIVATIVES ARE DONE ELSEWHERE -----
C
      IF(NGLEVL.EQ.1) THEN
         CALL NUMGRDX
         RETURN
      END IF
C
      NCOORD = 3*NAT
C
C     ----- OPEN FILE FOR DERIVATIVE FOCK MATRICES -----
C
      NFT18 = 18
      CALL SEQOPN(NFT18,'FOCKDER','UNKNOWN',.FALSE.,'UNFORMATTED')
C
      FIRST=.TRUE.
      MFIRST=.TRUE.
      SECND=.FALSE.
      MSECND=.FALSE.
      BOTH=.FALSE.
      MCPHF=.TRUE.
      CPHF=.TRUE.
C
C     --- CHECK FOR REACTION FIELD OR FRAGMENTS FOR TIMING PURPOSES ---
C
      IPOT=IEFC+IEFD+IEFQ+IEFO+IEFP+IREP
C
C     ---- INITIALIZE GRADIENT TO ZER0 ----
C
      CALL VCLR(DE,1,3*NAT)
      IF(NFRG.GT.0) CALL VCLR(ATORQ,1,3*NFRG)
C
C     ----- 1E- INTEGRAL DERIVATIVE CONTRIBUTIONS TO THE GRADIENT -----
C
      IF (IREST.LE.3) CALL STVDD
      IF (TIM .GE. TIMLIM) RETURN
C
C     ----- 2E- INTEGRAL DERIVATIVE CONTRIBUTIONS TO THE GRADIENT -----
C
      IF (IREST.LE.4) CALL DDERJK
C
C     ---- GET CPHF CONTRIBUTION ----
C
      CALL DAREAD(IDAF,IODA,DE,NCOORD,67,0)
      CALL CPHFX
C
C     ---- MAKE GRADIENT MODIFICATIONS DUE TO ECP, ELEC. FIELD,   ----
C     ---- REACN. FIELD, AND FRAGMENTS IF NEEDED                  ----
C
      IF (IECP.GT.0 .OR. IZRF.GT.0 .OR. IPOT.GT.0 .OR. EFLDL)
     *   CALL CIGRDM
C
      IREST = 0
C
C     --- WAVE FUNCTION PROPERTIES FOR CI RELAXED DENSITY MATRIX ---
C     PROPERTIES FOR EXPECTATION VALUE DENSITY ARE PRINTED IN WFNCI
C
      CALL PROPTY('CI R')
C
      IF(EXETYP.EQ.CHECK) CALL VCLR(DE,1,3*NAT)
      CALL DAWRIT(IDAF,IODA,DE,NCOORD,3,0)
      CALL DCOPY(NCOORD,DE,1,EG,1)
      RETURN
      END
C*MODULE GAMESS  *DECK GRADX
      SUBROUTINE GRADX
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL LINEAR,GOPARR,DSKWRK,MASWRK,FGONLY,LCFLAG,LRINT,LCFLAGS,
     *        LRINTS,GRDOUT
      DOUBLE PRECISION IMS, MD
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO=0.0D+00, GTOL=1.0D-08)
C
      COMMON /EFPOTD/ METHOD,INABIO,MOVE
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3*MXFRG),TORQ(3*MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /FUNCT / E,EG(3*MXATM)
      COMMON /GRAD  / DUMMY(3*MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METMP2,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /XYZPRP/ DUM(3),DIP(3),DUMM(32)
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
C
      DATA CHECK/8HCHECK   /,GUGA/8HGUGA    /,RNONE/8HNONE    /
      DATA IMS/8HIMS     /
      DATA MD/8HMD      /
C
C
C        THIS ROUTINE WRITTEN BY MIKE SCHMIDT, MAY 7, 1983.
C
      FGONLY = NUM.EQ.0  .AND.  NFRG.GT.0
      LCFLAGS=LCFLAG
      LRINTS=LRINT
      IF(DFTYPE.EQ.RNONE) THEN
        LCFLAG=.FALSE.
        LRINT=.FALSE.
      ENDIF
C
      IF (MASWRK.AND.NFG.EQ.0) WRITE(IW,9000)
      IF(NFG.EQ.0.OR.MPLEVL.EQ.0) E=ZERO
      IF (FGONLY) THEN
         IF (METHOD .GE. 4) THEN
            CALL POTNRG(METHOD)
         ELSE
            CALL EFSP
         END IF
      ELSE
         CALL ENERGX
      END IF
      IF(E.EQ.ZERO  .AND.  EXETYP.NE.CHECK) THEN
         IF (MASWRK) WRITE(IW,9010)
         IF(NFG.NE.0) RETURN
         CALL ABRT
      END IF
C
      NCOORD = 3*NAT
      NCF=3*NFRG
      NC1=NCOORD+2*NCF
      IF(MPLEVL.GT.0.AND.CODEMP.EQ.IMS) GO TO 150
      DO 100 I=1,NCOORD
         EG(I)=ZERO
  100 CONTINUE
      IF(CITYP.EQ.GUGA) THEN
         CALL CIGRAD
      ELSE
         IF (FGONLY) THEN
            IF (METHOD .GE. 4) THEN
               CALL POTGRAD
               CALL POTMAX(NFRG,DEFT,TORQ,MAXGRD,RMSGRD)
               RETURN
            ELSE
               CALL EFGRAD
            END IF
         ELSE
            CALL HFGRAD
         END IF
      END IF
C
  150 CONTINUE
      GRMS=ZERO
      GMAX=ZERO
      DO 200 I=1,NCOORD
         GVAL=ABS(EG(I))
         GRMS=GRMS + GVAL*GVAL
         IF(GVAL.GT.GMAX) GMAX=GVAL
         IF(GVAL.LT.GTOL) EG(I)=ZERO
         DUMMY(I)=EG(I)
  200 CONTINUE
      FMAX1 = ZERO
      FMAX2 = ZERO
      IF(NFRG.GT.0) FMAX1 = ABS(DEFT(IDAMAX(NCF,DEFT,1)))
      IF(NFRG.GT.0) FMAX2 = ABS(TORQ(IDAMAX(NCF,TORQ,1)))
      GMAX = MAX(GMAX,FMAX1,FMAX2)
      IF(NFRG.GT.0) GRMS  = GRMS + DDOT(NCF,DEFT,1,DEFT,1)
     *                           + DDOT(NCF,TORQ,1,TORQ,1)
      GRMS=SQRT(GRMS/NC1)
C
C     PRINT AND PUNCH THE FINAL GRADIENT
C
      IF(MASWRK  .AND.  NPRINT.NE.-5) THEN
         IF (.NOT. FGONLY) WRITE(IW,9070)
         IF (.NOT. FGONLY) CALL EGOUT(EG,NAT)
         WRITE(IW,9020) GMAX,GRMS
      END IF
      IF (.NOT. FGONLY.AND.NFG.EQ.0) CALL EGPUN(EG,NAT,' $GRAD  ')
C
C         TRANSFORM GRADIENT TO INTERNAL COORDINATES
C
      IF(NZMAT.GT.0) THEN
         CALL TRANG(DUMMY,NVAR,NCOORD)
         CALL PZANDG(DUMMY,1)
         GRMS=ZERO
         GMAX=ZERO
         DO 300 I=1,NVAR
            GVAL=ABS(DUMMY(I))
            IF(GVAL.LT.GTOL) DUMMY(I)=ZERO
            IF(GVAL.GT.GMAX) GMAX=GVAL
            GRMS=GRMS + GVAL*GVAL
  300    CONTINUE
         GRMS = SQRT(GRMS/NVAR)
         IF (MASWRK) WRITE(IW,9020) GMAX,GRMS
      END IF
C
C     A $VIB GROUP MIGHT BE OF USE IF THIS RUN IS TRYING TO CONVERGE
C     ON SOME GEOMETRY WHICH DIDN'T QUITE CONVERGE IN A RUNTYP=FORCE.
C
      IF(NFG.EQ.0) THEN
         GRDOUT=.FALSE.
         IF(RUNTYP.EQ.MD) GRDOUT=.TRUE.
         CALL PUVIB(IP,IW,GRDOUT,NCOORD,0,0,0,E,EG,DIP)
         IF (MASWRK) WRITE(IP,FMT='('' $END   '')')
      END IF
      LCFLAG=LCFLAGS
      LRINT=LRINTS
C
      IF(MASWRK) WRITE(IW,9030)
      CALL TIMIT(1)
      RETURN
C
 9000 FORMAT(/,20X,32(1H-),
     *       /,20X,'SINGLE POINT ENERGY AND GRADIENT',
     *       /,20X,32(1H-))
 9010 FORMAT(1X,'NO GRADIENT, SCF DID NOT CONVERGE')
 9020 FORMAT(/19X,'MAXIMUM GRADIENT = ',F14.9/
     *        23X,'RMS GRADIENT = ',F14.9)
 9030 FORMAT(/,'..... END OF SINGLE POINT GRADIENT .....')
 9070 FORMAT(/25X,22(1H-)/25X,22HGRADIENT OF THE ENERGY/25X,22(1H-))
      END
C*MODULE GAMESS  *DECK HFGRAD
      SUBROUTINE HFGRAD
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL QOPS,QFMM
C
      PARAMETER (MXATM=2000, MXFRG=1050)
C
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EEPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F,NFMOPCM
      COMMON /PCMTMP/ IDSP(MXATM+MXFRG*5),DPCMFRG(6,MXFRG),
     *                EGPCM(3,MXATM),PCMCDR(3,MXATM)
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /QMFM  / SIZE,EPS,DPGD,QFMM,NP,NS,IWS,NPGP,MPMTHD,NUMRD,
     *                ITERMS,QOPS,ISCUT
C
      DATA NONE,RNONE/4HNONE,8HNONE    /
C
C     ----- FINISH THE NUCLEAR GRADIENT OF THE ENERGY -----
C
C     TO BE MORE PRECISE, IN SPITE OF ITS NAME, THIS ROUTINE DOES
C     THE GRADIENT INTEGRAL CONTRIBUTIONS TO THE GRADIENT VECTOR,
C     INCLUDING CASES SUCH AS MP2, TD-DFT, OR CIS THAT ARE NOT -HF-!
C
C     SOME WAVEFUNCTIONS HAVE TO PRODUCE ENERGY-WEIGHTED DENSITY
C     MATRICES, ETC. PRIOR TO CALLING THIS ROUTINE, WHICH IS
C     RESPONSIBLE ONLY FOR THE FINAL INTEGRAL DERIVATIVE TERMS.
C
C     UNFORTUNATELY, THERE IS A ROGUE PATH FOR GUGA CI THAT IS NOT
C     PROPERLY CAPTURED INTO THIS ROUTINE.  SOMEDAY THAT SHOULD
C     BE CLEANED UP.  ANY PLACE THAT CALLS -HFGRAD- NORMALLY HAS
C     TO HAVE A CLUNKY IF/ELSE/THEN BLOCK CALLING -CIGRAD- AS WELL.
C
C     IREST = 3  1E-GRADIENT RESTART(MO'S SAVED; NO GRADIENT SAVED)
C     IREST = 4  2E-GRADIENT RESTART(MO'S SAVED; PARTIAL GRADIENT SAVED)
C
C     ----- NUMERICAL FIRST DERIVATIVES ARE DONE ELSEWHERE -----
C
      IF(NGLEVL.EQ.1) THEN
         CALL NUMGRDX
         RETURN
      END IF
C
C     ----- MOPAC FIRST DERIVATIVES ARE DONE ELSEWHERE -----
C
      IF(MPCTYP.NE.NONE) THEN
         CALL MPCGRD(SCFTYP)
         RETURN
      END IF
C
C     ----- POLARIZABLE CONTINUUM MODEL GRADIENT CORRECTIONS -----
C           NEED TO CALL DERCCM HERE FOR EFP-PCM GRADIENTS
C           WHICH ARE INVOLVED IN 'STVDER'
C
       IF(IPCM.EQ.1.OR.NFMOPCM.GT.0) THEN
         IF(IPCDER.EQ.2) THEN
           IF(IEF.EQ.3.OR.IEF.EQ.10) CALL DERCCM
         END IF
       END IF
C
C        TD-DFT GRADIENTS CANNOT USE POINT GROUP SYMMETRY
C
      IF(TDDFTYP.NE.RNONE) CALL SYMOFF
C
C     ----- 1E- INTEGRAL DERIVATIVE CONTRIBUTIONS TO THE GRADIENT -----
C
      IF (IREST.LE.3) CALL STVDER
      IF (TIM .GE. TIMLIM) RETURN
C
C     ----- 2E- INTEGRAL DERIVATIVE CONTRIBUTIONS TO THE GRADIENT -----
C
      IF (IREST.LE.4)  THEN
        IF (GOPARR   .AND.   MPLEVL.EQ.2) THEN
          CALL PJKDMP2
        ELSE
          IF (QFMM) THEN
             CALL JKLDER
          ELSE
             CALL JKDER
          END IF
        END IF
      END IF
C
C     ----- POLARIZABLE CONTINUUM MODEL GRADIENT CORRECTIONS -----
C
       IF(IPCM.EQ.1.OR.NFMOPCM.GT.0) THEN
         IF(IPCDER.EQ.2) THEN
           IF(IEF.EQ.3.OR.IEF.EQ.10) THEN
C             -- DERCCM IS CALLED IN VNNDER FOR EFP-PCM(NO QM)
C                DERCCM IS CALLED ABOVE IN OTHER CASES
              DO IAT = 1, NAT
                 DO IXYZ = 1, 3
                    EG(IXYZ,IAT) = EG(IXYZ,IAT) + EGPCM(IXYZ,IAT)
                 END DO
              END DO
           END IF
         ELSE IF(IPCDER.EQ.1) THEN
           IF(IEF.EQ.0) CALL DERPCM
           IF(IEF.EQ.3.OR.IEF.EQ.10) CALL DERIEF
         END IF
       END IF
C
      IF(TDDFTYP.NE.RNONE) CALL SYMON
      IREST = 0
C
C        COMPLETE NUCLEAR/ELECTRON ORBITAL METHOD GRADIENT
C
      IF(NEORUN.EQ.1) CALL NEOGRAD
C
      RETURN
      END
C*MODULE GAMESS  *DECK ORTHDN
      SUBROUTINE ORTHDN
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL MFRZ
C
      DIMENSION SAVDMO(1)
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
      COMMON /FMCOM / XX(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMOOPT/ ESPSCA(9),RESPAP(2),RESPPC(2),RESDIM,RESTRI(4),
     *                RCORSD,RESPCT,CONVFG,CNVDMP,COROFF,IXESP,MXITFG,
     *                NGUESS,NBSSE,MODORB,MODPAR,IRSTSTP,IRSTLAY,NPRFMO,
     *                NFMOPAL,MODPRP,MAXL1C,IPIEDA,MODGRD,MODESP,IVMUL
      COMMON /FMORUN/ ESPSCF,E0SCF(2),IDAFMO,ICURLAY,ICURFG,JCURFG,
     *                KCURFG,NCURSH,NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,
     *                NEEDR,MODRST,NORBPROJ,NUNESP,ISKIPESP,ICURUNT
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA UHF,SAVDMO/8HUHF     ,8HMOSAVED /,RMC/8HMCSCF   /
      DATA NONE/4HNONE/
C
C     ----- ORTHONORMALIZE CURRENT MO-S WITH CURRENT METRIC -----
C     ----- UPDATE THE DENSITY MATRIX ACCORDINGLY -----
C     OLD VECTORS AND NEW OVERLAP MATRIX MUST BE PRESENT ON THE DAF.
C
C        THIS ROUTINE WRITTEN BY MIKE SCHMIDT, MARCH 8,1983.
C
C     ----- MOPAC ORBITALS ARE AUTOMATICALLY ORTHONORMAL -----
C           FMO OFTEN DOES NOT HAVE INITIAL ORBITALS, ONLY DENSITY.
C
      IF(MPCTYP.NE.NONE) RETURN
C
      L0 = 0
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1 * L1
C
C     ----- FIND THE Q MATRIX -----
C
      CALL VALFM(LOADFM)
      LIWRK  = LOADFM + 1
      LS     = LIWRK  + L1
      LQ     = LS     + L2
      LV     = LQ     + L3
      LE     = LV     + L3
      LSCR   = LE     + L1
      LAST   = LSCR   + 8*L1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL DAREAD(IDAF,IODA,XX(LS),L2,12,0)
      CALL QMTSYM(XX(LS),XX(LV),XX(LQ),XX(LE),XX(LSCR),XX(LIWRK),
     *            L0,L1,L2,L3,.FALSE.)
      CALL DAWRIT(IDAF,IODA,XX(LQ),L3,45,0)
C
C     IF DOING FMO, QUIT NOW
C
      IF(NFG.NE.0) THEN
        IF(IFMOSTP.EQ.4.AND.SCFTYP.EQ.RMC) THEN
          IF(MOD(NGUESS/8,2).NE.0) THEN
            CALL DAREAD(IDAF,IODA,XX(LV),L3,15,0)
            CALL PROJGUES(L1,L2,XX(LV),XX(LE),XX(LQ),XX(LS))
            CALL DAWRIT(IDAF,IODA,XX(LV),L3,15,0)
          END IF
        END IF
C       IF(IFMOSTP.EQ.2.AND.NBDFG.NE.0.AND.IAND(NGUESS,64).NE.0)
C    *    CALL PROJGUES(L1,L2,XX(LV),XX(LE),XX(LQ),XX(LS))
        IF(IFMOSTP.NE.4.OR.(SCFTYP.NE.RMC.OR.IAND(NGUESS,1024).EQ.0)
     *                 .AND.IPIEDA.EQ.0) THEN
          CALL RETFM(NEED)
          RETURN
        END IF
      END IF
C
C        ORTHONORMALIZE, AND BACK TRANSFORM
C
      CALL DAREAD(IDAF,IODA,XX(LS),L2,12,0)
      IPASS=1
      NSAV=15
  200 CONTINUE
      CALL DAREAD(IDAF,IODA,XX(LV),L3,NSAV,0)
      NMO=L0
      IF(NFG.NE.0) THEN
C          IRSTLAY IS SET IN EDIM FOR MCSCF,
C          OTHERWISE WE SHOULD NOT GET HERE!
        NMO=IRSTLAY
        IF(SCFTYP.NE.RMC) NMO=NA
      END IF
      CALL ORTHO(XX(LQ),XX(LS),XX(LV),XX(LSCR),NMO,L0,L1,L2,L1)
      CALL TFSQB(XX(LV),XX(LQ),XX(LSCR),L0,L1,L1)
      CALL DAWRIT(IDAF,IODA,XX(LV),L3,NSAV,0)
C
C     IF THE ORBITALS ARE FROZEN, WRITE ALSO TO DICTIONARY FILE 318
C
      IF(MFRZ) CALL DAWRIT(IDAF,IODA,XX(LV),L3,318,0)
C
C        REPEAT FOR BETA ORBITALS FOR UHF FUNCTIONS
C
      IF(SCFTYP.NE.UHF) GO TO 300
      IF(NB.EQ.0) GO TO 300
      IF(IPASS.EQ.2) GO TO 300
      IPASS=2
      NSAV=19
      GO TO 200
C
  300 CONTINUE
      CALL RETFM(NEED)
C
C     ----- INITIALIZE THE DENSITY MATRICES -----
C
      LDA  = LOADFM + 1
      LDB  = LDA    + L2
      LV   = LDB    + L2
      LE   = LV     + L3
      LOCC = LE     + L1
      LAST = LOCC   + L1
      NEED = LAST - LDA - 1
      CALL GETFM(NEED)
      IDUMMY=0
      DUMMY=0.0D+00
      CALL INIDEN(SAVDMO,XX(LV),XX(LDA),XX(LDB),XX(LE),
     *            XX(LOCC),DUMMY,DUMMY,DUMMY,DUMMY,IDUMMY,0,
     *            IDUMMY,IDUMMY,L1,L2,L3,.FALSE.,.FALSE.,.FALSE.,
     *            .FALSE.,.FALSE.,NA,1,L1,L2,L3)
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE GAMESS  *DECK WFN
      SUBROUTINE WFN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MD
      CHARACTER*4 PRPTYP
C
      LOGICAL GOPARR,DSKWRK,MASWRK,POSNEO,POSPRP
C
      PARAMETER (MXATM=2000, MXRT=100)
C
      COMMON /ACONV / RRSHFT,EXTTOL,DMPTOL,VSHTOL,IEXTIN
      COMMON /CONV  / ACURCY,EN,ETOT,EHF,EHF0,DIFF,ITER,ICALP,ICBET
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT2,SZ2,SZZ2,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MRPTIN/ TYPMRMP,INORBMC
      COMMON /NEOMPN/ NEMPLV
      COMMON /NUCPOS/ IUNIQA(20),POSNEO,POSPRP
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /VBINTF/ VBENGY
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00)
C
C     COSMO INFORMATION
C
      PARAMETER (NPPA=1082)
      COMMON /COSMO1/ SE2,SECORR,ETOTS,CDUM,QVCOSMO,
     *                CSPOT(NPPA),ICORR,ITRIPO,ITRIP2,ITRIP3,ITRIP4,
     *                NATCOS,NQS,ITERC
      COMMON /COSMO2/ QENUC,ELAST,EMP2COS,EMP2COS2,ETOTSMP,SAVESE,
     *                EMP2LAST,MP2TRIP,MP2ITER,MP2FACT
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
C
      DATA RMC/8HMCSCF   /
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA CHECK/8HCHECK   /,RNONE/8HNONE    /, MD     /8HMD      /
C
C     ----- DRIVER FOR SELF-CONSISTENT FIELD CALCULATIONS -----
C     WHICH MAY BE FOLLOWED UP BY AN OPTIONAL CORRELATION COMPUTATION
C          IPSI=0 MEANS SCF OR DFT,
C          IPSI=1 MEANS CI,
C          IPSI=2 MEANS MP,
C          IPSI=3 MEANS CC,
C          IPSI=4 MEANS VB
C     COMPUTATION IS CURRENTLY IN PROGRESS.
C
      IPSI=0
      IF(IREST.EQ.5) THEN
        IREST=0
        GO TO 300
      END IF
C     SKIP SCF FOR FMO-MP2
C
C     ----- SET CONVERGENCE CRITERIA FOR SCF -----
C
      IEXTIN = 4
      EXTTOL = 1.0D-03
      DMPTOL = 1.0D-04
      VSHTOL = 0.4D+00
C
C        SET UP S,P,D,F,G TRANSFORMATION MATRICES
C
      CALL TRMAT
C
C     COSMO RESETS ICORR FOR EACH NEW GEOMETRY
C     WORKS BOTH FOR RHF AND MP2 OPTIMIZATION. THE LABEL 100 IS
C     NEEDED TO MAKE THE INNER SCF WITHIN THE MP2 ITERATIONS.
C
      ICORR=0
  100 CONTINUE
C
C         ZERO SOME ENERGIES AND SPINS
C
      E = ZERO
      ETOT = ZERO
      EN=ENUC(NAT,ZAN,C)
      IF(SCFTYP.EQ.RMC) ENUCR=EN
      IF(SCFTYP.EQ.RNONE) ENUCR=EN
      SZ = ZERO
      S2 = ZERO
C
C        IF A CI ON TOP OF AN MCSCF HAS BEEN COMPLETED AT AN EARLIER
C        GEOMETRY, ERASE THE CI COMPUTATION'S EIGENVECTOR FILE TO AVOID
C        CONFUSING THE MCSCF AT THE CURRENT GEOMETRY.
C
      IF(NEVALS.GT.0  .AND.  CITYP.NE.RNONE  .AND.  SCFTYP.EQ.RMC)
     *     CALL ERASCI
C
C        IF A MCSCF+PT RUN HAS VECTORS READ IN, WE CAN SKIP MCSCF
C        CI WITHOUT SCF GENERATING ORBITALS SHOULD SKIP PROPERTIES
C
      IF(SCFTYP.EQ.RMC  .AND.  INORBMC.NE.0) GO TO 300
      IF(SCFTYP.EQ.RNONE) GO TO 300
C
C     ----- EXECUTE SCF PROCEDURE -----
C
      IF (SCFTYP.EQ. RHF) CALL RHFCL
      IF (SCFTYP.EQ. UHF) CALL UHFOP(SZ,S2)
      IF (SCFTYP.EQ.ROHF) CALL UHFOP(SZ,S2)
      IF (SCFTYP.EQ. GVB) CALL RHFGVB
      IF (SCFTYP.EQ. RMC) CALL MCSCF
C
C     ----- SAVE ENERGY DATA FOR SCF -----
C
      IF (SCFTYP.EQ.RMC) ETOT=E
      IF (SCFTYP.EQ.RMC) EHF=EELCT
      E = ETOT
      ENUCR = EN
      EELCT = EHF
      ETOT2 = ETOT
      SZ2   = SZ
      SZZ2  = S2
      ECORE = ZERO
      ESCF  = ETOT
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
C
      IF(RUNTYP.EQ.MD) GO TO 300
C
C     -----  WAVE FUNCTION PROPERTIES AT THE SCF LEVEL -----
C     ----- DENSITY MATRIX PROPERTIES AT THE DFT LEVEL -----
C
                          PRPTYP='SCF '
      IF(DFTYPE.NE.RNONE) PRPTYP='DFT '
      CALL PROPTY(PRPTYP)
C
C        ==== OPTIONAL CORRELATED COMPUTATION FOLLOWING THE SCF ====
C
  300 CONTINUE
C
C     ++++ IN THE DIVERGED CASES BELOW FMO IS ALLOWED TO RETURN BECAUSE
C     ++++ IT MAY RUN THE SAME SCF AGAIN WITH A DIFFERENT CONVERGER.
C
C
C     ----- CARRY OUT OPTIONAL 2ND ORDER PERTURBATION COMPUTATION -----
C
      IF(MPLEVL.GT.0) THEN
         IF(E.EQ.ZERO  .AND.  EXETYP.NE.CHECK  .AND.  INORBMC.EQ.0) THEN
            IF(MASWRK) WRITE(IW,9000) MPLEVL
            IF(NFG.NE.0) RETURN
            CALL ABRT
         END IF
         IF(MPLEVL.EQ.2) CALL WFNMP2
         INORBMC = 0
      END IF
C
C     ----- CARRY OUT OPTIONAL NUCLEAR-ELECTRONIC MP2 (NEO-MP2) -----
C
      IF(NEMPLV.GT.0) THEN
         IF(NEMPLV.EQ.2) THEN
            CALL ENMP2D
            IF (POSNEO.AND.POSPRP) CALL LAMBDAHF
         ELSE
            IF(MASWRK) WRITE(IW,*)'ONLY NEO-MP2 CURRENTLY AVAILABLE'
         END IF
      END IF
C
C        COSMO MP2 ITERATIONS
C
      IF (MP2ITER.EQ.1) GO TO 100
C
C     ----- CARRY OUT OPTIONAL COUPLED CLUSTER COMPUTATION -----
C
      IF(CCTYP.NE.RNONE) THEN
         IF(E.EQ.ZERO  .AND.  EXETYP.NE.CHECK) THEN
            IF(MASWRK) WRITE(IW,9010) CCTYP
            IF(NFG.NE.0) RETURN
            CALL ABRT
         END IF
         CALL WFNCC
      END IF
C
C     ----- CARRY OUT OPTIONAL CI COMPUTATION -----
C
      IF (CITYP.NE.RNONE) THEN
         IF(E.EQ.ZERO  .AND.
     *          .NOT. (EXETYP.EQ.CHECK .OR. SCFTYP.EQ.RNONE)) THEN
            IF(MASWRK) WRITE(IW,9020) CITYP
            IF(NFG.NE.0) RETURN
            CALL ABRT
         END IF
         CALL WFNCI
      END IF
C
C     ----- CARRY OUT OPTIONAL VALENCE BOND COMPUTATION -----
C
      IF(VBTYP.NE.RNONE) THEN
         IF(E.EQ.ZERO  .AND.  EXETYP.NE.CHECK) THEN
            IF(MASWRK) WRITE(IW,9030) VBTYP
            CALL ABRT
         END IF
         IPSI=4
         CALL VBGMS(1)
         E     = VBENGY
         ETOT2 = VBENGY
         CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
         CALL PROPTY('VB  ')
      END IF
C
C     ----- CARRY OUT OPTIONAL TDDFT CALCULATION -----
C
      IF(TDDFTYP.NE.RNONE) THEN
         IF(E.EQ.ZERO  .AND.  EXETYP.NE.CHECK) THEN
            IF(MASWRK) WRITE(IW,9040) TDDFTYP
            IF(NFG.NE.0) RETURN
            CALL ABRT
         END IF
         CALL WFNTDDFT
      END IF
C
C     ----- WRITE ENERGY VALUES TO DISK -----
C     THIS NEEDS TO BE DONE BEFORE CALLING FOR PROPERTIES, SO THAT
C     EVERY PLACE SHOULD HAVE DONE THIS, BUT BE SAFE AND DO IT AGAIN.
C
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
      RETURN
C
 9000 FORMAT(/1X,'SCF DID NOT CONVERGE...NO MPLEVL=',I1,' CALCULATION')
 9010 FORMAT(/1X,'SCF DID NOT CONVERGE...NO CCTYP=',A8,' CALCULATION')
 9020 FORMAT(/1X,'SCF DID NOT CONVERGE...NO CITYP=',A8,' CALCULATION')
 9030 FORMAT(/1X,'SCF DID NOT CONVERGE...NO VBTYP=',A8,' CALCULATION')
 9040 FORMAT(/1X,'SCF DID NOT CONVERGE...NO TDDFT=',A8,' CALCULATION')
      END
C*MODULE GAMESS  *DECK WFNCC
      SUBROUTINE WFNCC
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ABEL,ABELPT,DIRSCF,FDIFF,
     *        EOM,DDITRF,NDINTS,DOCORE
C
      PARAMETER (MXRT=100, MXATM=2000, MXAO=8192)
C
      COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST,IDSKCC
      COMMON /ENRGYS/ VNN,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /EOMPAR/ CVGCI,CVGEOM,GRPEOM,NSTEOM(8),NOACT,NUACT,
     *                MOACTCC(MXAO),MTHTRIP,MTHCI,MTHEOM,MTHINIT,
     *                MAXCI,MAXEOM,MICCI,MICEOM,IROOTCC(2),
     *                IPROPCC,IPROPCCE
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMORUN/ ESPSCF,E0SCF(2),IDAFMO,ICURLAY,ICURFG,JCURFG,
     *                KCURFG,NCURSH,NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,
     *                NEEDR,MODRST,NORBPROJ,NUNESP,ISKIPESP,ICURUNT
      COMMON /FMCOM / XX(1)
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA RHF,ROHF/8HRHF     ,8HROHF    /
      DATA EOMSD,EOMSDT,CRCCL/8HEOM-CCSD,8HCR-EOM  ,8HCR-CCL  /
      DATA CHECK/8HCHECK   /
C
C        ---- DRIVER FOR COUPLED CLUSTER CALCULATION ----
C     IT IS USEFUL TO REMEMBER THAT
C     NCCTOT IS THE TOTAL NUMBER OF MOS.
C     NCCOCC IS THE NUMBER OF OCCUPIED MOS, INCLUDING CORE.
C     NCCFZC IS THE NUMBER OF CORE ORBITALS OMITTED FROM CORRELATION.
C     NCCFZV IS THE NUMBER OF FROZEN EXTERNAL ORBITALS OMITTED.
C
      IPSI=3
      NCCTOT = NQMT
C
C     ADJUST THE NUMBER OF VIRTUAL ORBITALS BY REMOVING REDUNDANT
C     ONES (THOSE PUSHED TO INFINITY WITH PROJECTION OPERATORS).
C
      IF(NFG.NE.0) NCCTOT = NCCTOT - NORBPROJ
C
      IF(MASWRK) THEN
         WRITE(IW,9000) CCTYP,NCCTOT,NCCOCC,NCCFZC,NCCFZV,
     *                  MXCCIT,MXRLEIT,ICCCNV,AMPTSH
         IF(NFG.NE.0.AND.NORBPROJ.NE.0) WRITE(IW,9005) NORBPROJ
         IF(MWRDCC.GT.0) WRITE(IW,9010) MWRDCC
      END IF
C
C     ----- AO BASIS 2E- INTEGRALS -----
C     IF NON-ABELIAN, WE NEED A C1 SYMMETRY AO INTEGRAL LIST,
C     SO THAT THE INTEGRAL TRANSFORMATION WILL RUN CORRECTLY.
C
      ABEL = ABELPT()
      IF(.NOT.DIRSCF  .AND.  .NOT.ABEL) THEN
         IF(MASWRK) WRITE(IW,9020)
         CALL SYMOFF
         CALL JANDK
         CALL SYMON
      END IF
C
C        CARRY OUT A FOUR INDEX TRANSFORMATION OVER ONLY
C        THOSE ORBITALS CORRELATED BY THE CC CALCULATION.
C        IN SERIAL, THIS IS A FULL VVVV TRANSFORMATION.
C        IN PARALLEL, WE DO INTEGRALS FROM OOOO TO VVVO BUT NOT VVVV.
C
      NPRINT= 0
      NCORBS= NCCFZC
      DOCORE=.FALSE.
      IF(GOPARR) THEN
         DDITRF=.TRUE.
         NDINTS=.TRUE.
         NOCCMO= NCCOCC
         NTOTMO= NCCTOT-NCCFZV
      ELSE
         DDITRF=.FALSE.
         NDINTS=.FALSE.
         NOCCMO= NCCTOT-NCCFZV
         NTOTMO= NCCTOT-NCCFZV
      END IF
C
C        PRINT A WARNING IF THERE IS A VERY LARGE COEFFICIENT
C        IN THE VIRTUAL ORBITAL SPACE
      CALL VALFM(LOADFM)
      LVEC = LOADFM+1
      LAST = LVEC + NUM*NUM
      NEED = LAST-LOADFM-1
      CALL GETFM(NEED)
      CALL DAREAD(IDAF,IODA,XX(LVEC),NUM*NUM,15,0)
      MAXC = IDAMAX(NUM*NQMT,XX(LVEC),1)
      BIGGEST = ABS(XX(LVEC-1+MAXC))
      IF(BIGGEST.GT.1.0D+02) THEN
         MAXM = 1 + MAXC/NUM
         MAXA = MAXC - NUM*(MAXM-1)
         IF(MASWRK) WRITE(IW,9100) BIGGEST,MAXA,MAXM
      END IF
      CALL RETFM(NEED)
C
      CALL TRFMCX(NPRINT,NCORBS,NOCCMO,NTOTMO,.FALSE.,.FALSE.,DDITRF,
     *            NDINTS,NDINTS,NDINTS,NDINTS,NDINTS,.FALSE.,DOCORE)
C
C        PERFORM THE COUPLED CLUSTER CALCULATION
C
C        THE VARIABLE -EOM- CAPTURES COMPUTATIONS THAT NEED TO
C        BE DIRECTED TOWARD THE EOM/METHOD OF MOMENTS CODE,
C        WHICH IS NOT ALWAYS AN EXCITED STATE COMPUTATION.
C
      IF(SCFTYP.EQ.RHF) THEN
         EOM = CCTYP.EQ.EOMSD .OR. CCTYP.EQ.EOMSDT .OR. CCTYP.EQ.CRCCL
         IF(MASWRK  .AND.  EOM) WRITE(IW,9040) CCTYP
         CALL   CCDRVR(BESTCC,EOM)
      END IF
C
      IF(SCFTYP.EQ.ROHF) THEN
         EOM = CCTYP.EQ.EOMSD .OR. CCTYP.EQ.EOMSDT
         CALL ROCCDRVR(BESTCC,EOM)
      END IF
C
C        CARRY OUT POSSIBLE CLOSED SHELL EQUATION OF MOTION CALCULATION
C        CCSD (WITHOUT TRIPLES) WAS DONE DURING THE CCDRVR STEP ABOVE,
C        AND THIS GROUND STATE ENERGY SHOULD BE PASSED TO THE EOM-CCSD.
C        THE ENERGY OF ONE OF THE EXCITED STATES, POSSIBLY TRIPLES
C        CORRECTED, WILL BE PASSED BACK TO US TO SAVE AS THE ANSWER.
C
      IF(SCFTYP.EQ.RHF) THEN
         IF(EOM) THEN
            IF(MASWRK) WRITE(IW,9050)
            ECCSD = BESTCC
            CALL EOMDRV(CCTYP,ESCF,ECCSD,BESTEOM)
            BESTCC = BESTEOM
         END IF
C     PROBABLY, FILE CLOSING IN CCFCLO SHOULD BE DONE WITHOUT IFS.
C     EOMDRV USES SOME FILES OPENED IN CCDRVR!!
         IF(NFG.NE.0) CALL CCFCLO(EOM)
      END IF
C
      CALL DERCHK(NDER)
      IF(NDER.GT.0  .AND.  CCTYP.EQ.CRCCL  .AND.  MASWRK) WRITE(IW,9060)
C
      IF(EXETYP.EQ.CHECK) BESTCC=0.0D+00
      E    = BESTCC
      ETOT = BESTCC
      CALL DAWRIT(IDAF,IODA,VNN,MXRT+15,2,0)
C
C        CCPRP/CCPRPE BOTH RESULT IN IPROPCC BEING SET,
C        BUT WE MUST THINK ABOUT G.S. VERSUS ONE PARTICULAR E.S.
C        OPEN SHELL CODE DOES NOT YET PRODUCE A DENSITY MATRIX.
C
      IF(SCFTYP.EQ.ROHF) RETURN
C
      IF(IPROPCC.NE.0) THEN
         IF(IROOTCC(1).EQ.1  .AND.  IROOTCC(2).EQ.0) THEN
            CALL PROPTY('CCSD')
         ELSE
            CALL PROPTY('EOMD')
         END IF
      END IF
      RETURN
C
 9000 FORMAT(/5X,27(1H-)/5X,'COUPLED CLUSTER CALCULATION'/5X,27(1H-)/
     *        1X,'CCTYP                        =',A8/
     *        1X,'TOTAL NUMBER OF MOS          =',I6/
     *        1X,'NUMBER OF OCCUPIED MOS       =',I6/
     *        1X,'NUMBER OF FROZEN CORE MOS    =',I6/
     *        1X,'NUMBER OF FROZEN VIRTUAL MOS =',I6/
     *        1X,'MAXIMUM CC ITERATIONS        =',I6/
     *        1X,'MAXIMUM DIIS ITERATIONS      =',I6/
     *        1X,'CONVERGENCE CRITERION FOR CC =',I6/
     *        1X,'AMPLITUDE ACCURACY THRESHOLD =',1P,E8.1)
 9005 FORMAT(/1X,'NUMBER OF REDUNDANT MOS IN FMO=',I5)
 9010 FORMAT( 1X,'MAXIMUM MEMORY USAGE IN CC   =',I12)
 9020 FORMAT(/1X,'REGENERATING AO INTEGRAL LIST W/O SYMMETRY FOR THE',
     *           ' INTEGRAL TRANSFORMATION.')
 9040 FORMAT(/1X,'CCTYP=',A8,' CALCULATION REQUIRES CONVERGED GROUND',
     *           ' STATE CCSD AMPLTUDES.')
 9050 FORMAT(/1X,'THE GROUND STATE CCSD HAS CONVERGED,',
     *          ' NOW ENTERING THE EOMCCSD PROGRAM TO'/
     *       1X,'CALCULATE EXCITED STATE(S) AND/OR',
     *          ' PROPERTIES AND/OR CR-CC(2,3) ENERGIES...'/)
 9060 FORMAT(/1X,'THE DERIVATIVE COMPUTATION WILL BE DONE WITH THE',
     *           ' TYPE -A- CR-CC(2,3)'/
     *        1X,'ENERGY, WHICH IS INVARIANT TO ROTATIONS OF THE',
     *           ' ORBITALS.')
 9100 FORMAT(/1X,'*** WARNING ***'/
     *        1X,'MAXIMUM LCAO COEF=',F15.6,
     *           ', FOR AO',I6,' IN MO=',I6,' EXCEEDS 100.'/
     *        1X,'ADDITIONAL INPUTS MAY BE REQUIRED TO',
     *           ' OBTAIN GOOD CC ACCURACY:'/
     *        1X,' $CONTRL ICUT=10 OR 11'/
     *        1X,' $SCF    CONV=2.5D-07 FDIFF=.FALSE.'/
     *        1X,'IF CCSD CONVERGENCE TROUBLES ARISE,',
     *           ' CONSIDER USING QMTTOL.')
      END
C*MODULE GAMESS  *DECK WFNCI
      SUBROUTINE WFNCI
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION NEOSCF,NEOCI
C
      PARAMETER (MXATM=2000, MXRT=100)
C
      PARAMETER (NNAM=3)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DIMENSION NRNFG(10),NPFLG(10)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW,SVDIRT,DIRTRF,ABEL,ABELPT,
     *        DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,DOVVVO,DOVVVV,DOCORE
C
      COMMON /CEEIS0/ ICEEIS
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT2,SZ2,SZZ2,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NEOMTD/ NEOSCF,NEOCI
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
C     ----- SET UP NAMELIST SIMULATION -----
C
      DATA CIINP/8HCIINP   /
      DATA QNAM/8HNRNFG   ,8HNPFLG   ,8HIREST   /
      DATA KQNAM/101,101,1/
      DATA NRNFG /1,1,1,1,1,0,0,0,0,0/
      DATA NPFLG /0,0,0,0,0,0,0,0,0,0/
C
      DATA CIDRT/8HCIDRT   /
      DATA RMC  /8HMCSCF   /
      DATA RNONE/8HNONE    /
      DATA OPTMIZ/8HOPTIMIZE/, SADPT/8HSADPOINT/, TRUDGE/8HTRUDGE  /
      DATA ALDET,GENCI,FSOCI/8HALDET   ,8HGENCI   ,8HFSOCI   /
      DATA    ORMAS,CIS,GUGA/8HORMAS   ,8HCIS     ,8HGUGA    /
      DATA FCI/8HFCI     /
C
C     ----- EVALUATE A CI WAVEFUNCTION -----
C
      IPSI=1
C
      SVDSKW = DSKWRK
      DSKWRK = .TRUE.
      NASAVE = NA
      NBSAVE = NB
C
C           CIS HAS ITS OWN DRIVER, DOESN'T USE $CIINP AT ALL
C
      IF(CITYP.EQ.CIS) GO TO 500
C
C     THE CI STEPS TO BE EXECUTED ARE IN -NRNFG-,
C     WITH THE AMOUNT OF PRINTOUT CONTROLLED BY -NPFLG-
C     USE OF -IREST- FOR RESTARTING IN THE MIDDLE IS --NOT-- RECOMMENDED
C
      JRET=0
      IREST=1
C
      CALL NAMEIO(IR,JRET,CIINP,NNAM,QNAM,KQNAM,
     *            NRNFG,NPFLG,IREST,
     *            0,
     *     0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0)
      IF (JRET.GT.1) THEN
         IF (MASWRK) WRITE (IW,9010)
         CALL ABRT
      END IF
C
C     ---- GUGA CI GRADIENT NEEDS LAGRANGIAN AND 2 PARTICLE DENSITY ----
C
      CALL DERCHK(NDER)
      IF(NDER.GT.0) THEN
         NRNFG(6)=1
         NRNFG(7)=1
      END IF
C
C     ----- TURN OFF CI PRINTOUT AFTER 1ST GEOMETRY -----
C     OPTIMIZE,SADPOINT,TRUDGE RUNS SHOULD ALWAYS PRINT CI DIAG
C
      IF (NPRINT.EQ.-5) THEN
         IREST=1
         DO 140 I = 1,10
            NPFLG(I) = -5
  140    CONTINUE
         IF(RUNTYP.EQ.OPTMIZ) NPFLG(4) = 0
         IF(RUNTYP.EQ.SADPT)  NPFLG(4) = 0
         IF(RUNTYP.EQ.TRUDGE) NPFLG(4) = 0
      END IF
C
C     ----- AO BASIS 2E- INTEGRALS -----
C     IF NO PRELIMINARY SCF WAS DONE, WE NEED AN AO INTEGRAL LIST.
C     IF NON-ABELIAN, WE NEED A C1 SYMMETRY AO INTEGRAL LIST.
C     PARALLEL RUNS ONLY NEED TO SET UP THE DDI MO TRANSFORMATION.
C
      SVDIRT=DIRTRF
      IF(GOPARR) DIRTRF=.TRUE.
C
      ABEL = ABELPT()
      IF(SCFTYP.EQ.RNONE .OR.  .NOT.ABEL) THEN
         IF(.NOT.ABEL) CALL SYMOFF
         CALL JANDK
         IF(.NOT.ABEL) CALL SYMON
      END IF
C
C     POSSIBLY CHANGE THE STATE MULTIPLICITY FOR FMO-CI (MONOMERS).
C     DEACTIVATE AND REMOVE LATER.
C
      IF(NFG.NE.0) CALL FMOMUL
C
      DIRTRF=SVDIRT
C
  500 CONTINUE
C
C              ===== EXECUTE THE DESIRED CI PACKAGE =====
C     THE CI COMPUTATION IS EXPECTED TO PRODUCE A DENSITY MATRIX FOR
C     SOME SPECIFIC STATE, AND FALL INTO PROPERTY EVALUATION BELOW.
C
C        CARRY OUT A DETERMINANT OR CSF BASED CI SINGLES COMPUTATION
C           NOTE WELL!  ACHTUNG!  WE RETURN AT ONCE, FOR CIS HANDLES A
C           SINGLE CALL FOR PROPERTIES, EXPECTATION OR RELAXED, ITSELF.
C
      IF(CITYP.EQ.CIS) THEN
         CALL WFNCIS
         RETURN
      END IF
C
C        CARRY OUT A DETERMINANT BASED NEO FULL CI COMPUTATION
C
      IF(NEORUN.EQ.1) THEN
         IF(NEOCI.EQ.FCI) THEN
            CALL NEOFCI(NPFLG,0)
         ELSE
            WRITE(IW,*) 'NEOCI=FCI MUST BE SELECTED IN $NEO'
            CALL ABRT
         END IF
         RETURN
      END IF
C
C        CARRY OUT A DETERMINANT BASED FULL CI COMPUTATION
C
      IF(CITYP.EQ.ALDET) THEN
         IF(MASWRK) WRITE(IW,9110) NRNFG(2),NPFLG(2),
     *         NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6)
         CALL ALDECI(NRNFG,NPFLG)
      END IF
C
C        CARRY OUT A DETERMINANT BASED GENERAL CI COMPUTATION
C
      IF(CITYP.EQ.GENCI) THEN
         IF(MASWRK) WRITE(IW,9120) NRNFG(2),NPFLG(2),
     *         NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6)
         CALL ALGNCI(NRNFG,NPFLG)
      END IF
C
C        CARRY OUT A DETERMINANT BASED FULL SECOND ORDER CI COMPUTATION
C
      IF(CITYP.EQ.FSOCI) THEN
         IF(MASWRK) WRITE(IW,9130) NRNFG(2),NPFLG(2),
     *         NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6)
         CALL FSODCI(NRNFG,NPFLG)
      END IF
C
C        CARRY OUT A DETERMINANT BASED ORMAS CI COMPUTATION
C
      IF(CITYP.EQ.ORMAS) THEN
         IF(MASWRK) WRITE(IW,9140) NRNFG(2),NPFLG(2),
     *         NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6)
         IF (ICEEIS.EQ.0) THEN
           CALL ORDET(NRNFG,NPFLG)
         ELSE IF (ICEEIS.EQ.1) THEN
           CALL CEEIS(NRNFG,NPFLG)
         END IF
      END IF
C
C        CARRY OUT A CSF BASED GUGA CI COMPUTATION
C
      IF(CITYP.EQ.GUGA) THEN
         IF (MASWRK) WRITE (IW,9150) (NRNFG(I),NPFLG(I),I=1,7)
         IF(IREST.LE.0) IREST=1
         GO TO (210,220,230,240,250,260,270), IREST
C
C        ----- CONSTRUCT -DRT- TABLE -----
C
  210    CONTINUE
         DRTNAM = CIDRT
         IF(NRNFG(1).NE.0) CALL DRTGEN(NPFLG(1),DRTNAM)
C
C        ----- TRANSFORM INTEGRALS -----
C
  220    CONTINUE
         DDITRF = GOPARR
                    DOOOOO=.FALSE.
         IF(DDITRF) DOOOOO=.TRUE.
                    DOVOOO=.FALSE.
                    DOVVOO=.FALSE.
                    DOVOVO=.FALSE.
                    DOVVVO=.FALSE.
                    DOVVVV=.FALSE.
                 DOCORE=.TRUE.
         IF(NRNFG(2).NE.0) THEN
             CALL TRFMCX(NPFLG(2),0,0,0,.FALSE.,.TRUE.,
     *                   DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *                   DOVVVO,DOVVVV,DOCORE)
         END IF
C
C        ----- SORT THE TRANSFORMED INTEGRALS FOR -GUGA-CI -----
C
  230    CONTINUE
         IF (NRNFG(3).NE.0) CALL GUGSRT(NPFLG(3),DDITRF)
C
C        ----- CONSTRUCT THE -CI- ENERGY MATRIX -----
C
         IF (NRNFG(3).NE.0) CALL GUGAEM(NPFLG(3))
C
C        ----- FIND ROOT(S) OF THE -CI- ENERGY MATRIX -----
C     IF THE ORBITALS ARE FROM MCSCF, WE NEED TO BLOW AWAY THE
C     MCSCF FUNCTIONS EIGENVECTOR FILE.
C
  240    CONTINUE
         IF (NRNFG(4).NE.0) THEN
            IF(SCFTYP.EQ.RMC) CALL ERASCI
            CALL GUGADG(NPFLG(4))
         END IF
C
C        ----- GET 1-PARTICLE REDUCED DENSITY MATRIX -----
C
  250    CONTINUE
         IF (NRNFG(5).NE.0) CALL GUGADM(NPFLG(5))
C
C        ----- GET 2-PARTICLE REDUCED DENSITY MATRIX -----
C
  260    CONTINUE
         IF (NRNFG(6).NE.0) CALL GUG2DM(NPFLG(6))
C
C        ----- GET LAGRANGIAN MATRIX -----
C
  270    CONTINUE
         IF (NRNFG(7).NE.0) CALL CILGRN(NPFLG(7))
      END IF
C
C        EACH CI PACKAGE SHOULD HAVE PUT ITS ENERGIES INTO /ENRGYS/,
C        BUT WE CAN DO THE WRITE-TO-DISK FOR ALL OF THEM HERE.
C
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
C
C     --- WAVE FUNCTION PROPERTIES FOR CI EXPECTATION VALUE DENSITY ---
C
      CALL PROPTY('CI E')
C
      DSKWRK = SVDSKW
      NA = NASAVE
      NB = NBSAVE
      RETURN
C
 9010 FORMAT(1X,'NAMELIST $CIINP SYNTAX ERROR FOUND.')
 9110 FORMAT(/1X,'DETERMINANT CI OPTIONS   NRNFG   NPFLG'/
     *        1X,'INTEGRAL TRANSFORMATION',I5,3X,I5/
     *        1X,'DIAGONALIZE HAMILTONIAN',I5,3X,I5/
     *        1X,'FORM 1E- DENSITY MATRIX',I5,3X,I5/
     *        1X,'FORM 2E- DENSITY MATRIX',I5,3X,I5)
 9120 FORMAT(/1X,'GENERAL CI OPTIONS       NRNFG   NPFLG'/
     *        1X,'INTEGRAL TRANSFORMATION',I5,3X,I5/
     *        1X,'DIAGONALIZE HAMILTONIAN',I5,3X,I5/
     *        1X,'FORM 1E- DENSITY MATRIX',I5,3X,I5/
     *        1X,'FORM 2E- DENSITY MATRIX',I5,3X,I5)
 9130 FORMAT(/1X,'FULL SECOND-ORDER CI OPTIONS       NRNFG   NPFLG'/
     *        1X,'INTEGRAL TRANSFORMATION',10X,I5,3X,I5/
     *        1X,'DIAGONALIZE HAMILTONIAN',10X,I5,3X,I5/
     *        1X,'FORM 1E- DENSITY MATRIX',10X,I5,3X,I5/
     *        1X,'FORM 2E- DENSITY MATRIX',10X,I5,3X,I5,
     *             ' (UNIMPLEMENTED)')
 9140 FORMAT(/1X,'OCCUPATIONALLY RESTRICTED MULTIPLE ACTIVE SPACE',
     *           ' CI OPTIONS'/
     *        1X,'                                   NRNFG   NPFLG'/
     *        1X,'INTEGRAL TRANSFORMATION',10X,I5,3X,I5/
     *        1X,'DIAGONALIZE HAMILTONIAN',10X,I5,3X,I5/
     *        1X,'FORM 1E- DENSITY MATRIX',10X,I5,3X,I5/
     *        1X,'FORM 2E- DENSITY MATRIX',10X,I5,3X,I5,
     *             ' (UNIMPLEMENTED)')
 9150 FORMAT(/1X,'GUGA CI OPTIONS      NRNFG     NPFLG'/1X,36(1H-)//
     *        1X,'-DRT- TABLE      ',I5,5X,I5/
     *        1X,'TRANSFORMATION   ',I5,5X,I5/
     *        1X,'ENERGY MATRIX    ',I5,5X,I5/
     *        1X,'DIAGONALIZATION  ',I5,5X,I5/
     *        1X,'1E-DENSITY MATRIX',I5,5X,I5/
     *        1X,'2E-DENSITY MATRIX',I5,5X,I5/
     *        1X,'LAGRANGIAN MATRIX',I5,5X,I5)
      END
C*MODULE GAMESS  *DECK WFNCIS
      SUBROUTINE WFNCIS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*4 PRPTYP
C
      LOGICAL PK,PANDK,BLOCK,DIRSCF,FDIFF,GOPARR,DSKWRK,MASWRK,
     *        MNMEDG,MNMEOP,UNVGSS,DGAPRX,RDCISV,DIRTRF,DETRUN,
     *        EXPDEN
C
      PARAMETER (MXATM=2000, MXRT=100)
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /CISPAR/ HAMTYP,DIAGZN,DAVCVG,PRTTOL,NSTATE,ISTATE,MULT,
     &                MXV,NDAVIT,ICISPR,NACORE,NBCORE,NOA,NOB,NORBOC,
     &                NBF,NGSVEC,MNMEDG,MNMEOP,ICLOBBR,UNVGSS,DGAPRX,
     &                RDCISV
      COMMON /CISEN / ECIS
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA RHF,UHF,ROHF /8HRHF     ,8HUHF     ,8HROHF    /
      DATA DETS/8HDETS    /
C
C     SET UP -CIS- RUN: EVALUATE ENERGY, AND IF REQUIRED 1-E GRADIENT
C
      NBF  = NUM
C
C     --- IT SHOULD NOT BE POSSIBLE TO GET HERE WITH A SUPERMATRIX ---
C     BUT CHECK THAT IT IS NOT, JUST TO BE SAFE.
C
      IF(.NOT.DIRSCF  .AND.  PK) THEN
         WRITE(IW,*) 'WFNCIS: ERROR, A -PK- FILE SHOULD NOT BE USED'
         CALL ABRT
      END IF
C
      DIRTRF = .FALSE.
C
C       NOTHING HAS BEEN DONE TO PERMIT IN-CORE CIS. (PERHAPS IT
C       IS NOT VERY NECESSARY ANYWAY, BUT THEN IT WOULD BE GOOD TO
C       GIVE UP IN-CORE INTEGRAL MEMORY FOR INTEGRAL TRANSFORMATION...)
C
      IF(NINTIC.NE.0.AND..NOT.DIRSCF) THEN
        IF(MASWRK) WRITE(IW,*) 'TURNING OFF IN-CORE INTEGRALS...'
        DIRSCF=.TRUE.
      END IF
C
C        --- POSSIBLY READ GUESS CIS VECTOR FROM INPUT ---
C
      IF(RDCISV) THEN
         NOCA  = NOA - NACORE
         NVIRA = NQMT - NOA
         IF(HAMTYP.EQ.DETS) THEN
            DETRUN = .TRUE.
            NCFG = 2*NOCA*NVIRA
         ELSE
            DETRUN = .FALSE.
            NCFG = NOCA*NVIRA
         END IF
         CALL CISVRD(DETRUN,NCFG,NSTATE)
         NGSVEC = NSTATE
         RDCISV = .FALSE.
      END IF
C
C     --- WILL WE GET EXPECTATION OR RELAXED DENSITY BACK FROM CIS?
C
      CALL DERCHK(NDER)
      EXPDEN = NDER.EQ.0  .AND.  ICISPR.EQ.0
C
C     -CISAO- DOES THE ENERGY, POSSIBLY SOME WORK TO GENERATE THE
C     RELAXED/GENERALIZED DENSITY, AND POSSIBLY SOME GRADIENT SET
C     UP.  CIS GRADIENTS WOULD BE COMPLETED IN -GRADX-, IF NEED BE.
C
C     NOTE ALSO THAT THE NORMAL CI DRIVER LEAVES IT UP TO US TO
C     EVALUATE PROPERTIES FOR CIS HERE, SO WE CAN LABEL THE DENSITY
C     MATRIX EXACTLY CORRECTLY.
C
      IF(SCFTYP.EQ.RHF)  THEN
         CALL CISAO
         E    = ECIS
         ETOT = ECIS
         CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
         IF(EXPDEN) THEN
            IF(MASWRK) WRITE(IW,9100)
            CALL TIMIT(1)
            PRPTYP='CISE'
         ELSE
            IF(MASWRK) WRITE(IW,9150)
            CALL TIMIT(1)
            PRPTYP='CISR'
         END IF
         CALL PROPTY(PRPTYP)
      END IF
C
      IF(SCFTYP.EQ.UHF) THEN
         CALL ABRT
      END IF
C
      IF(SCFTYP.EQ.ROHF) THEN
         CALL ABRT
      END IF
C
      RETURN
C
 9100 FORMAT(/1X,'..... DONE WITH CIS ENERGY .....'/)
 9150 FORMAT(/1X,'.... DONE WITH CIS ENERGY + 1-PARTICLE DENSITY ....'/)
      END
C*MODULE GAMESS  *DECK WFNMP2
      SUBROUTINE WFNMP2
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION IMS
      CHARACTER*8 CXBASIS
C
      LOGICAL PK,PANDK,BLOCK,DIRSCF,FDIFF,LMOMP2,ABEL,ABELPT,
     *        GOPARR,DSKWRK,MASWRK,GPSAVE,DIRTRF,
     *        DTRFSV,DSCFSV,DSKWSV,EONLY,DDMP
C
      PARAMETER (MXATM=2000, MXRT=100)
C
      COMMON /CXTHRM/ CXTHERM(11),CXZPE,METHCX,ICXBAS,CXBASIS
      COMMON /ENRGMP/ EMP2,EMP3,EMP4
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / X(1)
      COMMON /FUNCT / E,EG(3,MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2LOC/ LMOMP2
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /MRPTIN/ TYPMRMP,INORBMC
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PKFIL / PK,PANDK,BLOCK
      COMMON /PRPOPT/ ILOCAL
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
C     COSMO INFORMATION
C
      PARAMETER (NPPA=1082)
      LOGICAL ISEPS,USEPS
      COMMON /ISEPS / ISEPS, USEPS
      COMMON /COSMO1/ SE2,SECORR,ETOTS,CDUM,QVCOSMO,
     *                CSPOT(NPPA),ICORR,ITRIPO,ITRIP2,ITRIP3,ITRIP4,
     *                NATCOS,NQS,ITERC
      COMMON /COSMO2/ QENUC,ELAST,EMP2COS,EMP2COS2,ETOTSMP,SAVESE,
     *                EMP2LAST,MP2TRIP,MP2ITER,MP2FACT
C
      LOGICAL IVOCAS
      COMMON /MROPT/ IVOCAS
C
      DATA CHECK/8HCHECK   /
      DATA GRPV /8H $VEC   /
      DATA RHF,UHF,ROHF/8HRHF     ,8HUHF     ,8HROHF    /
      DATA GVB,RMC     /8HGVB     ,8HMCSCF   /
      DATA RMP,ZAPT          /8HRMP     ,8HZAPT    /
      DATA DEMRPT,RMCQD,GVVPT,GMCQDPT
     *    /8HDETMRPT ,8HMCQDPT  ,8HGVVPT   ,8HGMCPT   /
      DATA SERIAL,DDI,IMS/8HSERIAL  ,8HDDI     ,8HIMS     /
      DATA G3MP2/8HG3MP2   /
C
C     ----- DRIVER FOR SECOND ORDER PERTURBATION THEORY -----
C
C     DO ENERGY, DENSITY, AND/OR GRADIENT, IN SERIAL OR PARALLEL,
C     FOR ANY SCFTYP.  NOT ALL METHODS ARE CODED, E.G. GVB HAS NO
C     PERTURBATION THEORY, AND MCSCF HAS NO DENSITY/GRADIENT YET.
C
      IPSI=2
C
      NORB = NQMT
      NBF  = NUM
C
C         POSSIBLE LOCALIZATION FOR ENERGY DECOMPOSITION,
C         AND TURN OFF SO LOCALIZATION ISN'T REPEATED AT JOB END.
C
      IF (LMOMP2) THEN
         CALL LMOX
         ILOCAL=0
      END IF
C
C          SET COSMO MODEL'S MP2 TO LOOK UNCONVERGED ON FIRST PASS
      IF (ISEPS) MP2ITER=1
C
C        AT PRESENT, NO MCSCF+MPLEVL RUN CAN GENERATE A DENSITY MATRIX
C
      IF (SCFTYP.EQ.RMC) MPPROP=0
C
C     --- IT SHOULD NOT BE POSSIBLE TO GET HERE WITH A SUPERMATRIX ---
C     BUT CHECK THAT IT IS NOT, JUST TO BE SAFE.
C
      IF(.NOT.DIRSCF  .AND.  PK) THEN
         WRITE(IW,*) 'WFNMP2: ERROR, A -PK- FILE SHOULD NOT BE USED'
         CALL ABRT
      END IF
C
      IF(NINTIC.NE.0.AND.(.NOT.DIRTRF.OR..NOT.DIRSCF)) THEN
C       ACTUALLY SOME SEQUENTIAL MP2 WORKS WITH IN-CORE (DEPENDING ON
C       AVAILABLE MEMORY).
C       IF(MASWRK) WRITE(IW,*) 'IN-CORE MP2 IS NOT FINISHED YET.'
        IF(MASWRK) WRITE(IW,*) 'TURNING OFF IN-CORE INTEGRALS...'
        DIRSCF=.TRUE.
        DIRTRF=.TRUE.
C---    CALL ABRT
      END IF
C
C     ----- TEST FOR ENERGY ONLY, OR ANALYTIC DERIVATIVE NEEDED -----
C     DENSITY OF FIRST ORDER WAVEFUNCTION IS NEEDED FOR PROPERTIES,
C     AND OBTAINING IT REQUIRES RUNNING PART OF THE GRADIENT CODE.
C
      CALL DERCHK(NDER)
      IF(RUNTYP.EQ.G3MP2) THEN
         IF(ICXBAS.EQ.1) NDER=1
         IF(ICXBAS.EQ.2) NDER=0
      END IF
      EONLY = NDER.EQ.0  .OR.  NGLEVL.EQ.1  .OR.  NHLEVL.EQ.2
      IF(MPPROP.NE.0) EONLY=.FALSE.
C
C     CHECK FOR DISTRIBUTED DATA PARALLEL MP2, AND DDI SUPPORT
C
C        WE HAVE SERIAL CODE FOR RHF + MP2 ENERGY OR GRADIENT
C                                UHF + MP2 ENERGY OR GRADIENT
C                             ROHF + ZAPT2 ENERGY
C                             ROHF +  RMP2 ENERGY
C                            MCSCF + MRPT2 ENERGY
C      WE HAVE PARALLEL CODE FOR RHF + MP2 ENERGY OR GRADIENT
C                                UHF + MP2 ENERGY OR GRADIENT
C                             ROHF + ZAPT2 ENERGY OR GRADIENT
C                             ROHF +  RMP2 ENERGY (REPLICATED MEMORY)
C                            MCSCF + MRMP2 ENERGY
C
      DDMP=.FALSE.
      IF(GOPARR  .AND.
     *  (SCFTYP.EQ.RHF  .OR.  SCFTYP.EQ.UHF  .OR.
     *  (SCFTYP.EQ.ROHF.AND.OSPT.EQ.ZAPT.AND.     EONLY))) DDMP=.TRUE.
      IF(SCFTYP.EQ.ROHF.AND.OSPT.EQ.ZAPT.AND..NOT.EONLY)   DDMP=.TRUE.
C
      CALL DDI_LEVEL(IMPLEMENTATION)
      IF(IMPLEMENTATION.EQ.0  .AND.  DDMP) THEN
         IF(MASWRK) WRITE(IW,*) 'YOUR MACHINE LACKS -DDI- SUPPORT'
         CALL ABRT
      END IF
      IF(DDMP) GO TO 3
C
C        --- APPARENTLY WE ARE RUNNING A SERIAL MP2 PROGRAM ---
C        A C1 INTEGRAL LIST IS NEEDED IF THE GROUP IS NOT ABELIAN
C
C        JAN, 2006:
C           IN PARALLEL, THIS IS USED ONLY BY ROHF/RMP ENERGY RUNS.
C           FOR ANCIENT MP2 PARALLELIZATION:
C           THE INTEGRALS MUST BE REGENERATED IF A DUPLICATED AO
C           INTEGRAL FILE IS BEING USED (OLD PARALLELIZATION)
C
      ABEL = ABELPT()
      IF(.NOT.ABEL  .OR.
     *  (GOPARR .AND. ITRFAO.EQ.1  .AND.  SCFTYP.NE.RMC)) THEN
         IF(.NOT.DIRSCF) THEN
            GPSAVE = GOPARR
            IF(ITRFAO.EQ.1) GOPARR=.FALSE.
            IF(.NOT.ABEL  .AND.  MASWRK) WRITE(IW,9310)
            IF(.NOT.ABEL) CALL SYMOFF
            CALL JANDK
            IF(.NOT.ABEL) CALL SYMON
            GOPARR = GPSAVE
         END IF
      END IF
C
    3 CONTINUE
C
C     ==== CARRY OUT 2ND ORDER PERTURBATION FOR EACH SCF REFERENCE ====
C
C     IF ONLY THE ENERGY W/O DENSITY OR GRADIENT IS DESIRED, THERE
C     MAY BE SPECIALIZED ROUTINES FOR THAT.  ALSO, THE SERIAL CODE MAY
C     BE SEPARATE FROM A (PROBABLY) DISTRIBUTED MEMORY PARALLEL CODE.
C
C     THE CALLS FOR GRADIENT (OR JUST DENSITY MATRIX) SHOULD EVALUATE
C     THE 2ND ORDER ENERGY, DO ENOUGH INTEGRAL TRANSFORMING TO DO
C     RESPONSES, FINISH THE RESPONSES AND GENERATE DENSITY MATRICES,
C     BUT DO NOT INCLUDE NONSEPARABLE DM2 BACKTRANSFORMS OR INTEGRAL
C     DERIVATIVES, WHICH MUST BE DONE LATER.
C
      IF(SCFTYP.EQ.RHF)  THEN
         IF(EONLY) THEN
            IF(IVOCAS) THEN
             CALL MCQDPT(RMCQD,GRPV)
            ELSE
            IF(CODEMP.EQ.DDI)    CALL MP2DDI
            IF(CODEMP.EQ.SERIAL) CALL MP2NRG
            IF(CODEMP.EQ.IMS)    CALL MP2IMS
            ENDIF
C
            IF(MASWRK) WRITE(IW,9100)
            CALL TIMIT(1)
         ELSE
            IF(CODEMP.EQ.DDI) THEN
               CALL MP2DDI
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            END IF
            IF(CODEMP.EQ.SERIAL) THEN
               CALL MP2GE2
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
               IF(.NOT.ISEPS) CALL MP2GRD
            END IF
            IF(CODEMP.EQ.IMS) THEN
               CALL MP2GRDIMS
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            END IF
         END IF
      END IF
C
      IF(SCFTYP.EQ.UHF) THEN
         IF(EONLY) THEN
            IF(CODEMP.EQ.DDI) THEN
               CALL MP2DDI
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            END IF
            IF(CODEMP.EQ.SERIAL) THEN
               CALL UMP2EN
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            END IF
         ELSE
            IF(CODEMP.EQ.SERIAL) THEN
               CALL UMPGE2
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
               IF(.NOT.ISEPS) CALL UMPGRD
            END IF
            IF(CODEMP.EQ.DDI) THEN
               CALL MP2DDI
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            END IF
         END IF
      END IF
C
C     --- SELECT FROM 2 KINDS OF HIGH SPIN, OPEN SHELL PERT. THEORY ---
C
      IF(SCFTYP.EQ.ROHF) THEN
C
C                 THE RMP THEORY LACKS GRADIENTS, AND WE USE AN OLD
C                 STYLE PARALLELIZATION INSIDE THE SERIAL UMP CODE.
         IF(OSPT.EQ.RMP) THEN
            IF(EONLY) THEN
               CALL UMP2EN
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
            ELSE
               IF(MASWRK) WRITE(IW,*) 'RMP GRADIENT CODE DOES NOT EXIST'
               CALL ABRT
            END IF
         END IF
C
C                 THE ZAPT THEORY HAS PARALLEL AND SERIAL ENERGY CODE.
C                 THE ZAPT THEORY GRADIENT HAS ONLY DDI PARALLEL CODE.
C                 CHECK RUNS UNSET GOPARR BY CALLING SYSINP INSIDE
C                 MP2DDI, SO FORCE ZAPT GRADIENTS TO BE PARALLEL TWICE.
         IF(OSPT.EQ.ZAPT) THEN
            IF(EONLY) THEN
               IF(CODEMP.EQ.SERIAL) THEN
                  CALL ZAPTEN
                  IF(MASWRK) WRITE(IW,9100)
                  CALL TIMIT(1)
               END IF
               IF(CODEMP.EQ.DDI) THEN
                  CALL MP2DDI
                  IF(MASWRK) WRITE(IW,9100)
                  CALL TIMIT(1)
               ENDIF
            ELSE
               GOPARR = .TRUE.
               CALL MP2DDI
               IF(MASWRK) WRITE(IW,9100)
               CALL TIMIT(1)
               GOPARR = .TRUE.
            END IF
         END IF
      END IF
C
C     --- JUST A MARKER TO MAKE IT CLEAR GVB + PT2 IS IMPOSSIBLE ---
C     INPUT SCANNERS SHOULD HAVE PREVENTED US FROM EVER GETTING HERE.
C
      IF(SCFTYP.EQ.GVB) THEN
         IF(MASWRK) WRITE(IW,*) 'NO GVB+MP2, TRY MCSCF REFERENCE'
         CALL ABRT
      END IF
C
C     --- SELECT FROM 3 KINDS OF MULTIREFERENCE PERTURBATION THEORY ---
C     THERE'S NO GRADIENT OR DENSITY MATRIX CODE AT THE PRESENT TIME.
C
      IF(SCFTYP.EQ.RMC) THEN
         IF(EONLY) THEN
C
C     --- QUASIDEGENERATE MULTIREFERENCE PERTURBATION THEORY ---
C               THIS IS A DETERMINANT BASED PROGRAM
C
            IF (TYPMRMP.EQ.DEMRPT) THEN
               CALL MRPT
            END IF
C
C     --- QUASIDEGENERATE MULTIREFERENCE PERTURBATION THEORY ---
C               THIS IS A GUGA CSF BASED PROGRAM
C     THIS PROGRAM HAS SPIN-ORBIT PERTURBATION AS A SUB-OPTION.
C     THIS PROGRAM HAS REFERENCE WEIGHT COMPUTATION AS AN OPTION.
C
C     NOTE THAT PARALLEL FULLNR MAY HAVE FORCED A DIRECT TRANSFORMATION,
C     SO NOW THE MCQDPT MAY NEED AN AO INTEGRAL FILE ON EACH NODE.
C
            IF(TYPMRMP.EQ.RMCQD) THEN
               DTRFSV = DIRTRF
               DSCFSV = DIRSCF
               IF(DIRTRF  .OR.  DIRSCF) THEN
                  DIRTRF = .FALSE.
                  DIRSCF = .FALSE.
                  IF(MASWRK) WRITE(IW,9040)
                  DSKWSV = DSKWRK
                  DSKWRK = .TRUE.
                  CALL SEQOPN(IJK,'AOINTS','UNKNOWN',.FALSE.,
     *                        'UNFORMATTED')
                  GPSAVE = GOPARR
                  GOPARR = .FALSE.
                  IF(.NOT.ABEL) CALL SYMOFF
                  CALL JANDK
                  IF(.NOT.ABEL) CALL SYMON
                  GOPARR = GPSAVE
                  DSKWRK = DSKWSV
               END IF
               CALL MCQDPT(RMCQD,GRPV)
               IF(DTRFSV  .OR.  DSCFSV) THEN
                  DIRTRF = DTRFSV
                  DIRSCF = DSCFSV
               END IF
            END IF
C
C     --- GENERALIZED VAN VLECK MULTIREFERENCE PERTURBATION THEORY ---
C
            IF(TYPMRMP.EQ.GVVPT) THEN
               CALL GVVPT2M
            END IF
C
C     --- MC-QDPT WITH GENERAL MC REFERENCE FUNCTIONS (GMC-QDPT)
C
            IF(TYPMRMP.EQ.GMCQDPT) THEN
               CALL GMCPT
            END IF
C
            IF(MASWRK) WRITE(IW,9100)
            CALL TIMIT(1)
         ELSE
            IF(MASWRK) WRITE(IW,*)
     *           'MCSCF+MP2 GRADIENT CODE DOES NOT EXIST'
            CALL ABRT
         END IF
      END IF  ! END MRPT TYPE SELECTION
C
C        STORE ENERGY (ALL METHODS)
C
      E   =EMP2
      ETOT=EMP2
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
C
C     --- WAVE FUNCTION PROPERTIES FOR MP2 RELAXED DENSITY MATRIX ---
C     PRECISELY SPEAKING, THIS IS THE 1ST ORDER WAVEFUNCTION'S DENSITY
C
      IF(EONLY  .OR.  (ISEPS  .AND.  MP2ITER.EQ.0)) THEN
         CONTINUE
      ELSE
         CALL PROPTY('MP2 ')
      END IF
C
C          RESTORE ROHF CANONICAL ORBITALS AFTER RMP STYLE MP2
C
      IF(SCFTYP.EQ.ROHF .AND.  OSPT.EQ.RMP .AND. EXETYP.NE.CHECK) THEN
         L3 = NUM*NUM
         CALL VALFM(LOADFM)
         LV   = LOADFM + 1
         LAST = LV     + L3
         NEED = LAST - LOADFM -1
         CALL GETFM(NEED)
         CALL DAREAD(IDAF,IODA,X(LV),L3,61,0)
         CALL DAWRIT(IDAF,IODA,X(LV),L3,15,0)
         CALL RETFM(NEED)
      END IF
C
C     COSMO MP2 ITERATION
C
      IF(ISEPS) THEN
         WRITE(IW,*)
         WRITE(IW,*)"    ---------------------------------"
         WRITE(IW,*)"    CONVERGENCE WITHIN MP2 ITERATIONS"
         WRITE(IW,*)"    ---------------------------------"
         WRITE(IW,*)
         CHKMP2=ABS(EMP2LAST-EMP2)
         WRITE(IW,123) EMP2
         WRITE(IW,124) EMP2LAST
         WRITE(IW,125) CHKMP2
         WRITE(IW,*)
 123     FORMAT('      E(MP2)        =',F20.10)
 124     FORMAT('      E(MP2-LAST)   =',F20.10)
 125     FORMAT('      DELTA-E       =',F20.10)
         EMP2LAST=EMP2
C
         IF(CHKMP2.GT.1.0D-05) THEN
            MP2ITER=1
            ICORR=1
         ELSE
            MP2ITER=0
            EMP2LAST=0.0D+00
            WRITE(IW,*)
            WRITE(IW,*)"    CONVERGENCE WITHIN MP2 ACHIEVED"
            WRITE(IW,*)
         END IF
C
C        MP2ITER=1 NEEDS A CALL TO MP2GRD TO GET THE MP2 SURFACE CHARGES
C        AND THEN AN INNER SCF WITH FIXED SURFACE CHARGES
C
C        MP2ITER=0 MEANS THAT THE MP2 CHARGES/ITERATIONS ARE CONVERGED,
C        SO GO ON AS USUAL WHICH NEEDS TO RESET ICORR=0 (FOR RHFCL)
C        AND EMP2LAST (FOR THE NEXT MP2 ITERATIONS ON THE NEXT GEOMETRY)
C
         IF(MPPROP.EQ.1 .OR. MP2ITER.EQ.1) THEN
            WRITE(IW,*) "MPPROP, MP2ITER IN WFNMP2 =",MPPROP,MP2ITER
            WRITE(IW,*) "CALLING MP2GRD FROM WFNMP2"
            CALL MP2GRD
         END IF
         WRITE(IW,*) "ICORR BEFORE RETURNING FROM WFNMP2", ICORR
      END IF
C
      RETURN
C
 9100 FORMAT(1X,'..... DONE WITH MP2 ENERGY .....')
 9040 FORMAT(/1X,'MCQDPT CANNOT RUN AO INTEGRAL DIRECT, SO',
     *          '  DIRTRF/DIRSCF WILL BE IGNORED.')
 9310 FORMAT(/1X,'REGENERATING AO INTEGRALS W/O SYMMETRY FOR',
     *           ' THIS NON-ABELIAN POINT GROUP...')
      END
C
C*MODULE GAMESS  *DECK WFNTDDFT
      SUBROUTINE WFNTDDFT
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL TRIPLET
      LOGICAL DIRSCF,FDIFF
      LOGICAL GOPARR,DSKWRK,MASWRK,LCFLAG,LRINT,GOPSAV,SG1,SG1T
C
      PARAMETER (MXATM=2000, MXSH=5000, MXRT=100)
      PARAMETER (MXGRID=10, MXGRIDTYP=10)
C
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFLEB/  NLEB(MXGRID),NLEB0(MXGRID)
      COMMON /DFPRUN/ PRUNERADS(MXGRID,MXGRIDTYP),
     *                PRUNEATOMS(2,MXGRIDTYP),
     *                IPRUNECUTS(MXATM),NTOTGRIDPOINTS(MXATM),
     *                NGRIDS,MAXANG,NGRIDTYPS
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /INFGRD/ RHOMIN,ILENG,MAXGRD
      COMMON /INFOTD/ TDM(3,MXRT),CNVTOL,TRIPLET,MOCC(MXRT),MVIR(MXRT),
     *                NRADT,NTHET,NPHIT,NSTAT,NTRIAL,MAXVEC,NTHST,
     *                IRECTD,NLEBT,SG1T
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DATA RHF/8HRHF     /
      DATA UHF  /8HUHF     /
      DATA ROHF /8HROHF    /
      DATA RNONE/8HNONE    /,ATDDFT/8HTDDFT   /,ATDHF/8HTDHF    /
C
C     TDDFT EXCITATION ENERGY AND OSCILLATOR STRENGTH CALCULATION
C
C     WRITTEN BY MAHITO CHIBA
C     NATIONAL INSTITUTE OF ADVANCED INDUSTRIAL SCIENCE AND TECHNOLOGY
C     (AIST), JAPAN.
C
C        ----- DRIVER FOR TD-DFT COMPUTATIONS -----
C
      TDTYP=ATDDFT
      IF(TDDFTYP.EQ.RNONE) TDTYP=ATDHF
      IF(MASWRK) THEN
         IF(LCFLAG) THEN
            WRITE(IW,8000) TDTYP,SCFTYP,EMU
         ELSE
            WRITE(IW,7000) TDTYP,SCFTYP
         END IF
         IF(SCFTYP.EQ.RHF) THEN
            WRITE(IW,9000)
         ELSE
            WRITE(IW,9010)
         END IF
      ENDIF
C
C        PROGRAMMED ONLY WITH A GRID (FORCED HERE FOR CHECK RUNS)
C
      IF(DFTYPE.NE.RNONE) NDFTFG = 1
C
C     HPTI: ONLY DLB RUNS IN PARALLEL, SLB IS LEFT TRIVIALLY SERIAL.
C
      IF(IBTYP.EQ.1) THEN
         GOPSAV=GOPARR
         NPROCS=NPROC
      ELSE
         GOPSAV=GOPARR
         NPROCS=NPROC
         GOPARR=.FALSE.
         NPROC=1
         IF(.NOT.MASWRK) GOTO 100
      END IF
C
C       --- TURN OFF INTEGRAL SYMMETRY FOR TDDFT ITERS ---
C     THE POINT GROUP SYMMETRY SHOULD BE TURNED BACK ON LATER,
C     ONCE THE TDDFT ITERATIONS HAVE CONVERGED, SO THAT THE
C     SYMMETRY LABELS FOR THE EXCITATIONS CAN BE PRINTED.
C
C     POOR MAN'S PARALLELISATION: RECOMPUTE INTEGRALS ON MASTER NODE.
C
      IF(NT.GT.1.OR.GOPSAV) THEN
         CALL SYMOFF
         IF(DIRSCF) THEN
            IF(MASWRK) WRITE(IW,1100) TDTYP
         ELSE
            IF(MASWRK) WRITE(IW,1110) TDTYP
            IF(LCFLAG) THEN
               LRINT=.TRUE.
               CALL JANDK
               LRINT=.FALSE.
            ENDIF
            CALL JANDK
         END IF
         CALL SYMON
      END IF
C
C        ----- CHANGE GRID SIZE FOR TDDFT
C
      NRADS=NRAD
      NTHES=NTHE
      NPHIS=NPHI
      NLEBS=NLEB(1)
      NRAD=NRADT
      NTHE=NTHET
      NPHI=NPHIT
      NLEB(1)=NLEBT
C
C     --- DEFINE MAXGRD, W/O EXPLOITING ANY GRID SYMMETRY
C
      IF(NDFTFG.EQ.1) THEN
         CALL SYMOFF
         CALL MEMGRD
         CALL SYMON
      END IF
C
      IF(MASWRK) THEN
         WRITE(IW,*) ' '
         WRITE(IW,*) '-TDDFT RUNTIME PARAMETERS-'
         WRITE(IW,*) '   TRIPLET  =',TRIPLET
         WRITE(IW,*) '   NSTATE   =',NSTAT
         WRITE(IW,*) '   IROOT    =',NTHST
         WRITE(IW,*) '   NTRIAL   =',NTRIAL
         WRITE(IW,*) '   MAXVEC   =',MAXVEC
         IF(NDFTFG.EQ.1) THEN
            WRITE(IW,*) '   ILENG    =',ILENG
            WRITE(IW,*) '   MAXGRD   =',MAXGRD
            IF(SG1) THEN
               WRITE(IW,*)'   USING THE SG-1 PRUNED GRIDS'
            ELSE
               IF(NLEB(1).NE.0) THEN
                  WRITE(IW,*)'   NRAD     =',NRAD
                  WRITE(IW,*)'   NLEB     =',MAXANG
               ELSE
                  WRITE(IW,*)'   NRAD     =',NRAD
                  WRITE(IW,*)'   NTHE     =',NTHE
                  WRITE(IW,*)'   NPHI     =',NPHI
               ENDIF
            ENDIF
         ENDIF
         WRITE(IW,*) ' '
         CALL FLSHBF(IW)
      ENDIF
C
C     --- TDDFT
C     NOTE THAT SYMMETRY IS TURNED OFF AGAIN, INSIDE THE FOLLOWING.
C
      IF (SCFTYP.EQ.RHF)  CALL  TDDFTCALC
      IF (SCFTYP.EQ.UHF)  CALL UTDDFTCALC
      IF (SCFTYP.EQ.ROHF) CALL UTDDFTCALC
C
C             PRINT WARNING IF RADIAL GRID IS SUBSTANDARD.
      IF(MASWRK) CALL CHKRGRID
C
      NRAD=NRADS
      NTHE=NTHES
      NPHI=NPHIS
      NLEB(1)=NLEBS
C
  100 CONTINUE
      GOPARR=GOPSAV
      NPROC=NPROCS
      IF(GOPARR) THEN
         CALL DDI_BCAST(2428,'F',ETOT,1,MASTER)
         CALL DDI_BCAST(2428,'F',ESTATE,MXRT,MASTER)
         CALL DDI_BCAST(2428,'F',TDM,MXRT,MASTER)
         CALL DDI_BCAST(2428,'I',MOCC,MXRT,MASTER)
         CALL DDI_BCAST(2428,'I',MVIR,MXRT,MASTER)
      ENDIF
C
C        IF THE RUN IS DOING AN ANALYTIC GRADIENT, WE NEED TO
C        GENERATE RESPONSES, DENSITY QUANTITIES, AND PROPERTIES.
C        THIS CALL DOES -NOT- DO THE NUCLEAR DERIVATIVE INTEGRALS!
C
      CALL DERCHK(NDER)
      IF(NDER.GT.0  .AND.  NGLEVL.EQ.0) CALL TDGRAD
      RETURN
C
 1100 FORMAT(/1X,'SWITCHING OFF POINT GROUP SYMMETRY DURING DIRECT ',
     *           A5,' ITERATIONS')
 1110 FORMAT(/1X,'REGENERATING AO INTEGRAL LIST IN C1 SYMMETRY FOR ',
     *           A5,' ITERATIONS...')
 7000 FORMAT(/1X,71(1H-)/
     *  20X,A5,' CALCULATION FOR SCFTYP=',A4)
 8000 FORMAT(/1X,71(1H-)/
     *  17X,'LC-',A5,' CALCULATION FOR SCFTYP=',A4/
     *  22X,'WITH LC-PARAMETER MU = ',F4.2/
     *  9X,'Y. TAWADA, T. TSUNEDA, S. YANAGISAWA, T. YANAI, K. HIRAO,'/
     *  18X,'J. CHEM. PHYS. 120 (2004) 8425-8433.'/)
 9000 FORMAT(26X,'CODED BY MAHITO CHIBA'/
     *   1X,'NATIONAL INSTITUTE OF ADVANCED INDUSTRIAL SCIENCE AND',
     *      ' TECHNOLOGY, JAPAN'/
     *       1X,71(1H-))
 9010 FORMAT(26X,'CODED BY SOOHAENG YOO'/
     *       1X,71(1H-))
      END
C
C*MODULE GAMESS  *DECK TRIVIA
C
C     STUBS FOR INTERFACE TO KURT GLAESEMANN'S PIMC CODE
C
      SUBROUTINE PIMCINP
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /PIMC  / MTHPIMC,NFPIMC
      MTHPIMC=0
      NFPIMC=38
      RETURN
      END
C
      SUBROUTINE PIMCX
      CALL PIMCOUT
      RETURN
      END
C
      SUBROUTINE PIMCOUT
      COMMON /PIMC  / MTHPIMC,NFPIMC
      WRITE(6,*) 'EXCELLENT FINAL OUTPUT, EH?  NFPIMC=',NFPIMC
      RETURN
      END
C
C        AND SOME OTHER STUBS TOO
C
      SUBROUTINE GVVPT2M
      WRITE(6,*) 'PRESENTLY THE GVVPT2 PROGRAM IS DELETED'
      RETURN
      END
