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 /FUNCT/ SAVES C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /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 /RUNOPT/; SAVE/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, MXATM=500) 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 /HERMIT/ H11,H21,H22,H31,H32,H33,H41,H42,H43,H44, * H51,H52,H53,H54,H55,H61,H62,H63,H64,H65,H66, * H71,H72,H73,H74,H75,H76,H77 COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PCMDAT/ EPS,EPSINF,DR,RSOLV,VMOL,TCE,STEN,DSTEN, * CMF,TABS,ICOMP,IFIELD,ICAV,IDISP COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS COMMON /TMVALS/ TI,TX,TIM COMMON /WERMIT/ W11,W21,W22,W31,W32,W33,W41,W42,W43,W44, * W51,W52,W53,W54,W55,W61,W62,W63,W64,W65,W66, * W71,W72,W73,W74,W75,W76,W77 COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP C PARAMETER (ZERO=0.0D+00) C DATA CHECK /8HCHECK / DATA SURF /8HSURFACE / DATA MOROKM /8HMOROKUMA/ DATA TDHF /8HTDHF / C DATA RHF,AMCSCF/8HRHF ,8HMCSCF / DATA RNONE,GUGA/8HNONE ,8HGUGA / DATA DETWRD,DRTWRD,GENWRD/8HDET ,8HDRT ,8HGEN / DATA BLANK /8H / 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 ----- INITIALIZE COMMON /HERMIT/ ----- C H11= ZERO H21=-.707106781186548D+00 H22= .707106781186548D+00 H31=-1.22474487139159D+00 H32= ZERO H33= 1.22474487139159D+00 H41=-1.65068012388578D+00 H42=-.524647623275290D+00 H43= .524647623275290D+00 H44= 1.65068012388578D+00 H51=-2.02018287045609D+00 H52=-.958572464613819D+00 H53= ZERO H54= .958572464613819D+00 H55= 2.02018287045609D+00 H61= -2.350604973674D+00 H62= -1.335849074014D+00 H63= -0.436077411928D+00 H64= 0.436077411928D+00 H65= 1.335849074014D+00 H66= 2.350604973674D+00 H71=-2.651961356835233D+00 H72=-1.673551628767471D+00 H73=-0.816287882858965D+00 H74= ZERO H75= 0.816287882858965D+00 H76= 1.673551628767471D+00 H77= 2.651961356835233D+00 C C ----- INITIALIZE COMMON /WERMIT/ ----- C W11= 1.77245385090552D+00 W21= .8862269254528D+00 W22= .8862269254528D+00 W31= .2954089751509D+00 W32= 1.181635900604D+00 W33= .2954089751509D+00 W41= 8.131283544725D-02 W42= 8.049140900055D-01 W43= 8.049140900055D-01 W44= 8.131283544725D-02 W51= 1.995324205905D-02 W52= 3.936193231522D-01 W53= 9.453087204829D-01 W54= 3.936193231522D-01 W55= 1.995324205905D-02 W61= 4.530009905509D-03 W62= 1.570673203229D-01 W63= 7.246295952244D-01 W64= 7.246295952244D-01 W65= 1.570673203229D-01 W66= 4.530009905509D-03 W71= 9.717812450995D-04 W72= 5.451558281913D-02 W73= 4.256072526101D-01 W74= 8.102646175568D-01 W75= 4.256072526101D-01 W76= 5.451558281913D-02 W77= 9.717812450995D-04 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) IF (GOPARR) WRITE(IW,9055) NPROC 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 ----- READ IN BASIS SET AND GET INITIAL MO'S ----- C CALL START C CALL VALFM(INITFM) C C ----- GET DETAILS ABOUT MCSCF WAVEFUNCTION ----- C NEED TO REREAD LOCALIZATION INPUT ONCE MCSCF DETAILS ARE KNOWN C IF(SCFTYP.EQ.AMCSCF) THEN NA=0 NB=0 CALL DETINP(-23,DETWRD) IF(NA+NB.EQ.0) CALL GCIINP(-23,GENWRD) IF(NA+NB.EQ.0) CALL DRTGEN(-23,DRTWRD) IF(NA+NB.EQ.0) THEN IF(MASWRK) WRITE(IW,9060) CALL ABRT END IF END IF C CALL LMOINP 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 ----- ONLY RHF+CI RUNS HAVE GRADIENT CAPABILITY ----- C CALL DERCHK(NDER) IF (CITYP.NE.RNONE .AND. NDER.GT.0) THEN IF(SCFTYP.NE.RHF) THEN IF (MASWRK) WRITE(IW,9080) RUNTYP,SCFTYP CALL ABRT END IF IF(CITYP.NE.GUGA) THEN IF (MASWRK) WRITE(IW,9083) CITYP CALL ABRT END IF IF(NPROC.GT.1) THEN IF (MASWRK) WRITE(IW,9085) RUNTYP CALL ABRT END IF END IF C IF (TIM .GE. TIMLIM) CALL ABRT 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(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(ICAV.EQ.1.OR.IFIELD.NE.0) CALL CAVITM IF(IDISP.EQ.1) CALL DISRPM CALL SOLPRT END IF C C ----- POSSIBLE ORBITAL LOCALIZATION ----- C ----- POSSIBLE MO TRUNCATION/LOCALIZATION ----- C CALL LMOX CALL TRUNC C C ----- INTERFACES TO OTHER PROGRAMS ----- C 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 C C ----- ALL DONE ----- C CALL VALFM(LASTFM) IF(LASTFM.NE.INITFM .AND. MASWRK) WRITE(IW,9090) 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 = 16 FEB 2002 (R4)',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,'CHRISTINE AIKENS, ROB BELL, PRADIPTA BANDYOPADHYAY,', * ' BRETT BODE,'/ * 5X,'GALINA CHABAN, WEI CHEN, CHEOL CHOI, PAUL DAY,', * ' DMITRI FEDOROV,'/ * 5X,'GRAHAM FLETCHER, MARK FREITAG, KURT GLAESEMANN,', * ' GRANT MERRILL,'/ * 5X,'MIKE PAK, JIM SHOEMAKER, TETSUYA TAKETSUGU,', * ' SIMON WEBB.') 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, HARUYUKI NAKANO,', * ' TAKAHITO'/ * 5X,'NAKAJIMA, TAKAO TSUNEDA, MUNEAKI KAMIYA, SUSUMU YANAGISAWA'/ * 5X,'ODENSE UNIVERSITY: 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: KAROL KOWALSKI, PIOTR PIECUCH'/ * 5X,'UNIVERSITY OF SILESIA: MONIKA MUSIAL, STANISLAW KUCHARSKI'/) 9055 FORMAT(1X,'PARALLEL VERSION RUNNING WITH ',I3,' PROCESSORS'/) 9060 FORMAT(1X,'MCSCF REQUIRES A $DET, $GEN, OR $DRT GROUP TO', * ' DEFINE THE WAVEFUNCTION') 9070 FORMAT(/1X,'***** ERROR ***** GAMESS DOES NOT PERMIT RUNTYP=', * A8,' WITH MP2') 9080 FORMAT(/1X,'***** ERROR *****'/ * 1X,'GAMESS DOES NOT PERMIT RUNTYP=',A8,' WITH SCFTYP=',A8/ * 1X,'SINCE THERE IS NO CI GRADIENT EXCEPT FOR RHF.') 9083 FORMAT(/1X,'***** ERROR ***** YOUR INPUT CITYP=',A8/ * 1X,'THERE IS NO CI GRADIENT EXCEPT CITYP=GUGA.') 9085 FORMAT(/1X,'***** ERROR *****'/ * 1X,'CI GRADIENT DOES NOT RUN IN PARALLEL,'/ * 1X,'SO GAMESS DOES NOT PERMIT YOUR RUNTYP=',A8) 9090 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 C DATA ENERGY /8HENERGY /, GRAD /8HGRADIENT/, HSSIAN /8HHESSIAN / DATA PROP /8HPROP /, OPTMIZ /8HOPTIMIZE/, SADPT /8HSADPOINT/ DATA AIRC /8HIRC /, DRC /8HDRC / DATA MOROKM /8HMOROKUMA/, TRNSTN /8HTRANSITN/ DATA TRUDGE /8HTRUDGE /, FFIELD /8HFFIELD /, TDHF /8HTDHF / DATA GRDXTR /8HGRADEXTR/, MAKEFP /8HMAKEFP /, MD /8HMD / DATA VSCF /8HVSCF /, RAMAN /8HRAMAN /, GLOBOP /8HGLOBOP / DATA PIMC /8HPIMC /, AMEX /8HMEX / 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 SADDLE POINT 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.'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.'MEX ', minimum energy crossing point search 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.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.RAMAN) CALL RAMANX if(RUNTYP.EQ.AMEX) call mexngx IF(RUNTYP.EQ.PROP ) THEN CALL ONEEI CALL GUESMO(GUESS) CALL HFPROP END IF IF(RUNTYP.EQ.MAKEFP) CALL EFPX 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,skpges C PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, 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 COMMON /FUNCT / E,EG(3*MXATM) COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT), * CF(MXGTOT),CG(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 /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS 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,DIRTRF COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD common /mexopt/ skpges C DATA RMC /8HMCSCF / DATA RNONE /8HNONE / DATA GUGA /8HGUGA / DATA ENERGY /8HENERGY / DATA OPTMIZ /8HOPTIMIZE/ DATA SADPT /8HSADPOINT/ 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 C TINKER MM ENERGY CALCULATION C IF ((QMMM .OR. MMONLY) .AND. (RUNTYP .EQ. ENERGY)) THEN IF(MASWRK) THEN CALL ANALYZE END IF IF (MMONLY) RETURN 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 C ----- 1E- INTEGRALS ----- C IF(IREST.LE.1) CALL ONEEI 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 ALSO, GENERATE THE -Q- MATRIX AT THE CURRENT GEOMETRY. C IF(NEVALS.EQ.0) THEN if(skpges) then call orthdn else CALL GUESMO(GUESS) end if ELSE CALL ORTHDN END IF C C ----- 1E- INTEGRALS FOR DFT ----- C THIS REQUIRES ONE KNOW THE ORBITALS 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(IREST.LE.1 .AND. SCFTYP.NE.RNONE) CALL JANDK GOPARR = SVGPAR NT = NTSAVE IF(TIM.GE.TIMLIM) GO TO 120 C C ----- PCM CALCULATION, STEP 1 ----- C IF(IPCM.EQ.1) CALL SOLVNT C C ----- CALCULATE WAVEFUNCTION ----- C IF(IREST.LE.2) CALL WFN NEVALS = NEVALS + 1 IF(TIM.GE.TIMLIM) GO TO 120 C C ----- WAVEFUNCTION PROPERTIES ----- C IF(.NOT.VTSCAL .AND. IREST.LE.2) THEN IF(SCFTYP.EQ.RMC .AND. MPLEVL.EQ.2) THEN CONTINUE ELSE CALL HFPROP END IF END IF C C ----- OPTIONAL VIRIAL SCALING ----- C IF(VTSCAL .AND. ((RUNTYP.NE.OPTMIZ) .AND. (RUNTYP.NE.SADPT) .AND. * (RUNTYP.NE.ENERGY))) THEN IF(MASWRK) WRITE(IW,9000) CALL ABRT END IF IF(VTSCAL .AND. * (MPLEVL.GT.0 .OR. CITYP.NE.RNONE .OR. CCTYP.NE.RNONE)) THEN IF(MASWRK) WRITE(IW,*) ' VTSCAL IS IMPLEMENTED FOR SCF ONLY' CALL ABRT END IF IF((VTSCAL .AND. ((RUNTYP.EQ.OPTMIZ).OR.(RUNTYP.EQ.SADPT))) .AND. * .NOT.LVCLN ) THEN IF(MASWRK) WRITE(IW,9010) CALL HFPROP SCALTE=(-EPOT/(TWO*EKIN))**2 SCALTT = SCALTT*SCALTE END IF IF((VTSCAL .AND. RUNTYP.EQ.ENERGY) .OR. LVCLN) THEN IF(.NOT.LVCLN .AND. MASWRK) WRITE(IW,9020) CALL HFPROP 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 STOP 100 CONTINUE IF(MASWRK) WRITE(IW,9070) ABS(GRD2),VTCONV IF(LVCLN) OLDHSS=VIRHSS IF(LVCLN) RETURN VTSCAL = .FALSE. NPRINT = 7 CALL HFPROP CALL ORBKIN END IF C 120 CONTINUE 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=500) PARAMETER (MXPT=100, MXFRG=50, MXFGPT=MXPT*MXFRG) 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 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) COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS 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 IREST = 3 1E-GRADIENT RESTART(MO'S SAVED; NO GRADIENT SAVED) C IREST = 4 2E-GRADIENT RESTART(MO'S SAVED; PARTIAL GRADIENT SAVED) 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 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 C PARAMETER (MXATM=500) PARAMETER (MXPT=100, MXFRG=50, MXFGPT=MXPT*MXFRG) 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 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) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP COMMON /XYZPRP/ DUM(3),DIP(3),DUMM(32) COMMON /ZMAT / NZMAT,NZVAR,NVAR,NSYMC,LINEAR C DATA CHECK /8HCHECK /, GUGA /8HGUGA / C C ----- CALCULATE ENERGY AND ITS GRADIENT AT ONE GEOMETRY ----- C THIS ROUTINE WRITTEN BY MIKE SCHMIDT, MAY 7, 1983. C FGONLY = NUM.EQ.0 .AND. NFRG.GT.0 C IF (MASWRK) WRITE(IW,9000) 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) CALL ABRT END IF C NCOORD = 3*NAT NCF=3*NFRG NC1=NCOORD+2*NCF 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 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) CALL EGPUN(EG,NAT) 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 CALL PUVIB(IP,IW,.FALSE.,NCOORD,0,0,0,E,EG,DIP) IF (MASWRK) WRITE(IP,FMT='('' $END '')') 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 C COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEF,IP_F COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST COMMON /TMVALS/ TI,TX,TIM COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP C DATA NONE/4HNONE/ DATA RHF,UHF/8HRHF ,8HUHF / C C ----- CALCULATE GRADIENT OF THE ENERGY ----- C WITH RESPECT TO THE NUCLEAR COORDINATES 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 ----- MOPAC FIRST DERIVATIVES ARE DONE ELSEWHERE ----- C IF(MPCTYP.NE.NONE) THEN CALL MPCGRD(SCFTYP) RETURN END IF C C ----- PREPARATION OF DENSITY FOR MP2 GRADIENT ----- C IF(MPLEVL.EQ.2 .AND. SCFTYP.EQ.RHF .AND. .NOT.GOPARR) CALL MP2GRD IF(MPLEVL.EQ.2 .AND. SCFTYP.EQ.UHF .AND. .NOT.GOPARR) CALL UMPGRD IF (TIM .GE. TIMLIM) RETURN 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 CALL JKDER END IF END IF C C ----- POLARIZABLE CONTINUUM MODEL GRADIENT CORRECTIONS ----- C IF(IPCM.EQ.1) THEN IF(IEF.EQ.0) CALL DERPCM IF(IEF.EQ.3) CALL DERIEF ENDIF C IREST = 0 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=500, MXAO=2047) C COMMON /FMCOM / XX(1) COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO) COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP C DATA UHF,SAVDMO/8HUHF ,8HMOSAVED / 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 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 LOADFM=0 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 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) CALL ORTHO(XX(LQ),XX(LS),XX(LV),XX(LSCR),L0,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 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 LOGICAL GOPARR,DSKWRK,MASWRK,KSTATE,QUD,LMOPAR C PARAMETER (MXATM=500, 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 COMMON /FUNCT / E,EG(3,MXATM) COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /MQ2PAR/ DMQPAR(200),AVECOE(MXRT), * IMQPAR(400),MAINCS( 3),KSTATE(MXRT),LMOPAR(10) COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PSILVL/ IPSI COMMON /QUDMC / QUDTHR,QUD COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,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 C DATA RMC/8HMCSCF / DATA RHF,UHF,ROHF,GVB/8HRHF ,8HUHF ,8HROHF ,8HGVB / DATA CHECK/8HCHECK /,RNONE/8HNONE /, TRNSTN /8HTRANSITN/ C C ----- DRIVER FOR SELF-CONSISTENT FIELD CALCULATIONS ----- C C IPSI=0 MEANS SCF, IPSI=1 MEANS CI, IPSI=2 MEANS MP, IPSI=3 MEANS CC C LEVEL COMPUTATION IS CURRENTLY IN PROGRESS. C IPSI=0 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 IF A CI STEP HAS BEEN COMPLETED, WE MUST ERASE ITS C EIGENVECTOR FILE TO AVOID CONFUSING A FOLLOWING MCSCF 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 INORB = IMQPAR(3) IF(INORB.EQ.0.AND.RUNTYP.EQ.TRNSTN) THEN IF(MASWRK) WRITE(IW,*) * 'AT PRESENT INORB=0 IS NOT SUPPORTED WITH SO-MCQDPT' CALL ABRT STOP ENDIF IF(INORB.NE.0) GO TO 200 C C ----- EXECUTE SCF PROCEDURE ----- 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 E = ZERO ETOT = ZERO EN=ENUC(NAT,ZAN,C) IF (SCFTYP.EQ.RMC) ENUCR=EN SZ = ZERO S2 = ZERO 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) THEN IF (QUD) THEN CALL MCQUD ELSE CALL MCSCF END IF END IF C C ----- SAVE ENERGY DATA FOR SCF ----- C 200 CONTINUE 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 C ----- CARRY OUT OPTIONAL -MP- PERTURBATION COMPUTATION ----- C IF(MPLEVL.GT.0) THEN IF(E.EQ.ZERO .AND. EXETYP.NE.CHECK .AND. INORB.EQ.0) THEN IF(MASWRK) WRITE(IW,9000) MPLEVL CALL ABRT END IF IF(MPLEVL.EQ.2) CALL WFNMP2 END IF C C COSMO MP2 ITERATIONS C IF (MP2ITER.EQ.1) GOTO 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 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 CALL ABRT END IF CALL WFNCI END IF C C ----- WRITE ENERGY RESULTS TO DAF ----- 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') END C*MODULE GAMESS *DECK WFNCC SUBROUTINE WFNCC C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C LOGICAL GOPARR,DSKWRK,MASWRK C PARAMETER (MXRT=100, MXATM=500) C COMMON /CCPAR / AMPTSH,METHCC,NCCTOT,NCCOCC,NCCFZC,NCCFZV, * MXCCIT,MXRLEIT,MWRDCC,ICCCNV,ICCRST COMMON /ENRGYS/ VNN,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2, * VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN COMMON /FUNCT / E,EG(3,MXATM) COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PSILVL/ IPSI COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP 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 IF(MASWRK) THEN WRITE(IW,9000) CCTYP,NCCTOT,NCCOCC,NCCFZC,NCCFZV, * MXCCIT,MXRLEIT,ICCCNV,AMPTSH IF(MWRDCC.GT.0) WRITE(IW,9010) MWRDCC END IF C C CARRY OUT A FULL FOUR INDEX TRANSFORMATION OVER ONLY C THOSE ORBITALS CORRELATED BY THE CC CALCULATION. C NCORBS= NCCFZC NTOTMO= NCCTOT-NCCFZV NOCCMO= NCCTOT-NCCFZV NPRINT= 0 CALL TRFMCX(NPRINT,NCORBS,NTOTMO,NOCCMO,.FALSE.,.FALSE.) C C PERFORM THE COUPLED CLUSTER CALCULATION C CALL CCDRVR(BESTCC) E = BESTCC ETOT = BESTCC C C NEXT THING UP IS A CALL FOR HF PROPERTIES C IF(MASWRK) WRITE(IW,9090) 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 RLE ITERATIONS =',I6/ * 1X,'CONVERGENCE CRITERION FOR CC =',I6/ * 1X,'AMPLITUDE ACCURACY THRESHOLD =',1P,E8.1) 9010 FORMAT( 1X,'MAXIMUM MEMORY USAGE IN CC =',I12) 9090 FORMAT(/5X,47(1H-)/ * 5X,'SCF PROPERTIES...FOR THE REFERENCE WAVEFUNCTION'/ * 5X,47(1H-)) END C*MODULE GAMESS *DECK WFNCI SUBROUTINE WFNCI C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C PARAMETER (MXATM=500, MXSH=1000) C PARAMETER (NNAM=3) DIMENSION QNAM(NNAM),KQNAM(NNAM) DIMENSION NRNFG(10),NPFLG(10) C LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW,SVGPAR,DIRTRF,ABEL,ABELPT C COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, * ZAN(MXATM),C(3,MXATM) COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PSILVL/ IPSI COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48), * T(432),INVT(48),NT COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,DIRTRF COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,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 / C C ----- EVALUATE A CI WAVEFUNCTION ----- C IPSI=1 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,9008) CALL ABRT END IF C SVDSKW = DSKWRK DSKWRK = .TRUE. NASAVE = NA NBSAVE = NB C C ---- 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 ----- 2E- INTEGRALS ----- C IF NO PRELIMINARY SCF WAS DONE, WE NEED AN INTEGRAL LIST. C IN PARALLEL RUNS, WE MAY NEED DUPLICATE FULL AO INTEGRALS C LISTS ON EACH NODE. C ABEL = ABELPT() IF((SCFTYP.EQ.RNONE) .OR. * .NOT.ABEL .OR. * (GOPARR .AND. ITRFAO.EQ.1)) THEN NTSAVE = NT SVGPAR = GOPARR IF(.NOT.ABEL) NT=1 IF(ITRFAO.EQ.1) GOPARR=.FALSE. CALL JANDK GOPARR = SVGPAR NT = NTSAVE END IF C C CARRY OUT A DETERMINANT BASED FULL CI COMPUTATION C IF(CITYP.EQ.ALDET) THEN IF(MASWRK) WRITE(IW,9026) NRNFG(2),NPFLG(2), * NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6) CALL ALDECI(NRNFG,NPFLG) RETURN END IF C C CARRY OUT A DETERMINANT BASED GENERAL CI COMPUTATION C IF(CITYP.EQ.GENCI) THEN IF(MASWRK) WRITE(IW,9027) NRNFG(2),NPFLG(2), * NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6) CALL ALGNCI(NRNFG,NPFLG) RETURN END IF C C CARRY OUT A DETERMINANT BASED FULL SOCI COMPUTATION C IF(CITYP.EQ.FSOCI) THEN IF(MASWRK) WRITE(IW,9029) NRNFG(2),NPFLG(2), * NRNFG(4),NPFLG(4),NRNFG(5),NPFLG(5),NRNFG(6),NPFLG(6) CALL FSODCI(NRNFG,NPFLG) RETURN END IF C C CARRY OUT A GUGA CSF BASED CI COMPUTATION C IF (MASWRK) WRITE (IW,9028) (NRNFG(I),NPFLG(I),I=1,7) C 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 IF(NRNFG(2).NE.0) CALL TRFMCX(NPFLG(2),0,0,0,.FALSE.,.TRUE.) C C ----- SORT THE TRANSFORMED INTEGRALS FOR -GUGA-CI ----- C 230 CONTINUE IF (NRNFG(3).NE.0) CALL GUGSRT(NPFLG(3)) 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)) C DSKWRK = SVDSKW NA = NASAVE NB = NBSAVE RETURN C 9008 FORMAT(1X,'NAMELIST $CIINP SYNTAX ERROR FOUND. STOP.') 9026 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) 9027 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) 9028 FORMAT(/1X,'GUGA CI OPTIONS NRNFG NPFLG'/1X,37(1H-)// + , 20H -DRT- TABLE ,I5,5X,I5,/, + 20H TRANSFORMATION ,I5,5X,I5,/, 20H ENERGY MATRIX , + I5,5X,I5,/, 20H DIAGONALIZATION ,I5,5X,I5,/, + 20H 1E-DENSITY MATRIX ,I5,5X,I5,/, 20H 2E-DENSITY MATRIX , + I5,5X,I5,/, 20H LAGRANGIAN MATRIX ,I5,5X,I5) 9029 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)') END C*MODULE GAMESS *DECK WFNMP2 SUBROUTINE WFNMP2 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C LOGICAL PK,PANDK,BLOCK,DIRSCF,FDIFF,LMOMP2,ABEL,ABELPT, * GOPARR,DSKWRK,MASWRK,GPSAVE,DIRTRF,KSTATE,GOTDDI,LMOPAR C PARAMETER (MXATM=500, MXSH=1000, MXRT=100) C COMMON /ENRGMP/ EMP2,EMP3,EMP4 COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2, * VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN 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) COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) COMMON /MP2LOC/ LMOMP2 COMMON /MP2PAR/ OSPT,TOL,METHOD,NWDMP2,MPPROP, * NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT COMMON /MQ2PAR/ DMQPAR(200),AVECOE(MXRT), * IMQPAR(400),MAINCS( 3),KSTATE(MXRT),LMOPAR(10) COMMON /OPTSCF/ DIRSCF,FDIFF COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK COMMON /PKFIL / PK,PANDK,BLOCK COMMON /PRPOPT/ ILOCAL COMMON /PSILVL/ IPSI COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48), * T(432),INVT(48),NT COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,DIRTRF COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,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 DATA RHF,UHF,ROHF /8HRHF ,8HUHF ,8HROHF / DATA RMC/8HMCSCF /,GRPMC/8HMCQDPT /,GRPV/8H $VEC / DATA CHECK/8HCHECK / DATA RMP,ZAPT/8HRMP ,8HZAPT / C C ----- SET UP -MP2- RUN AND EVALUATE ENERGY ----- C IPSI=2 C NORB = NQMT NBF = NUM C C POSSIBLE LOCALIZATION FOR ENERGY DECOMPOSITION C IF (LMOMP2) THEN IF (ILOCAL .NE. 2) CALL HFPROP CALL LMOX ILOCAL=0 END IF C C EVALUATE MCSCF PROPERTIES, IF WE HAVE RECOMPUTED THE MCSCF C IF (SCFTYP.EQ.RMC) THEN INORB = IMQPAR(3) IF(INORB.EQ.0) CALL HFPROP END IF 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 CALL DDI_LEVEL(GOTDDI) IF(GOPARR .AND. GOTDDI .AND. * (SCFTYP.EQ.RHF .OR. * (SCFTYP.EQ.ROHF.AND.OSPT.EQ.ZAPT))) GO TO 3 C C --- APPARENTLY WE ARE RUNNING THE NON-DDI MP2 PROGRAM --- C THE INTEGRALS MUST BE REGENERATED IF A DUPLICATED AO C INTEGRAL FILE IS BEING USED (OLD PARALLELIZATION) C A C1 INTEGRAL LIST IS NEEDED IF THE GROUP IS NOT ABELIAN 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. NTSAVE = NT IF(.NOT.ABEL) NT=1 CALL JANDK GOPARR = GPSAVE NT = NTSAVE END IF END IF C C ----- TEST FOR LEVEL OF DERIVATIVE NEEDED ----- C 3 CONTINUE CALL DERCHK(NDER) C C THE NEXT CALL IN THE ENERGX ROUTINE WILL BE A CALL FOR PROPERTIES. C DEPENDING ON WHAT WE ARE DOING HERE, THE DENSITY ON THE DAF WILL C BE EITHER SCF OR MP2 LEVEL ON EXIT, SO WE TRY TO LABEL THE OUTPUT C ACCORDINGLY. C C IF ONLY THE ENERGY W/O PROPERTIES OR GRADIENT IS NEEDED, C USE SPECIAL ROUTINES THAT GO FOR ONLY THE ENERGY. C IF(NDER.EQ.0 .AND. MPPROP.EQ.0) THEN IF(SCFTYP.EQ.RHF) THEN IF(GOPARR) THEN CALL MP2DDI ELSE CALL MP2NRG END IF END IF C IF(SCFTYP.EQ.UHF) THEN CALL UMP2EN END IF C IF(SCFTYP.EQ.ROHF) THEN IF(OSPT.EQ.RMP) THEN CALL UMP2EN END IF IF(OSPT.EQ.ZAPT) THEN IF(GOPARR) THEN CALL MP2DDI ELSE CALL ZAPTEN END IF END IF END IF C IF(SCFTYP.EQ.RMC) CALL MCQDPT(GRPMC,GRPV) C IF(MASWRK) WRITE(IW,9100) CALL TIMIT(1) IF(SCFTYP.NE.RMC .AND. MASWRK .AND. * NPRINT.NE.-5) WRITE(IW,9200) C C RUNS INVOLVING THE GRADIENT OR 1ST ORDER DENSITY FOR PROPERTIES. C RIGHT NOW WE ARE GOING TO DO THE ENERGY, AND SOME SETUP FOR THE C GRADIENT. ADDITIONAL CALLS TO FINISH THE GRADIENT ARE IN -GRADX- C ELSE IF(SCFTYP.EQ.RHF) THEN IF(GOPARR) THEN IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9200) CALL HFPROP CALL MP2DDI IF(MASWRK) WRITE(IW,9100) CALL TIMIT(1) IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9210) ELSE CALL MP2GE2 IF(MASWRK) WRITE(IW,9100) CALL TIMIT(1) IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9200) IF(MPPROP.EQ.1 .AND. .NOT.ISEPS) THEN CALL HFPROP CALL MP2GRD IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9210) END IF END IF END IF C IF(SCFTYP.EQ.UHF) THEN CALL UMPGE2 IF(MASWRK) WRITE(IW,9100) CALL TIMIT(1) IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9200) IF(MPPROP.EQ.1 .AND. .NOT.ISEPS) THEN CALL HFPROP CALL UMPGRD IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9210) END IF END IF END IF C E =EMP2 ETOT=EMP2 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,*) ENDIF 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 IF(MASWRK .AND. MP2ITER.EQ.0) WRITE(IW,9210) END IF WRITE(IW,*) "ICORR BEFORE RETURNING FROM WFNMP2", ICORR ENDIF C RETURN C 9100 FORMAT(1X,'..... DONE WITH MP2 ENERGY .....') 9200 FORMAT(/5X,49(1H-)/ * 5X,'SCF PROPERTIES...FOR THE UNPERTURBED WAVEFUNCTION'/ * 5X,49(1H-)) 9210 FORMAT(/5X,49(1H-)/ * 5X,'MP2 PROPERTIES...FOR THE FIRST ORDER WAVEFUNCTION'/ * 5X,49(1H-)) END C THESE ARE DUMMY VERSIONS OF CHARGE PENETRATION SUBROUTINE ASKCP(NEWCP) LOGICAL NEWCP NEWCP = .FALSE. RETURN END SUBROUTINE EXPDMP(CHCHCP) DOUBLE PRECISION CHCHCP CHCHCP=0.0D+00 RETURN END 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 WRITE(6,*) 'EXCELLENT FINAL OUTPUT TO BE PRINTED HERE' RETURN END C C STUBS FOR INTERFACE TO MARIUSZ' MODEL CORE POTENTIALS C SUBROUTINE MMPINP(NUCZ,CSINP,CPINP,CDINP,CFINP, * IERR1,IERR2,INTYP,NANGM,NBFS,MINF,MAXF, * LOC,NGAUSS,NS) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION CSINP(*),CPINP(*),CDINP(*),CFINP(*),INTYP(*), * NANGM(27),NBFS(27),MINF(27),MAXF(27),NS(*) SUM = NUCZ + CSINP(1) + CPINP(1) + CDINP(1) + CFINP(1) SUM = SUM + IERR1 + IERR2 + NANGM(1) + NBFS(1) SUM = SUM + MINF(1) + MAXF(1) + LOC + NGAUSS + NS(1) IF(SUM.EQ.0.0D+00) INTYP(1)=0 RETURN END C SUBROUTINE MMPINF(NUCZ,CSINP,CPINP,CDINP,CFINP, * IERR1,IERR2,INTYP,NANGM,NBFS,MINF,MAXF, * LOC,NGAUSS,NS) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION CSINP(*),CPINP(*),CDINP(*),CFINP(*),INTYP(*), * NANGM(27),NBFS(27),MINF(27),MAXF(27),NS(*) SUM = NUCZ + CSINP(1) + CPINP(1) + CDINP(1) + CFINP(1) SUM = SUM + IERR1 + IERR2 + NANGM(1) + NBFS(1) SUM = SUM + MINF(1) + MAXF(1) + LOC + NGAUSS + NS(1) IF(SUM.EQ.0.0D+00) INTYP(1)=0 RETURN END C SUBROUTINE MMPCOR RETURN END C SUBROUTINE MCPINT(WRK,H,L2) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION WRK(L2),H(L2) SUM = H(1) + WRK(1) IF(SUM.EQ.0.0D+00) WRITE(6,*) 'NO MESSAGE' RETURN END C SUBROUTINE MCPPRO(WRK,H,L2) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION WRK(L2),H(L2) SUM = H(1) + WRK(1) IF(SUM.EQ.0.0D+00) WRITE(6,*) 'NO MESSAGE' RETURN END