C 11 APR 08 - SAN - SIGINI: CONTROL G3(MP2) COMPUTATIONS
C  4 MAR 08 - BJN,MWS,SPW - CHANGES FOR VSCF, TDDFT, AND NEO RUNS
C 20 AUG 07 - LVS - EFDSPL: EFP1/MP2 DISPERSION UPDATED
C 24 MAR 07 - LVS - PAD COMMON FRGINF,EFPPAR, PRINTING FOR EFP/MC
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 29 MAR 06 - FLG - SIGINI: READ COORD FREEZING FOR ELONGATION METHOD
C 29 MAR 06 - KRG - HESGES: REPLACE CARTESIAN GUESS
C 13 MAR 06 - NM  - ADJUST ARGS TO EGIN CALL
C  2 FEB 06 - MWS - LABEL CALLS TO HFPROP...
C 17 JAN 06 - GMC - SIGINI: TURN OFF HSSEND IF VSCF JOB
C 17 JAN 06 - HL  - BKRNR: CORRECT HESSIAN SHIFT OF FROZEN COORDS
C 19 SEP 05 - IA  - SYNCHRONIZE FRGINF COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - MWS - PAD THE COMMON TRFOPT
C 30 APR 05 - DGF - ADD KDIAGH OPTION TO COPE WITH NUMERIC PROBLEMS
C 14 MAR 05 - HL  - EFDSPL: ROTATE CAN. MO, ADD F AND G FUNCTIONS
C  7 MAR 05 - IA  - EFDSPL: UPDATE DYNAMIC POLARIZABILITY POTENTIALS
C 22 FEB 05 - MWS - EFDSLP: CORRECT ROTATION OF MP2 TYPE POLARIZABILITY
C 13 FEB 05 - JS  - EFDSPL,DISPLC: EFP MP2 DISPERSION CHANGES
C  5 FEB 05 - MWS - PAD COMMON MCINP
C 22 NOV 04 - MWS - SIGEND: MODIFY GLOBOP OUTPUT SOME MORE
C  7 SEP 04 - MWS - SIGEND: REMOVE CALL TO GAMGEN
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C 22 DEC 03 - MWS - SIGEND: FIX UMP2 AND NON-GRADIENT MP2 PROPERTIES
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - MWS - SIGEND: RESTORE PRINTING FINAL COORDINATE LOGIC
C  3 JUL 03 - JMM - SUPPRESS PRINTING DURING MONTE CARLO RUNS
C 16 JUN 03 - HL  - DISPLC: SCALE DISPLCAMENT RADIUS FOR FROZEN ATOMS
C 14 JAN 03 - JI  - ADD HOOK TO ORMAS CI STEP
C  7 AUG 02 - HT  - USE DYNAMIC MEMORY FOR EFP PAULI REPULSION
C 22 MAY 02 - MWS - SIGEND: MCSCF SHOULD REGENERATE GAMMA FUNCTION TABLE
C 17 APR 02 - PND - PRMOV: CORRECT FRAGMENT PRINTING
C 16 NOV 01 - MWS - ADJUST CALL TO CANMCV
C  8 OCT 01 - HL  - DISPLC: BUG FIXED FOR FREEZING CARTESIAN COORDINATES
C 19 SEP 01 - MWS - SIGX,SIGEND: FIX MEMORY LEAKS
C  1 AUG 01 - JI  - TWEAKS FOR GENERAL CI
C 25 JUN 01 - MWS - ALTER COMMON BLOCK SCFOPT AND WFNOPT
C 20 FEB 01 - MWS - PAD OUT THE "APPLE" COMMON, DISPLC: FIX FRAGONLY RMS
C 29 DEC 00 - MWS - DISPLC: CHECK ALL 3*NAT CARTESIANS FOR CONVERGENCE
C 19 NOV 00 - HL  - DISPLC: USE CARTESIAN GRADIENTS FOR CONVERGENCE
C 11 OCT 00 - MWS - UPDATE THE DETWFN COMMON
C 15 AUG 00 - CHC - ONLY MASTER CALLS TO PRTXYZ
C 28 JUL 00 - MAF - SIGEND: SPHERICAL HARM. PATCH, ALWAYS INVOKE CANMCV
C 11 JUN 00 - SK  - SIGEND: ONE MORE WORD NEEDED BY PRCIVC
C  1 MAY 00 - MWS - NO SYMMETRY OPTION IN TRFOPT COMMON
C 15 FEB 00 - JHJ,VK- SIGINI,DISPLC,SIGX: ALLOW FOR FROZEN CARTESIANS.
C 29 AUG 99 - CHC - SIGVAL,SIGX: ADD QMMM OPTIONS BY JRS
C 13 MAR 99 - MWS - CHKCST: AVOID DIVISION BY ZERO IN SQRT
C 13 FEB 99 - MAF - SIGEND: PRINT/PUNCH ONLY L0 ORBITALS
C 31 DEC 98 - CHC - FIXES TO CONSTRAINTS WITH SYMMETRY + IFZMAT FREEZING
C  8 AUG 07 - DGF - ADD TDDFT PROPERTIES
C  2 DEC 98 - MWS - SIGINI: ALLOW FOR A QUICK PASS JUST TO READ INPUT
C 12 NOV 98 - GDF - REMOVE USE OF ISOOUT
C 27 SEP 98 - CHC - CONSTRAIN GEOMETRY OPT FOR DLC, UPDISP: REMOVE PUNTS
C 12 SEP 98 - JAB - HESSET: FIX CALL TO PURFCM
C 13 APR 98 - MWS - SIGEND: READ SYMMETRY LABELS FROM DAF, PRINT DETS
C  6 JAN 98 - MWS - DISPLC: FIT GRADIENT INTO 80 COLUMNS
C 16 JUL 97 - MWS - BKRNR,DISPLC,SIGEND,SIGINI,SIGVAL: FRAGONLY CHANGES
C 29 APR 97 - MWS - SIGEND: PUNCH GVB COEFFICIENTS
C  8 FEB 97 - MWS - HESGES: LOOP 490 SHOULD RUN ONLY OVER AB INITIO
C  8 JAN 97 - GMC - SIGEND: CHANGES TO DROPPING MCCORES, BKRNR: STPT BUG
C 18 DEC 96 - JHJ - EFDSPL: ROTATE PAULI REPULSION INFO
C  4 DEC 96 - MWS - SIGEND: PUNCH ALL MCSCF ORBITALS AT END OF SEARCH
C  3 DEC 96 - TK  - BKRNR: CHANGE PRINTOUT OF CURVATURES
C 13 NOV 96 - JRS - UPDISP: SKIP COORDINATE TESTING FOR SYM COORDS
C 17 OCT 96 - SPW - SIGVAL: ADD CALL TO CIGRAD FOR CI RUNS
C 29 SEP 96 - MWS - SIGEND: PUNCH ALL ORBITALS AT END OF SEARCH
C 18 SEP 96 - PND - PRMOV: IMPROVEMENTS FOR FRAGMENTS PRESENT
C 14 SEP 96 - JHJ - ADDED PROJCT OPTION IN $STATPT
C 10 SEP 96 - MWS - INCLUDE EF ROUTINES EFDSPL AND EFROTT
C 11 JUL 96 - MWS - SIGEND: GENERATE MP2 NATURAL ORBITALS
C 13 JUN 96 - VAG - ADD VARIABLE FOR CI TYPE TO SCFOPT COMMON
C 18 APR 96 - GMC - SIGEND: CORRECT PRINTOUT FOR FOCAS FUNCTIONS
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C  9 FEB 96 - WC  - FRAGMENT DECLARATIONS FIXED
C  9 JAN 96 - WC  - HESSET,SIGINI: SMARTER HESSIAN GUESS FOR FRAGMENTS
C  3 JAN 96 - MWS - BKRNR: ELECTRIC FIELD OPTS HAVE 2 OR 3 TRANS. MODES
C 15 NOV 95 - FRJ - SPLIT NR, RFO, AND QA ALGORITHMS, ADD CONOPT OPTION
C 11 NOV 95 - MWS - SIGEND: PRINT SCF AND MP2 PROPERTIES FOR MP2 RUNS
C  6 OCT 95 - MWS - BKRUPD: CORRECT CALL TO FCMPUN FOR CARTESIAN HESSIAN
C 26 JUL 95 - MWS - SIGEND: CHANGE CALL TO CANMCV
C 31 MAY 95 - MWS - SIGINI: SAVE HESSIAN REQUEST IN HSSCTL COMMON
C 29 MAR 95 - JMB - BKRUPD: FIX MIXED MS-P UPDATE FORMULAE
C  4 JAN 95 - MWS - FIX CALLS TO EGMAX FOR LINEAR CASE
C 29 DEC 94 - MWS - BKRNR: POSSIBLY SKIP PROJECTION OF ROTATIONS
C 17 NOV 94 - WC  - FIX EFFECTIVE FRAGMENT GEOMETRY OPTIMIZATION
C 12 NOV 94 - MWS - REMOVE MOST FTNCHEK WARNINGS
C 15 OCT 94 - MWS - SIGEND: FIX PARALLEL MCSCF I/O OPERATIONS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  1 JUN 94 - MWS - SIGEND: FIX PROBLEM WITH PARALLEL MCSCF OUTPUT
C 27 MAY 94 - SPW - FIX FRAGMENT GEOMETRY OPTIMIZATIONS
C  2 MAY 94 - MWS - SIGEND: PRINT FINAL MCSCF PROPERTIES
C  1 APR 94 - SPW - SIGX: CALL TO EFPCGD IS NO LONGER NEEDED.
C 11 MAR 94 - FRJ - SIGVAL,SIGX: VIRIAL SCALING CHANGES
C  5 JAN 94 - MWS - SIGVAL: FIX IHREP OPTION FOR INTERNAL COORDS.
C 13 DEC 93 - TLW - SIGEND: DIRECT TRANS. MCSCF SHOULD SKIP CANON CORE
C  9 DEC 93 - MWS - HESGES,UPDISP: CHANGE DAF RECORD NUMBER,
C                   HESGES: IMPLEMENT REDUND->SYMM COORDINATE HESSIAN
C  1 DEC 93 - MWS - HESGES: TRY FISCHER/ALMLOF FORMULAE
C 11 NOV 93 - JHJ - UPDISP: DAF RECORDS DEPEND ON USE OF SYM COORDS
C 22 SEP 93 - FJ  - ADD -TRIM/QA- AND -NR- TO -RFO- IN STANDARD METHOD
C  6 AUG 93 - MWS - ADD ATORQ TO /FGRAD/
C 16 JUL 93 - MWS - INCREASE MAXIMUM CI ROOTS TO 100
C  6 MAY 93 - PND - PRINTING OF CHEM3D MOVIE IN IRCDATA FILE.
C 28 APR 93 - TLW - FIX BUG PUNCHING HESSIANS
C 15 APR 93 - TLW - DISP: ADDED GETQ0 AND UPDISP ROUTINES TO ITERATE
C                   TRANSFORMING INTERNAL DISPLACEMENT TO CARTESIANS
C  3 APR 93 - TLW - HESSET,SIGINI: ADD PURIFY OPTION
C  1 APR 93 - PND - MODICATIONS FOR SEARCHES WITH EFFECTIVE FRAGMENTS.
C 29 MAR 93 - TLW - CHANGES FOR RECTANGULAR B AND B INVERSE
C 29 MAR 93 - MWS - SIGEND: ALWAYS PUNCH HESSIAN IF GEOM NOT CONV.
C 11 MAR 93 - FJ  - SIGINI,SIGX,SIGVAL,SIGEND: ADD VIRIAL SCALING
C 26 JAN 93 - MR  - SIGEND: PUNCH $VIB EVEN IF ONLY 1 GEOMETR
C 11 DEC 92 - MWS - CHANGE CALLS TO HESSX
C  7 DEC 92 - MR,MWS - SIGEND: MOVE $VIB PUNCH, CHANGE NPRT
C 24 OCT 92 - MWS - ADD PRINT/PUNCH CONTROL OPTION
C 15 JUN 92 - MWS - SIGX: TURN OFF PUNCH OF VIRTUAL ORBITALS
C  3 APR 92 - MWS,TLW - COMMON ENRGYS MADE PURE FLOATING POINT,
C                   DIVIDE OPTGRD INTO TWO DAF RECORDS
C 23 MAR 92 - MWS - SIGX: USE DYNAMIC STORAGE FOR COORD STEPS
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 25 FEB 92 - MWS - SIGEND: CHANGE FROM SYMTRZ TO SYMMOS
C 11 JAN 92 - TLW - PARALLEL I/O CHANGES
C 15 NOV 91 - MWS - SIGEND: USE CANMCV TO PRINT MCSCF ORBITALS.
C 29 OCT 91 - DRG - SIGVAL: CALL EFPCGD FOR EFP'S IN OPTIMIZATION.
C  2 SEP 91 - MWS - SIGX: PRINT TIMLIM IF TIME EXPIRES.
C 21 AUG 91 - MWS - SIGEND,SIGVAL,UPCOOR: ADD ICOORD TO /ZMTALT/
C 14 AUG 91 - TLW - SYMDR: ADDED FTR AND GTR TO COMMON SYMSPD
C 24 JUN 91 - MWS - OPTTOL CHANGED FROM 0.0005 TO 0.0001
C 29 MAY 91 - TRC - HESGES: ADD APARM AND DPARM FOR 6TH ROW ELEMENTS
C 16 MAY 91 - JAB - FIX BUG IN FINAL MCSCF ORBITAL OUTPUT
C 17 APR 91 - JAB - PUNCH HESSIAN ON EVERY GEOMETRY STEP,
C                   PRINT NO-S, OCC. NOS, AND CSF COEFS IN SIGEND
C  9 APR 91 - MR  - SAVE NPRINT FOR FINAL OUTPUT STAGE, PUNCH $VIB
C  1 MAR 91 - MWS - FIX BUG IN DOING HSSEND FINAL HESSIAN
C 20 FEB 91 - JAM - AVOID MOD 0 CALCULATION IN SIGVAL
C  5 FEB 91 - JAB - ADD IHREP=, HSSEND= TO $STATPT
C  9 NOV 90 - JHJ - UPCOOR,SIGVAL,SIGEND:FULLY SUBST. Z-MAT OPTION
C  3 NOV 90 - MWS - HESGES: FIX GLITCH WITH DUMMY ATOMS
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C  5 MAY 90 - MWS - PRINT AT MOST 10 NORMAL MODES IN BAKER SADPOINT,
C                   FIX BUG PREVENTING READING THAN 15 FROZ. COORDS
C  1 JAN 90 - MWS - IMPROVE ORBITAL PRINT/PUNCH IN SIGEND.
C  9 DEC 89 - MWS - CORRECT NUCLEAR CHARGES FOR ECP CASES.
C  6 NOV 89 - MWS - TRY TO IMPROVE EIGENVALUE TESTING IN BKRNR.
C 23 OCT 89 - MWS - DELETE /FROZNC/ AND /FUNCT/ SAVES
C 30 SEP 89 - MWS - IMPROVE 9090 DIAGNOSTIC IN DISPLC.
C 22 SEP 89 - MWS - CHANGE ANGSTROMS-BOHR CONVERSION FACTOR
C 20 JUN 89 - MWS - SIGEND: IMPROVE MESSAGES WHEN GEOM ISN'T CONVERGED
C 21 MAY 89 - MWS - BKRNR USES ABS(EIGEN) IN CAUTIOUS BRACKETING
C 22 MAR 89 - JAM - BKRNR CALLS PREVNL INSTEAD OF PREV
C 26 FEB 89 - STE - SIGINI: VARIABLE NAME IS NOT SCHLEGEL
C 24 FEB 89 - MWS - FIX BUG PREVENTING MODE FOLLOWING IN INTERNALS.
C 21 FEB 89 - STE - SIGX: DEL 9020 FORMAT, DISPLC: MOVE SAVE STATEMENT
C  6 FEB 88 - MWS - MESSED WITH COMPUTATION OF LAMDA IN BKRNR.
C 20 JAN 89 - MWS - RENAME -SIGMA- TO -STATPT-,
C                   COMBINE $SIGX AND $OPTX IN $STATPT GROUP,
C                   ADD HESS=,OPTTOL= TO $STATPT,
C                   DELETE RDHES ROUTINE AND USE FCMIN INSTEAD,
C                   CARTESIAN SEARCHES MUNG EIGENVALUES IN BKRNR,
C                   ALLOW GRADIENT AT INITIAL GEOMETRY TO BE READ IN
C 15 DEC 88 - MWS - INTRODUCE /SYMSHL/ AND /SYMSPD/ INTO SYMDR
C  2 NOV 88 - STE - MOVE SAVE IN DISPLC AHEAD OF COMMON STATEMENTS
C 15 OCT 88 - MWS - PAD OPTGRD TO FULLWORD BOUNDARY
C 26 AUG 88 - MWS - INCLUDE METHOD=BAKER, RENAME MOST ROUTINES,
C                   DOTMX TEST REMOVED, EXETYP=SIGX PRODUCES ALL DEBUG
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 27 JUL 88 - JAB - ADD EXTRA ARGUMENTS TO TFHF, TFHB CALLS.
C 19 MAY 88 - MWS - ABORT JOB IF CARTESIAN DISPLACEMENT IS RIDICULOUS.
C 30 MAY 88 - MWS - USE PARAMETERS TO DIMENSION COMMONS
C  8 MAY 88 - MWS - UP AO-S FROM 255 TO 2047
C  4 APR 88 - MWS - ABORT IF GLDIAG FAILS
C  2 DEC 87 - STE - SAVE NEW HESSIAN/COORDINATES AT STEP/TIME LIMIT
C 17 NOV 87 - STE - USE EXETYP; REMOVE REDUNDANT $SIGX READ; SAVE/FUNCT/
C 19 OCT 87 - STE - FIX NFRZ MISTAKE OF 21 AUG 87
C 21 AUG 87 - STE - SAVE /FROZNC/; REMOVE LOCAL IFREEZ FROM SIGINI
C  7 MAY 87 - STE - SIGX,SYMDR: ADD DEBUG PRINTOUT
C 30 APR 87 - STE - SCHNR,SCHNRM: CHANGE IA,SCR FOR USE BY GLDIAG
C 23 APR 87 - STE - RDHES:  CHANGE R*8 TO DOUBLE PRECISION
C 12 FEB 87 - MWS - CHANGE MSWRIT TO DAWRIT IN UPCOOR
C  4 NOV 86 - STE - RDHES: IMPROVE ERROR HANDLING, READ IC HESS IF
C                   $CONTRL/NHOPT=2; SIGEND CALLS PUHESS; PARAMETERS
C 11 JUL 86 - LAM - SAVE OPTGRD IN SIGEND
C  7 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS
C 25 JUN 86 - LAM - SAVE OPTGRD ON EVERY CYCLE
C 20 JUN 86 - MWS - TFHB CALL CORRECTED, LINEAR STEP COMPLETELY
C                   REMOVED, ALLOW OPTTOL RESET ON RESTARTS,
C                   OPTION TO AVOID HESSIAN UPDATING.
C 13 MAY 86 - LAM - IMPLEMENT CAPABILITY TO RESTART OPTIMIZATION
C                   CHANGES IN SIGINI, SIGEND, SIGX
C 10 NOV 85 - STE - USE GENERIC ABS,MAX,SIGN,SQRT AND BLAS
C                   REPLACE SETXBK,SETXFW WITH DCOPY
C  7 NOV 85 - LAM - PRINT INTERNUCLEAR DISTANCES FOR ALL NSERCH IN
C                   SIGVAL, UPDATE COORDINATES IN DAF IN UPCOOR
C  3 AUG 85 - MWS - CHANGE BADGER'S RULE PARAMETERS
C 25 FEB 85 - MWS - IMPLEMENT SCHLEGEL'S INTERNAL COORDINATE HESSIAN
C  5 MAY 84 - STE - CHANGE ENERGY DATA IN DICT. RECORD 2
C  8 MAR 84 - STE - ZERO FC ELEMENTS FOR FROZEN COORDINATES CORRECTLY
C 19 JAN 84 - STE - SCFOPT COMMON MISSING MCONV IN SIGEND AND SIGVAL
C 27 DEC 83 - STE - SIGINI NEEDS /OPTOPT/, $SIGX(DOTMX)
C  3 DEC 83 - STE - REMOVE/DEFINE UNDEFINED VARIABLES IN SIGINI
C  7 NOV 83 - STE - CHANGE CONVERGE TEST IN DISPLC FROM RMS/5 TO RMS/3
C  4 NOV 83 - STE - CHANGE ZMATPR AND ZGMATP TO PZANDG
C                   DELETE CODE TO FIX C.O.M. IN DISPLC
C  6 JUL 83 - MWS - EASE TEST FOR SYMMETRY LOSS IN DISPLACEMENT
C  8 JUN 83 - MWS - MAKE THIS PACKAGE ALSO DO GEOMETRY OPTS
C 23 MAR 83 - MWS - COMPUTE PROPERTIES AT FINAL GEOMETRY
C  9 MAR 83 - MWS - KILL MAJOR BUG IN DXCORR, EXTENSIVE CLEANUP,
C                   PRINT MORE SEARCH INFO, INTRNL COORD HESS,
C                   STOP ON INSUFFICIENT TIME, DUMPING HESSIAN
C 15 DEC 82 - MWS - CLEAN UP FINAL OUTPUT
C 21 OCT 82 - MWS - ADD DMY ARGUMENTS TO NAMEIO CALL
C  4 OCT 82 - MWS - CONVERT FOR THE IBM
C  2 JUN 82 - DFF - ALLOW CART. COORDS IN SCHSAV
C
C*MODULE STATPT  *DECK BKRFOL
      SUBROUTINE BKRFOL(NEWMOD,NCVAL,VEC,TOVLP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VEC(NCVAL,NCVAL)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXATM=2000, MXFRG=1050)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- FOLLOW THE SAME MODE AS IN PREVIOUS STEPS -----
C
C     ON THE FIRST STEP SIMPLY DETERMINE WHICH MODE TO FOLLOW
C
      IF(NSERCH.EQ.0) THEN
         IT=IFOLOW
         IF (MASWRK) WRITE(IW,9000) IFOLOW
C
C     ON SUBSEQUENT STEPS DETERMINE WHICH HESSIAN EIGENVECTOR HAS
C     THE GREATEST OVERLAP WITH THE MODE WE ARE FOLLOWING
C
      ELSE
         IT=1
         TOVLP=DDOT(NCVAL,VMODE,1,VEC(1,1),1)
         TOVLP=ABS(TOVLP)
         DO 110 I=2,NCVAL
            OVLP=DDOT(NCVAL,VMODE,1,VEC(1,I),1)
            OVLP=ABS(OVLP)
            IF(OVLP.GT.TOVLP) THEN
               TOVLP=OVLP
               IT=I
            END IF
  110    CONTINUE
         IF (MASWRK) WRITE(IW,9010) IT,TOVLP
      END IF
C
C     SAVE THE EIGENVECTOR BEING FOLLOWED IN VMODE
C
      DO 200 I=1,NCVAL
         VMODE(I)=VEC(I,IT)
  200 CONTINUE
      NEWMOD=IT
      RETURN
C
 9000 FORMAT(10X,'HESSIAN MODE FOLLOWING SWITCHED ON,',
     *     ' FOLLOWING MODE ',I3)
 9010 FORMAT(10X,'OVERLAP OF CURRENT MODE',I4,
     *          ' WITH PREVIOUS MODE IS ',F12.6)
      END
C*MODULE STATPT  *DECK BKRNR
      SUBROUTINE BKRNR(IMTH,NCVAL,NCVF,OUT,STPT,STSTEP,PROJCT,
     *                 FC,A,VEC,SCR,EIGEN,FX,IA,
     *                 GTOT,BUF1,BUF2,RM,FRGMI,COMC)
C
C     ----- NOTE THAT -A- AND -FC- ARE EQUIVALENCED BY CALL -----
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOPARR,MASWRK,DSKWRK,EFLDL,PRJROT,STPT
      LOGICAL PROJCT
C
      DIMENSION VEC(NCVF,NCVF),A(NCVF,NCVF),FC(*),SCR(8,NCVF),
     *          EIGEN(NCVF),IA(NCVF),FX(NCVF),GTOT(NCVF),
     *          BUF1(NCVAL,NCVAL),BUF2(NCVAL,NCVAL),
     *          RM(NCVAL),FRGMI(6,*),COMC(NCVAL)
      DIMENSION CMASS(3)
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      SAVE DEPRE,OLDE,NOLDS
C
      COMMON /EFLDC / EVEC(3),EFLDL
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FJUNK(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 /FROZNC/ JFRZ(3*MXATM),NFRZ
      COMMON /FUNCT / ENERGY,F(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 /MACHSW/ KDIAG,ICORFL,IXDR
      COMMON /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, THREE=3.0D+00,
     *           FOUR=4.0D+00, HALF=0.5D+00,
     *           TMSIX=1.0D-06, TMONE=1.0D-01, PT75=0.75D+00)
      DATA DEPRE,OLDE,NOLDS/0.0D+00,0.0D+00,-1/
C
C     ----- MAIN DRIVER FOR EIGENVECTOR FOLLOWING -----
C     -NCVAL- IS DIMENSION OF INTERNAL OR CARTESIAN SPACE
C     -NCVF- ADDS IN 6 EXTRA DIMENSIONS FOR EACH EFFECTIVE FRAGEMENT.
C     IMTH = 1 : NR  ALGORITHM
C     IMTH = 2 : RFO ALGORITHM
C     IMTH = 3 : QA  ALGORITHM
C
      TRTOL = 1.0D-09
      IF(NFRG.GT.0) TRTOL=1.0D-10
C
C  MAKE ONE ARRAY FOR BOTH REGULAR GRADIENT AND FRAGMENT GRADIENT
C
      DO 320 I=1,NCVAL
         GTOT(I)=F(I)
  320 CONTINUE
C     WRITE(6,*)'ME,NSERCH,DEFT,TORQ',ME,NSERCH,DEFT(2,1),TORQ(2,1)
      I=NCVAL+1
      DO 321 INF=1,NFRG
         GTOT(I)=DEFT(1,INF)
         GTOT(I+1)=DEFT(2,INF)
         GTOT(I+2)=DEFT(3,INF)
         GTOT(I+3)=TORQ(1,INF)
         GTOT(I+4)=TORQ(2,INF)
         GTOT(I+5)=TORQ(3,INF)
         I=I+6
 321  CONTINUE
C
      IF(NZVAR.EQ.0) THEN
C
C        ----- PROJECT OUT T,R MODES -----
C        USE UNIT MASSES TO PROJECT OUT DIRECTLY IN CARTESIANS
C
         LRM=3*NAT+21*NFRG
         LFRG=6*NFRG
         CALL VCLR(RM,1,LRM)
         CALL VCLR(FRGMI,1,LFRG)
         I0=1
         DO 10 I=1,3*(NAT+NFRG)
            RM(I0  ) = ONE
            I0=I0+1
   10    CONTINUE
         I0=3*(NAT+NFRG)+1
         I1=3*(NAT+4*NFRG)+1
         DO 20 I=1,NFRG
            RM(I0  ) = ONE
            RM(I0+4) = ONE
            RM(I0+8) = ONE
            RM(I1  ) = ONE
            RM(I1+4) = ONE
            RM(I1+8) = ONE
            FRGMI(1,I) = ONE
            FRGMI(3,I) = ONE
            FRGMI(6,I) = ONE
            I0=I0+9
            I1=I1+9
   20    CONTINUE
         ZMASST=NAT+NFRG
C
         CALL VCLR(CMASS,1,3)
         DO 40 I=1,NAT
            DO 30 J=1,3
               CMASS(J)=CMASS(J)+C(J,I)
   30       CONTINUE
   40    CONTINUE
         DO 45 I=1,NFRG
            DO 44 J=1,3
               CMASS(J)=CMASS(J)+EFCENT(J,I)
   44       CONTINUE
   45    CONTINUE
         DO 50 I=1,3
            CMASS(I)=CMASS(I)/ZMASST
   50    CONTINUE
C
         KK=0
         DO 70 I=1,NAT
            DO 60 J=1,3
               KK=KK+1
               COMC(KK) = C(J,I)-CMASS(J)
   60       CONTINUE
   70    CONTINUE
         DO 90 I=1,NFRG
            DO 80 J=1,3
               KK=KK+1
               COMC(KK) = EFCENT(J,I)-CMASS(J)
   80       CONTINUE
   90    CONTINUE
C
         CALL DAREAD(IDAF,IODA,FC,NCVF*NCVF,4,0)
         PRJROT = .NOT.EFLDL
         IF (PROJCT) CALL PRJFC(.FALSE.,PRJROT,ZMASST,FC,D,COMC,
     *                          RM,FRGMI,BUF1,BUF2,NAT,NCVAL,NCVF)
      ELSE
C
C           READ AND SYMMETRIZE THE INTERNAL COORDINATE F.C.M.
C           IF A COORDINATE IS FROZEN, ZERO ITS OFF DIAGONAL
C           HESSIAN ELEMENTS, AND LEVEL SHIFT IT AWAY.
C           NOTE THAT FRAGMENT POSITIONS CANNOT BE FROZEN!
C
         CALL DAREAD(IDAF,IODA,FC,NCVF*NCVF,43,0)
         DO 130 I = 1,NCVAL
            DO 120 J = 1,I
               AVE = (A(I,J) + A(J,I))*HALF
               IF(JFRZ(I).EQ.1) AVE = ZERO
               IF(JFRZ(J).EQ.1) AVE = ZERO
               A(I,J) = AVE
               A(J,I) = AVE
  120       CONTINUE
            IF(JFRZ(I).EQ.1) A(I,I) = 24.0D+00 + I*0.02D+00
  130    CONTINUE
      END IF
C
C     ----- OBTAIN CURRENT NORMAL MODE DIRECTIONS -----
C
      IJ = 0
      DO 150 I = 1,NCVF
         DO 140 J = 1,I
            IJ = IJ + 1
            FC(IJ) = A(J,I)
  140    CONTINUE
  150 CONTINUE
C
      IF(OUT) WRITE(IW,9000)
      IF(OUT) CALL PRTRI(FC,NCVF)
C
C     KDIAG=0 WAS FOUND TO BE FAILING FREQUENTLY WITH FMO OPTIMISATIONS.
C     IT IS NOT KNOWN WHETHER THE REASON HAS SOMETHING TO DO WITH FMO
C     ITSELF OR WITH THE MOLECULAR SIZE.
      KDIAGS=KDIAG
      IF(KDIAGH.GE.0) KDIAG=KDIAGH
      CALL GLDIAG(NCVF,NCVF,NCVF,FC,SCR,EIGEN,VEC,IERR,IA)
      KDIAG=KDIAGS
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'GLDIAG FAILURE IN -BKRNR-'
         CALL ABRT
      END IF
C
C     SHIFT T, R MODES TO BE THE LAST 6(5)
C
      IF(NZVAR.EQ.0 .AND. PROJCT) THEN
         NTR=0
         DO 151 I=NCVF,1,-1
            IF(ABS(EIGEN(I)).LT.TRTOL) NTR=NTR+1
            IF(ABS(EIGEN(I)).LT.TRTOL) ISHIFT=I
  151    CONTINUE
         N5OR6 = 5
         IF(EFLDL) N5OR6 = 2
         IF (NTR.NE.N5OR6 .AND. NTR.NE.N5OR6+1 .AND. PROJCT) THEN
            IF(MASWRK) WRITE(IW,9080) NTR,(EIGEN(I),I=1,NCVF)
C  ---- LVS PATCH FOR MC RUNS
            IF (NACC .EQ. 0) THEN
               IF(MASWRK) WRITE(IW,9081)
               CALL ABRT
            ELSE
               IDPUNC = 1
               IF(MASWRK) WRITE(IW,9082)
               RETURN
            END IF
         END IF
         JSHIFT=ISHIFT-1
         DO 153 J=1,NTR
            JSHIFT=JSHIFT+1
            SCR(8,J)=EIGEN(JSHIFT)
            DO 152 I=1,NCVF
               SCR(J,I)=VEC(I,JSHIFT)
  152       CONTINUE
  153    CONTINUE
         DO 155 J=ISHIFT,NCVF-NTR
            EIGEN(J)=EIGEN(J+NTR)
            DO 154 I=1,NCVF
               VEC(I,J)=VEC(I,J+NTR)
  154       CONTINUE
  155    CONTINUE
         JTMP=0
         DO 157 J=NCVF-NTR+1,NCVF
            JTMP=JTMP+1
            EIGEN(J)=SCR(8,JTMP)
            DO 156 I=1,NCVF
               VEC(I,J)=SCR(JTMP,I)
  156       CONTINUE
  157    CONTINUE
      END IF
      IF(OUT) WRITE(IW,9010)
      IF(OUT) CALL PREVNL(VEC,EIGEN,NCVF,NCVF,NCVF)
C
C     ----- PRINT (UP TO 10) INITIAL MODES FOR SADPOINT RUNS -----
C
      IF(NSERCH.EQ.0  .AND.  NNEG.GT.0 .AND. MASWRK) THEN
         WRITE(IW,9012)
         KMAX = MIN(2,1 + (NCVF-1)/5)
         DO 170 K=1,KMAX
            MINJ = 5*(K-1) + 1
            MAXJ = MIN(K*5,NCVF)
            WRITE(IW,9013)
            WRITE(IW,9014) (I,I=MINJ,MAXJ)
            WRITE(IW,9015) (EIGEN(I),I=MINJ,MAXJ)
            WRITE(IW,9014)
            DO 160 I=1,NCVF
               WRITE(IW,9016) I,(VEC(I,J),J=MINJ,MAXJ)
  160       CONTINUE
  170    CONTINUE
      END IF
C
      IF (STPT) THEN
         ITMP=ABS(IFOLOW)
         IF(OUT) WRITE(IW,9020) STSTEP,IFOLOW,EIGEN(ITMP)
         TEST=ZERO
         DO 175 I=1,NCVF
            VMODE(I)=VEC(I,ITMP)
            IF (ABS(VMODE(I)).GT.(ABS(TEST)+1.0D-06))TEST=VMODE(I)
  175    CONTINUE
         IF(TEST.LT.ZERO)CALL DSCAL(NCVF,-ONE,VMODE,1)
         IF(IFOLOW.LT.ZERO)CALL DSCAL(NCVF,-ONE,VMODE,1)
         IF(OUT) WRITE(IW,9021) (VMODE(I),I=1,NCVF)
         IF(ABS(EIGEN(ITMP)).LT.1.0D-09) THEN
            IF(MASWRK) WRITE(IW,9022)
            CALL ABRT
         END IF
         CALL DCOPY(NCVF,VMODE,1,D,1)
         CALL DSCAL(NCVF,STSTEP,D,1)
         RADIUS=STSTEP
         IFOLOW=ABS(IFOLOW)
         STPT = .FALSE.
         RETURN
      END IF
C
      NEG=0
      DO 200 I = 1,NCVF
         IF(ABS(EIGEN(I)).LT.TMSIX) EIGEN(I)=ZERO
         IF(EIGEN(I).LT.ZERO) NEG = NEG+1
  200 CONTINUE
      IF(OUT) WRITE(IW,9051) NEG
C
C---      IF(MASWRK  .AND.  NEG.NE.NNEG .AND. IMTH.NE.1) THEN
C---         WRITE(IW,9050) NEG
C---         N = 0
C---         DO 310 I=1,NCVF
C---            IF(EIGEN(I).EQ.ZERO) GO TO 310
C---            N=N+1
C---            IF(N.LE.NNEG  .OR.  EIGEN(I).LT.ZERO)
C---     *         WRITE(IW,9052) N,EIGEN(I)
C---            IF(N.GT.NNEG  .AND.  EIGEN(I).LT.ZERO  .OR.
C---     *         N.LE.NNEG  .AND.  EIGEN(I).GT.ZERO) THEN
C---               WRITE(IW,9053)
C---               WRITE(IW,9054) (VEC(J,I),J=1,NCVF)
C---            END IF
C---  310    CONTINUE
C---      END IF
C--- 9051 FORMAT(10X,'CURRENT HESSIAN HAS',I5,1X,'NEGATIVE EIGENVALUES')
C--- 9052 FORMAT(1X,'LOCAL CURVATURE',I4,
C---     *          ' OF THE APPROXIMATE HESSIAN HAS EIGENVALUE=',F12.6)
C--- 9053 FORMAT(1X,'*** THIS MODE HAS AN INCORRECT CURVATURE ***'/
C---     *       1X,'THE COMPONENTS OF THIS MODE FOLLOWS:')
C--- 9054 FORMAT(1X,5F15.6)
C
      IF(MASWRK  .AND. IMTH.NE.1  .AND.  NPRTGO.GT.-1) THEN
         N = 0
         IF (NNEG.EQ.0) THEN
            DO 310 I=1,NCVF
               IF(EIGEN(I).EQ.ZERO) GO TO 310
               N=N+1
               IF(EIGEN(I).LT.ZERO .AND. NPRTGO.NE.2) THEN
                  WRITE(IW,9052) N,EIGEN(I)
                  WRITE(IW,9053)
                  WRITE(IW,9054) (VEC(J,I),J=1,NCVF)
               END IF
 310        CONTINUE
         ELSE IF (NNEG.EQ.1) THEN
            DO 315 I=1,NCVF
               IF(EIGEN(I).EQ.ZERO) GO TO 315
               N=N+1
               IF(N.NE.IFOLOW .AND. EIGEN(I).LT.ZERO .OR.
     *            N.EQ.IFOLOW .AND. EIGEN(I).GT.ZERO ) THEN
                  WRITE(IW,9052) N,EIGEN(I)
                  WRITE(IW,9053)
                  WRITE(IW,9054) (VEC(J,I),J=1,NCVF)
               END IF
 315        CONTINUE
         ELSE IF (IFOLOW.GE.NNEG) THEN
            DO 319 I=1,NCVF
               IF(EIGEN(I).EQ.ZERO) GO TO 319
               N=N+1
               IF((N.GT.(NNEG-1).AND.N.NE.IFOLOW.AND.EIGEN(I).LT.ZERO)
     *        .OR.(N.GT.(NNEG-1).AND.N.EQ.IFOLOW.AND.EIGEN(I).GT.ZERO)
     *        .OR.(N.LE.(NNEG-1).AND.EIGEN(I).GT.ZERO)) THEN
                  WRITE(IW,9052) N,EIGEN(I)
                  WRITE(IW,9053)
                  WRITE(IW,9054) (VEC(J,I),J=1,NCVF)
               END IF
 319        CONTINUE
         ELSE
            DO 325 I=1,NCVF
               IF(EIGEN(I).EQ.ZERO) GO TO 325
               N=N+1
               IF((N.GT.NNEG.AND.EIGEN(I).LT.ZERO)
     *        .OR.(N.LE.NNEG.AND.EIGEN(I).GT.ZERO)) THEN
                  WRITE(IW,9052) N,EIGEN(I)
                  WRITE(IW,9053)
                  WRITE(IW,9054) (VEC(J,I),J=1,NCVF)
               END IF
 325        CONTINUE
         END IF
      END IF
 9051 FORMAT(10X,'CURRENT HESSIAN HAS',I5,1X,'NEGATIVE EIGENVALUES')
 9052 FORMAT(1X,'LOCAL CURVATURE',I4,
     *          ' OF THE APPROXIMATE HESSIAN HAS EIGENVALUE=',F12.6)
 9053 FORMAT(1X,'*** THIS MODE HAS AN INCORRECT CURVATURE ***'/
     *       1X,'THE COMPONENTS OF THIS MODE FOLLOWS:')
 9054 FORMAT(1X,5F15.6)
C
C     ----- PROJECT GRADIENT ONTO EACH NORMAL MODE -----
C
      DO 400 I=1,NCVF
         FX(I)=DDOT(NCVF,GTOT,1,VEC(1,I),1)
         IF(EIGEN(I).EQ.ZERO) FX(I) = ZERO
  400 CONTINUE
C
C     OLDE = 0 INDICATE THAT PREVIOUS POINT HAD STPT=.TRUE.
      IF(NSERCH.GT.0 .AND. OLDE.NE.ZERO) THEN
         DEACT = ENERGY-OLDE
         RATIO = DEACT/DEPRE
         IF(MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9060) DEACT,DEPRE,RATIO
C
         IF (NOLDS.EQ.NSERCH) GO TO 401
C
         IF(ITRUPD.EQ.1) THEN
C
C           THE STARTING POINT FOR DXMAXT IS THE PREVIOUS VALUE
C           IF THIS WAS A GOOD STEP, INCREASE THE ALLOWED STEP LENGTH
C           REDUCE IT IF IT WAS A POOR STEP
C
            DXMAXT=RADIUS
            IF (RATIO.LE.TMONE .OR. RATIO.GE.THREE)
     *          DXMAXT=DXMAXT/TWO
            IF (RATIO.GE.PT75 .AND. RATIO.LE.(FOUR/THREE))
     *          DXMAXT=DXMAXT*SQRT(TWO)
C
C           BE BRAVE IF  0.90 < RATIO < 1.10
C
            IF (ABS(RATIO-ONE).LT.TMONE) DXMAXT=DXMAXT*SQRT(TWO)
            DXMAXT=MAX(DXMAXT,TRMIN)
            DXMAXT=MIN(DXMAXT,TRMAX)
         END IF
      END IF
  401 CONTINUE
C
      CALL BKRFNR(IMTH,EIGEN,FX,VEC,NCVF,OUT,XLAMD,XLAMD0)
C
C     CALCULATE PREDICTED ENERGY CHANGE
C
      SCALE=ONE
      IF (RADIUS.GT.DXMAXT .AND. IMTH.NE.1) SCALE = DXMAXT/RADIUS
      DEPRE=ZERO
      DO 500 I=1,NCVF
         XTMP=XLAMD
         IF(NNEG.NE.0 .AND. I.EQ.IFOLOW) XTMP=XLAMD0
         IF(ABS(XTMP-EIGEN(I)).LT.TMSIX) THEN
            SS=ZERO
         ELSE
            SS=FX(I)/(XTMP-EIGEN(I))
         END IF
         SS = SS*SCALE
         TMP=SS*FX(I) + HALF*SS*SS*EIGEN(I)
         DEPRE=DEPRE+TMP
  500 CONTINUE
      OLDE  = ENERGY
      NOLDS=NSERCH
      RETURN
C
 9000 FORMAT(16X,'FORCE CONSTANT MATRIX')
 9010 FORMAT(/10X,39HFORCE CONSTANT EIGENVALUES AND VECTORS ,/)
 9012 FORMAT(10X,'THE FIRST FEW LOCAL MODES AND EIGENVALUES ARE')
 9013 FORMAT(1X)
 9014 FORMAT(1X,' MODE',5I12)
 9015 FORMAT(6X,5F12.6)
 9016 FORMAT(1X,I3,2X,5F12.6)
 9020 FORMAT(/,10X,'INPUT GEOMETRY TAKEN AS STATIONARY',/,
     *       10X,'GENERATING INITIAL GEOMETRY BY TAKING A STEP OF',
     *       F8.5,1X,'ALONG HESSIAN MODE',I3,/,
     *       10X,'WITH EIGENVALUE',F10.6,1X,'AND COMPONENTS')
 9021 FORMAT(9F10.5)
 9022 FORMAT(/,10X,'TRYING TO FOLLOW MODE WITH EIGENVALUE = 0',/,
     *       10X,'MAYBE THIS IS A TRANSLATIONAL OR ROTATIONAL MODE?')
 9060 FORMAT(10X,'   ACTUAL ENERGY CHANGE WAS',F15.10/
     *       10X,'PREDICTED ENERGY CHANGE WAS',F15.10,' RATIO=',F7.3)
 9080 FORMAT(1X,'*** ERROR! THERE ARE NOT 5 OR 6 TRANS/ROT MODES',
     *          ' NUM T/R=',I5,' EIGENVALUES='/
     *       (1X,5F15.10))
 9081 FORMAT(1X,'THE CAUSE OF THIS IS OFTEN CORRUPTION OF THE HESSIAN'/
     *       1X,'MATRIX AFTER MANY STEPS.  THE FIX MAY BE AS SIMPLE AS'/
     *       1X,'RESTARTING THE COMPUTATION, OR MIGHT REQUIRE THAT YOU'/
     *       1X,'CONSIDER CHANGING THE COORDINATES BEING USED.')
 9082 FORMAT(1X,'CONTINUE...')
      END
C*MODULE STATPT  *DECK BKRFNR
      SUBROUTINE BKRFNR(IMTH,EIGEN,FX,VEC,NCVF,OUT,XLAMD,XLAMD0)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION LAMDA,LAMDA0
C
      LOGICAL OUT,GOPARR,DSKWRK,MASWRK,FRODO1,FRODO2,LSCAL
C
      DIMENSION EIGEN(NCVF),FX(NCVF),VEC(NCVF,NCVF)
C
      PARAMETER (MXATM=2000, MXFRG=1050)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
C
      PARAMETER (ZERO=0.0D+00, FOUR=4.0D+00, HALF=0.5D+00, STEP=1.0D-03,
     *           BIG=1.0D+03, EPS=1.0D-16, TEN=1.0D+01, TMSIX=1.0D-06,
     *           TOLL=1.0D-10, SFIX=1.0D-02, TWO=2.0D+00)
C
C     FORM THE GEOMETRY STEP BY EITHER PURE NR, P-RFO OR TRIM/QA
C     ALGORITHM DEPENDING ON IMTH=1,2,3. FOR QA AND RFO THE RETURNED
C     STEPLENGTH IS LESS THAN OR EQUAL TO DXMAXT
C
      IT=0
      JT=1
      LSCAL=.FALSE.
      IF (IMTH.EQ.2) LSCAL=.TRUE.
      EIGIT = ZERO
      IF(NNEG.NE.0) THEN
C
C        ON RETURN FROM BKRFOL, NEWMOD IS THE MODE
C        ALONG WHICH THE ENERGY IS TO BE MAXIMIZED
C
         CALL BKRFOL(NEWMOD,NCVF,VEC,TOVLP)
C        ADJUST TRUST RADIUS FOR TS SEARCH IF OVERLAP IS SMALL
         IF (NSERCH.GT.0 .AND. ITRUPD.EQ.1) THEN
            IF (TOVLP.LT.0.90D+00) DXMAXT=RADIUS/SQRT(TWO)
            IF (TOVLP.LT.0.90D+00  .AND.  OUT) WRITE(IW,9030)0.90D+00
            IF (TOVLP.LT.0.80D+00) DXMAXT=DXMAXT/SQRT(TWO)
            IF (TOVLP.LT.0.80D+00  .AND.  OUT) WRITE(IW,9030)0.80D+00
            IF (TOVLP.LT.0.70D+00) DXMAXT=DXMAXT/SQRT(TWO)
            IF (TOVLP.LT.0.70D+00  .AND.  OUT) WRITE(IW,9030)0.70D+00
            DXMAXT=MAX(DXMAXT,TRMIN)
            DXMAXT=MIN(DXMAXT,TRMAX)
            IF (TOVLP.LT.0.90D+00  .AND.  OUT) WRITE(IW,9031)DXMAXT
         END IF
         IF(NEWMOD.NE.IFOLOW .AND. MASWRK) WRITE(IW,9070)
     *      IFOLOW,NEWMOD
         IFOLOW=NEWMOD
         IT=IFOLOW
         EIGIT=EIGEN(IT)
         IF (EIGIT.EQ.ZERO) THEN
            IF(MASWRK) WRITE(IW,9080)
            CALL ABRT
         END IF
         IF (MASWRK) THEN
            WRITE(IW,9110) IT,EIGEN(IT)
            WRITE(IW,9120) (VEC(J,IT),J=1,NCVF)
         END IF
      END IF
C
C     JT SHOULD BE LOWEST MODE WHICH IS NOT THE TS-MODE AND NOT T,R
C     MODES IN CARTESIAN COORDINATES. ALSO CHECK TO SEE IF THE SO
C     CHOSEN JT HAS A FX VALUE THAT ENSURE THAT THERE WILL BE A
C     SOLUTION THE LAMDA EQUATION WITHIN THE NUMERICAL ACCURACY.
C
      JST=1
   90 CONTINUE
      DO 100 I=JST,NCVF
      IF(OUT) WRITE(IW,*) 'SEARCH FOR JT,I,IT,EIG',I,IT,EIGEN(I)
         IF(I.NE.IT .AND. EIGEN(I).NE.ZERO) THEN
            JT=I
            GO TO 110
         END IF
  100 CONTINUE
C
  110 CONTINUE
      EONE=EIGEN(JT)
      IF(OUT) WRITE(IW,*) 'JT,EONE,FX(JT)',JT,EONE,FX(JT)
      SSMIN=MAX(ABS(EONE)*EPS,(TEN*EPS))
      SSMAX=MAX(BIG,ABS(EONE))
      SSMAX=SSMAX*BIG
      IF(OUT) WRITE(IW,*) 'EONE,SSMIN,SSMAX,TOLL',EONE,SSMIN,SSMAX,TOLL
      TST=SQRT(SSMIN*ABS(EONE))
      IF( (EONE.LT.ZERO .AND. ABS(FX(JT)).LT.TST) .OR.
     *    (ABS(FX(JT)).LT.TST*1.0D-05) ) THEN
         IF(OUT) WRITE(IW,*) ' FX(JT) TOO SMALL, TRYING NEW JT'
         JST=JT+1
         IF(JST.GT.NCVF) CALL ABRT
         GO TO 90
      END IF
      D2MAX=DXMAXT*DXMAXT
C
      LAMDA0= ZERO
      LAMDA = ZERO
      FRODO1=.FALSE.
      FRODO2=.FALSE.
      IF (IMTH.EQ.1) GO TO 200
C
      ETMP=ZERO
      DO 115 I=1,NCVF
         IF (I.NE.IT .AND. EIGEN(I).LT.ZERO) ETMP=EIGEN(I)
  115 CONTINUE
      IF (NNEG.NE.0 .AND. EIGIT.LT.ZERO .AND. ETMP.GE.ZERO) THEN
         IF(MASWRK) WRITE(IW,9150)
         GO TO 200
      END IF
      IF (NNEG.EQ.0 .AND. EONE.GE.ZERO) THEN
         IF(MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9160)
         GO TO 200
      END IF
      IF (IMTH.EQ.3) GO TO 300
  120 IF (NNEG.NE.0) THEN
         LAMDA0=EIGEN(IT)+SQRT(EIGEN(IT)**2+FOUR*FX(IT)**2)
         LAMDA0=LAMDA0*HALF
         IF(NCVF.EQ.1) GO TO 200
      END IF
      SSTEP = STEP
      IF(EONE.LE.ZERO) LAMDA=EONE-SSTEP
      IF(EONE.GT.ZERO) SSTEP=EONE
      IF(EONE.GT.ZERO) LAMDA=-SSTEP
      BULI = EONE
      IF (EONE.GT.ZERO) BULI=ZERO
      BL = LAMDA - SSTEP
      BU = LAMDA + SSTEP*HALF
  130 FL = ZERO
      FU = ZERO
      DO 140 I = 1,NCVF
         IF (I.EQ.IT) GO TO 140
         FL   = FL + (FX(I)*FX(I))/(BL-EIGEN(I))
         FU   = FU + (FX(I)*FX(I))/(BU-EIGEN(I))
  140 CONTINUE
      FL = FL - BL
      FU = FU - BU
C        WRITE(IW,*)'BL,BU,FL,FU FROM BRACK'
C        WRITE(IW,668)BL,BU,FL,FU
C668     FORMAT(6F20.15)
      IF (FL*FU .LT. ZERO) GO TO 150
      BL = BL - (EONE-BL)
      BU = BU + HALF*(BULI-BU)
      IF (BL.LE.-SSMAX) THEN
         BL = -SSMAX
         FRODO1=.TRUE.
      END IF
      IF (ABS(BULI-BU).LE.SSMIN) THEN
         BU = BULI-SSMIN
         FRODO2=.TRUE.
      END IF
      IF (FRODO1.AND.FRODO2) THEN
         IF(MASWRK) WRITE(IW,9200) EONE,BL,BU,FL,FU
         IF(MASWRK) WRITE(IW,9210)
         GO TO 300
      END IF
      GO TO 130
  150 CONTINUE
      NCNT = 0
      XLAMDA = ZERO
  160 CONTINUE
      FL = ZERO
      FU = ZERO
      FM = ZERO
      LAMDA = HALF*(BL+BU)
      DO 170 I = 1,NCVF
         IF (I.EQ.IT) GO TO 170
         FL   = FL + (FX(I)*FX(I))/(BL-EIGEN(I))
         FU   = FU + (FX(I)*FX(I))/(BU-EIGEN(I))
         FM   = FM + (FX(I)*FX(I))/(LAMDA-EIGEN(I))
  170 CONTINUE
      FL = FL - BL
      FU = FU - BU
      FM = FM - LAMDA
C        WRITE(IW,*)'BL,BU,LAMDA,FL,FU,FM FROM SEARCH'
C        WRITE(IW,668)BL,BU,LAMDA,FL,FU,FM
      IF (ABS(XLAMDA-LAMDA).LT.TOLL) GO TO 200
      NCNT = NCNT + 1
      IF (NCNT.GT.1000) THEN
         IF(MASWRK) WRITE(IW,9220) BL,BU,LAMDA,FL,FU
         CALL ABRT
      END IF
      XLAMDA = LAMDA
      IF (FM*FU.LT.ZERO) BL = LAMDA
      IF (FM*FL.LT.ZERO) BU = LAMDA
      GO TO 160
C
C
C     ----- CALCULATE THE STEP -----
C
  200 CONTINUE
      CALL VCLR(D,1,NCVF)
      DO 230 I=1,NCVF
         IF (LAMDA.EQ.ZERO .AND. ABS(EIGEN(I)).LT.TMSIX) THEN
            TEMP=ZERO
         ELSE
            IF (ABS(LAMDA-EIGEN(I)).LT.TMSIX) THEN
               TEMP=ZERO
            ELSE
               TEMP=FX(I)/(LAMDA-EIGEN(I))
            END IF
         END IF
         IF (I.EQ.IT) THEN
            IF (ABS(LAMDA0-EIGEN(IT)).LT.TMSIX) THEN
               TEMP=ZERO
            ELSE
               TEMP=FX(IT)/(LAMDA0-EIGEN(IT))
            END IF
         END IF
         IF (OUT) WRITE(IW,*)'BKRFNR, DELTA STEP',I,TEMP
         DO 220 J=1,NCVF
            D(J)=D(J)+TEMP*VEC(J,I)
  220    CONTINUE
  230 CONTINUE
      DD = SQRT(DDOT(NCVF,D,1,D,1))
      IF(LAMDA.EQ.ZERO .AND. LAMDA0.EQ.ZERO) THEN
            IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9250) DD
      ELSE
         IF(LAMDA.NE.ZERO .AND. LAMDA0.NE.-LAMDA) THEN
            IF (MASWRK .AND. NNEG.NE.0) WRITE(IW,9171) LAMDA0
            IF (MASWRK) WRITE(IW,9131) LAMDA
            IF (MASWRK) WRITE(IW,9260) DD
         ELSE
            IF (MASWRK .AND. NNEG.NE.0) WRITE(IW,9172) LAMDA0
            IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9132) LAMDA
            IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9270) DD
         END IF
      END IF
      IF (DD.LT.(DXMAXT+TMSIX) .OR. IMTH.EQ.1) THEN
         XLAMD=LAMDA
         XLAMD0=LAMDA0
         RADIUS=DD
         RETURN
      END IF
      IF (LAMDA.EQ.ZERO .AND. LAMDA0.EQ.ZERO
     *                  .AND. IMTH.EQ.2) GO TO 120
      IF (LAMDA.EQ.ZERO .AND. LAMDA0.EQ.ZERO
     *                  .AND. IMTH.EQ.3) GO TO 300
      IF (LSCAL) THEN
         XLAMD=LAMDA
         XLAMD0=LAMDA0
         RADIUS=DD
         RETURN
      END IF
  300 LAMDA=ZERO
      FRODO1=.FALSE.
      FRODO2=.FALSE.
      SSTEP = STEP
      BULI = EONE
      IF (-EIGIT.LT.BULI) BULI = -EIGIT
      IF (BULI.GT.ZERO) BULI = ZERO
      IF (BULI.LE.ZERO) LAMDA = BULI-SSTEP
      LAMDA = BULI - SSTEP
      BL = LAMDA - SSTEP
      BU = LAMDA + SSTEP*HALF
  310 FL = ZERO
      FU = ZERO
      DO 320 I = 1,NCVF
         IF (I.EQ.IT) GO TO 320
         FL   = FL + (FX(I)/(BL-EIGEN(I)))**2
         FU   = FU + (FX(I)/(BU-EIGEN(I)))**2
  320 CONTINUE
      IF (NNEG.NE.0) THEN
         FL   = FL + (FX(IT)/(BL+EIGEN(IT)))**2
         FU   = FU + (FX(IT)/(BU+EIGEN(IT)))**2
      END IF
      FL = FL - D2MAX
      FU = FU - D2MAX
C        WRITE(IW,*)'BL,BU,FL,FU FROM BRACK2'
C        WRITE(IW,668)BL,BU,FL,FU
      IF (FL*FU .LT. ZERO) GO TO 330
      BL = BL - (EONE-BL)
      BU = BU + HALF*(BULI-BU)
      IF (BL.LE.-SSMAX) THEN
         BL = -SSMAX
         FRODO1=.TRUE.
      END IF
      IF (ABS(BULI-BU).LE.SSMIN) THEN
         BU = BULI-SSMIN
         FRODO2=.TRUE.
      END IF
      IF (FRODO1.AND.FRODO2) THEN
         IF(MASWRK) WRITE(IW,9200) EONE,BL,BU,FL,FU
         IF(MASWRK) WRITE(IW,9230)
C
C           LAMDA SEARCH FAILED, GO FOR FIXED LEVEL SHIFTED NR
C           THIS IS UNLIKELY TO PRODUCE ANYTHING USEFUL, BUT MAYBE
C           WE ARE LUCKY AND AT LEAST PERTURB THE GEOMETRY ENOUGH TO
C           CONTINUE
C
         LAMDA=EONE-SFIX
         LAMDA0=EIGIT+SFIX
         LSCAL=.TRUE.
         GO TO 200
      END IF
      GO TO 310
  330 CONTINUE
      NCNT = 0
      XLAMDA = ZERO
  340 CONTINUE
      FL = ZERO
      FU = ZERO
      FM = ZERO
      LAMDA = HALF*(BL+BU)
      DO 350 I = 1,NCVF
         IF (I.EQ.IT) GO TO 350
         FL   = FL + (FX(I)/(BL-EIGEN(I)))**2
         FU   = FU + (FX(I)/(BU-EIGEN(I)))**2
         FM   = FM + (FX(I)/(LAMDA-EIGEN(I)))**2
  350 CONTINUE
      IF (NNEG.NE.0) THEN
         FL   = FL + (FX(IT)/(BL+EIGEN(IT)))**2
         FU   = FU + (FX(IT)/(BU+EIGEN(IT)))**2
         FM   = FM + (FX(IT)/(LAMDA+EIGEN(IT)))**2
      END IF
      FL = FL - D2MAX
      FU = FU - D2MAX
      FM = FM - D2MAX
C        WRITE(IW,*)'BL,BU,LAMDA,FL,FU,FM FROM SEARCH2'
C        WRITE(IW,668)BL,BU,LAMDA,FL,FU,FM
      IF (ABS(XLAMDA-LAMDA).LT.TOLL) GO TO 360
      NCNT = NCNT + 1
      IF (NCNT.GT.1000) THEN
         IF(MASWRK) WRITE(IW,9220) BL,BU,LAMDA,FL,FU
         CALL ABRT
      END IF
      XLAMDA = LAMDA
      IF (FM*FU.LT.ZERO) BL = LAMDA
      IF (FM*FL.LT.ZERO) BU = LAMDA
      GO TO 340
C
  360 CONTINUE
      LAMDA0=-LAMDA
      LSCAL=.TRUE.
      GO TO 200
C
 9030 FORMAT(10X,'TS MODE OVERLAP LESS THAN',F5.2,', REDUCING ',
     *           'TRUST RADIUS BY SQRT(2)')
 9031 FORMAT(10X,'NEW TRUST RADIUS =',F11.6)
 9070 FORMAT(1X,'WARNING!! MODE SWITCHING WAS FOLLOWING MODE ',I3,
     *       ', NOW FOLLOWING MODE ',I3)
 9080 FORMAT(/1X,'TRYING TO FOLLOW MODE WITH EIGENVALUE EXACTLY ZERO.'/
     *       1X,'THIS IS PROBABLY A TRANSLATIONAL OR ROTATIONAL MODE?'//
     *       1X,'YOU MAY WISH TO FOLLOW A DIFFERENT MODE BY ENTERING'/
     *          ' -IFOLOW-,'/
     *       1X,'OR YOU MAY WISH TO ENTER BETTER STARTING COORDINATES')
 9110 FORMAT(10X,'FOLLOWING MODE',I3,' WITH EIGENVALUE',F11.5,
     *       ' AND COMPONENTS')
 9120 FORMAT(12X,6F9.5)
 9131 FORMAT(10X,'    RFO LAMBDA FOR NON-TS MODES =',F13.8)
 9132 FORMAT(10X,'TRIM/QA LAMBDA FOR NON-TS MODES =',F13.8)
 9150 FORMAT(10X,'TS SEARCH, CORRECT HESSIAN, TRYING PURE NR STEP')
 9160 FORMAT(10X,'MIN SEARCH, CORRECT HESSIAN, TRYING PURE NR STEP')
 9171 FORMAT(10X,'    RFO LAMBDA FOR     TS MODE  =',F13.8)
 9172 FORMAT(10X,'TRIM/QA LAMBDA FOR     TS MODE  =',F13.8)
 9200 FORMAT(10X,'NUMERICAL PROBLEMS IN BRACKETING LAMDA'/1P,5E15.10)
 9210 FORMAT(10X,'GOING FOR FIXED STEP SIZE')
 9220 FORMAT(10X,'TOO MANY ITERATIONS IN LAMBDA BISECT'/1P,5E15.10)
 9230 FORMAT(10X,'THIS IS A SERIOUS FAILURE!!!',/,
     *           'GOING FOR FIXED LEVEL SHIFTED NR STEP BUT DO NOT ',
     *           'EXPECT ANYTHING USEFUL...')
 9250 FORMAT(10X,'     NR STEP HAS LENGTH         =',F11.6)
 9260 FORMAT(10X,'    RFO STEP HAS LENGTH         =',F11.6)
 9270 FORMAT(10X,'TRIM/QA STEP HAS LENGTH         =',F11.6)
      END
C*MODULE STATPT  *DECK BKRNRM
      SUBROUTINE BKRNRM(NCVAL,OUT,IMTH,STPT,STSTEP,PROJCT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXFRG=1050,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      LOGICAL OUT,STPT,PROJCT
C
      COMMON /FMCOM / XX(1)
      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)
C
C     ----- GROW MEMORY FOR BKRNR -----
C
      NCF = 6*NFRG
      NCVF = NCVAL+NCF
C
      CALL VALFM(LOADFM)
      LFC   = LOADFM + 1
      LVEC  = LFC   + NCVF*NCVF
      LSCR  = LVEC  + NCVF*NCVF
      LEIG  = LSCR  + 8*NCVF
      LFX   = LEIG  + NCVF
      LIA   = LFX   + NCVF
      LGTOT = LIA   + NCVF
      LBUF1 = LGTOT + NCVF
      LBUF2 = LBUF1 + NCVF*NCVF
      LRM   = LBUF2 + NCVF*NCVF
      LFRG  = LRM   + (NCVAL+21*NFRG)
      LCOMC = LFRG  + NCF
      LAST  = LCOMC + (NCVAL+3*NFRG)
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
C
      CALL BKRNR(IMTH,NCVAL,NCVF,OUT,STPT,STSTEP,PROJCT,
     *           XX(LFC),XX(LFC),XX(LVEC),
     *           XX(LSCR),XX(LEIG),XX(LFX),XX(LIA),XX(LGTOT),
     *           XX(LBUF1),XX(LBUF2),XX(LRM),XX(LFRG),XX(LCOMC))
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK BKRUPD
      SUBROUTINE BKRUPD(NCVAL,NCOORD,NPUN,OUT,
     *                  F,FC,FCCART,SVEC,TVEC)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO=0.0D+00)
C
      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 / ENERGY,EG(3*MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      DIMENSION F(*),FC(NCVAL+6*NFRG,NCVAL+6*NFRG),
     *          SVEC(NCVAL+6*NFRG),TVEC(NCVAL+6*NFRG),
     *          FCCART(NCOORD+6*NFRG,NCOORD+6*NFRG)
C
C     ----- UPDATE THE HESSIAN MATRIX -----
C     2 UPDATING PROCEDURES ARE AVAILABLE, DEPENDING ON UPHESS.
C
C     UPDATE USES CURRENT GRADIENT, GRADIENT FROM PREVIOUS POINT
C     AND CORRECTION VECTOR USED ON LAST CYCLE
C     SVEC AND TVEC ARE FOR TEMPORARY STORAGE
C     D    -- CORRECTION VECTOR (H)
C     SVEC -- V = G'-G
C     TVEC -- H(OLD)H
C
      NC1 = NCVAL+6*NFRG
      NC3 = NC1*NC1
C
C     ----- READ IN FC MATRIX ------
C
      IF(NZVAR.EQ.0) THEN
         CALL DAREAD(IDAF,IODA,FC,NC3, 4,0)
      ELSE
         CALL DAREAD(IDAF,IODA,FC,NC3,43,0)
      END IF
      IF(OUT) WRITE(IW,9020)
      IF(OUT) CALL PRSQ(FC,NC1,NC1,NC1)
C
      DO 120 I=1,NC1
         TVEC(I)=ZERO
         DO 110 J=1,NC1
            TVEC(I)=TVEC(I) + FC(I,J)*D(J)
  110    CONTINUE
  120 CONTINUE
C
         CALL EGMOVE(F,EG,DEFT,TORQ,NCVAL,NFRG)
C
C     ----- POWELL UPDATE (USUAL FOR RUNTYP=SADPOINT) -----
C     ----- MIXED MS-POWELL UPDATE (SEE BOFILL) -----
C
      IF(IUPHSS.EQ.1  .OR.  IUPHSS.EQ.5) THEN
         IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9000)
         DO 200 I=1,NC1
            TVEC(I)=F(I)-OLDF(I)-TVEC(I)
  200    CONTINUE
         DDS=RADIUS*RADIUS
         DDT=DDOT(NC1,TVEC,1,TVEC,1)
         DDTD=DDOT(NC1,TVEC,1,D,1)
         IF(IUPHSS.EQ.1) THEN
            DDTD=DDTD/DDS
         ELSE
            ONE=1.0D+00
            COEF1=ONE-DDTD*DDTD/(DDS*DDT)
            COEF2=(ONE-COEF1)*DDS/DDTD
            COEF3=COEF1*DDTD/DDS
         END IF
         DO 220 I=1,NC1
            DO 210 J=1,I
               IF(IUPHSS.EQ.1) THEN
                  TEMP=TVEC(I)*D(J) + D(I)*TVEC(J) - D(I)*DDTD*D(J)
               ELSE
                  TEMP=(TVEC(I)*D(J) + D(I)*TVEC(J))*COEF1
     *                 -D(I)*D(J)*COEF3+TVEC(I)*TVEC(J)*COEF2
               END IF
               FC(I,J)=FC(I,J)+TEMP/DDS
               FC(J,I)=FC(I,J)
  210       CONTINUE
  220    CONTINUE
      END IF
C
C     ----- BFGS UPDATE.  NORMAL UPDATE FOR RUNTYP=OPTIMIZE -----
C
      IF(IUPHSS.EQ.2) THEN
         IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9010)
         DO 300 I=1,NC1
             SVEC(I)=F(I)-OLDF(I)
  300    CONTINUE
         DDS=DDOT(NC1,SVEC,1,D,1)
C
C           IF DDS IS NEGATIVE, RETENSION OF POSITIVE
C           DEFINITENESS IS NOT GUARANTEED.
C
         IF(DDS.LT.ZERO .AND. MASWRK .AND. NPRTGO.NE.2) WRITE(IW,9050)
         DDTD=DDOT(NC1,TVEC,1,D,1)
C
         DO 320 I=1,NC1
            DO 310 J=1,I
               TEMP= (SVEC(I)*SVEC(J))/DDS - (TVEC(I)*TVEC(J))/DDTD
               FC(I,J)=FC(I,J)+TEMP
               FC(J,I)=FC(I,J)
  310       CONTINUE
  320    CONTINUE
      END IF
C
C     ----- SAVE UPDATED FORCE CONSTANT MATRIX -----
C        (TRANSFORM FC TO CARTESIAN SPACE BEFORE PUNCHING)
C
      IF(NZVAR.EQ.0) THEN
         CALL DAWRIT(IDAF,IODA,FC,NC3, 4,0)
         IF(NPUN.EQ.1  .OR.  NPUN.EQ.3) THEN
            IF(MASWRK) WRITE(IP,*) 'THE APPROXIMATE HESSIAN IS'
            CALL FCMPUN(FC,NC1)
         END IF
      ELSE
         CALL DAWRIT(IDAF,IODA,FC,NC3,43,0)
C
         IF(NPUN.EQ.1  .OR.  NPUN.EQ.3) THEN
            CALL TFHB(FC,FCCART,NC1,NCOORD,NC1,NCOORD,49)
            IF(MASWRK) WRITE(IP,*) 'THE APPROXIMATE HESSIAN IS'
            CALL FCMPUN(FCCART,NCOORD)
         END IF
      END IF
      IF(OUT) WRITE (IW,9030)
      IF(OUT) CALL PRSQ(FC,NC1,NC1,NC1)
      RETURN
C
 9000 FORMAT(10X,'HESSIAN UPDATED USING THE POWELL FORMULA')
 9050 FORMAT(10X,'WARNING! HEREDITARY POSITIVE DEFINITENESS ENDANGERED')
 9010 FORMAT(10X,'HESSIAN UPDATED USING THE BFGS FORMULA')
 9020 FORMAT(1X,'IN BKRUPD, FC =')
 9030 FORMAT(1X,'IN BKRUPD, THE UPDATED FC=')
      END
C*MODULE STATPT  *DECK BKRUPM
      SUBROUTINE BKRUPM(NCVAL,NPUN,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      PARAMETER (MXATM=2000, MXFRG=1050,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /FMCOM / XX(1)
      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 /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
C     ----- ALLOCATE MEMORY -----
C          -FC-      AT I10
C          -FCCART-  AT I20
C          -SVEC-    AT I30
C          -TVEC-    AT I40
C
      NC1 = NCVAL+6*NFRG
      NC3 = NC1*NC1
      NCOORD = 3*NAT
C
      CALL VALFM(LOADFM)
      I10 = 1 + LOADFM
      I20 = I10 + NC1
      I30 = I20 + NC3
      I40 = I30 + (NCOORD+6*NFRG)**2
      I50 = I40 + NC1
      LAST= I50 + NC1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL BKRUPD(NCVAL,NCOORD,NPUN,OUT,
     *            XX(I10),XX(I20),XX(I30),XX(I40),XX(I50))
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK CONOPM
      SUBROUTINE CONOPM(NCVAL,NPUN,NPRT,NPRTHS,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXFRG=1050,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      LOGICAL OUT
C
      COMMON /FMCOM / X(1)
      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)
C
C     ----- GROW MEMORY FOR CONOPT -----
C     NOTE THAT NCVAL HARDWIRED TO NCOORD IN THE PRESENT VERSION
C
      NCVF = NCVAL+6*NFRG
C
      CALL VALFM(LOADFM)
      LFC   = LOADFM + 1
      LSCR  = LFC   + NCVF*NCVF
      LIA   = LSCR  + 8*NCVF
      LVEC  = LIA   + NCVF
      LVECP = LVEC  + NCVF*NCVF
      LEIGP = LVECP + NCVF*NCVF
      LRM   = LEIGP + NCVF*NCVF
      LCOMC = LRM   + NCVAL
      LAVEC = LCOMC + NCVAL
      LBVEC = LAVEC + NCVF
      LYVEC = LBVEC + NCVF
      LYPVC = LYVEC + NCVF
      LPVEC = LYPVC + NCVF
      LFX   = LPVEC + NCVF
      LFPX  = LFX   + NCVF
      LFPPX = LFPX  + NCVF
      LEIG  = LFPPX + NCVF
      LEIPP = LEIG  + NCVF
      LBMODE= LEIPP + NCVF
      LOPNT = LBMODE+ NCVF
      LTMP1 = LOPNT + NCVF
      LTMP2 = LTMP1 + NCVF
      LAST  = LTMP2 + NCVF
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
C
      CALL CONOPT(NCVAL,NCVF,NPUN,NPRT,NPRTHS,OUT,
     *           X(LFC),X(LFC),X(LSCR),X(LIA),
     *           X(LVEC),X(LVECP),X(LEIGP),X(LRM),X(LCOMC),
     *           X(LAVEC),X(LBVEC),X(LYVEC),X(LYPVC),X(LPVEC),
     *           X(LFX),X(LFPX),X(LFPPX),X(LEIG),X(LEIPP),
     *           X(LBMODE),X(LOPNT),X(LTMP1),X(LTMP2))
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK CONOPT
      SUBROUTINE CONOPT(NCVAL,NCVF,NPUN,NPRT,NPRTHS,OUT,
     *                 FC,A,SCR,IA,VEC,VECP,EIGP,
     *                 RM,COMC,AVEC,BVEC,YVEC,YPVC,PVEC,
     *                 FX,FPX,FPPX,EIG,EIPP,BMODE,OPNT,TMP1,TMP2)
C
C     ----- NOTE THAT -A- AND -FC- ARE EQUIVALENCED BY CALL -----
C
C     ----- MAIN DRIVER FOR CONSTRAINED OPTIMIZATION  -----
C           IMPLEMENTED BY FRANK JENSEN SEPT. 1995
C           Y. ABASHKIN, N. RUSSO, J.CHEM.PHYS. 100, 4477 (1994).
C           Y. ABASHKIN, N. RUSSO, M. TOSCANO, INT.J.QUANT.CHEM.
C           52, 695 (1994).
C
C     FC,A,AVEC,OPNT,PVEC,VEC REFER TO THE ORIGINAL CARTESIAN COORDS
C     BVEC,YVEC,FX,EIG REFER TO THE HESSIAN NORMAL MODE SYSTEM
C     YPVC,FPX,EIGP,VECP REFER TO THE REDUCED COORDINATE SYSTEM
C     FPPX,EIPP REFER TO THE DIAGONAL REDUCED COORDINATE SYSTEM
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION METHOD
C
      LOGICAL LINEAR,OUT,GOPARR,MASWRK,DSKWRK,HSSEND
      LOGICAL LCONV,UPDATE,DONR
C
      DIMENSION FC(*),A(NCVF,NCVF),SCR(8,NCVF),IA(NCVF),
     *          VEC(NCVF,NCVF),VECP(NCVF,NCVF),EIGP(NCVF,NCVF),
     *          RM(NCVAL),COMC(NCVAL),AVEC(NCVF),BVEC(NCVF),
     *          YVEC(NCVF),YPVC(NCVF),PVEC(NCVF),
     *          FX(NCVF),FPX(NCVF),FPPX(NCVF),
     *          EIG(NCVF),EIPP(NCVF),BMODE(NCVF),OPNT(NCVF),
     *          TMP1(NCVF),TMP2(NCVF)
      DIMENSION CMASS(3)
C
      PARAMETER (MXATM=2000, MXAO=8192, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      SAVE OLDE
C
      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 / ENERGY,EG(3*MXATM)
      COMMON /HSSCTL/ IHESSM,IHREP,HSSEND
      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 /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           TEN=1.0D+01, TMSIX=1.0D-06)
C
      DATA SCNOPT /8HCONOPT  /
      DATA OLDE/0.0D+00/
C
C     -NCVAL- IS DIMENSION OF INTERNAL OR CARTESIAN SPACE
C     -NCVF- ADDS IN 6 EXTRA DIMENSIONS FOR EACH EFFECTIVE FRAGEMENT.
C
      MSTEP=MAX(NSTEP,10)
      METHOD=SCNOPT
      UPDATE=.TRUE.
      IF(IUPHSS.EQ.4) UPDATE=.FALSE.
      MPRINT=NPRINT
      NPRINT=-5
      PI=ACOS(-ONE)
      TODEG=180.0D+00/PI
      LCONV=.FALSE.
      DONR=.FALSE.
      NNEG=1
      NC1=NCVF
      NCOORD=3*NAT
      MICRO=0
      RCUT=CONVF*TEN*TEN
      GCUT=CONVF*TEN
C
C     INITIAL POINT IS ASSSUMED TO BE A MINIMUM, SAVE COORDS IN AVEC
C
      CALL DCOPY(NC1,X,1,AVEC,1)
      CALL DCOPY(NC1,X,1,PVEC,1)
C     CONSTRUCT FIRST GUESS POINT ALONG PROPER EIGENMODE
C
      CALL GRXINM(NCOORD,NCVAL,NCVF,DXMAXT,OUT)
C
C     IF THE HESSIAN HAS BEEN CALCULATED WE HAVE THE GRADIENT
C     IF IT HAS BEEN READ THE GRADIENT IS PROBABLY JUST ZERO
C
      GNORM = SQRT(DDOT(NC1,EG,1,EG,1))
      IF (GNORM.GT.CONVF) WRITE(IW,9110) GNORM,CONVF
      CALL DCOPY(NC1,X,1,OPNT,1)
      CALL DCOPY(NC1,VMODE,1,BMODE,1)
      RDIST=DXMAXT
      MICRO=1
      NSERCH=1
C
C
C     CALCULATE GRADIENT AND HESSIAN
C
   5  CONTINUE
      IF(MICRO.EQ.1 .AND. .NOT.DONR)WRITE(IW,8900)
      CALL DCOPY(NC1,X,1,C,1)
      CALL DCOPY(NC1,EG,1,OLDF,1)
      CALL SIGVAL(EXETYP,NCOORD,METHOD,NPRT,NPRTHS)
      IF (MICRO.EQ.1) EMICRO=ENERGY
      IF(UPDATE) THEN
         IF(NSERCH.EQ.0 .AND. MASWRK) WRITE(IW,9070)
         IF(NSERCH.GT.0) THEN
            IF(IHREP.GT.0) THEN
               IHMOD = MOD(NSERCH,IHREP)
               IF(IHMOD.EQ.0 .AND. MASWRK) WRITE(IW,9075)
            ELSE
               IHMOD = 1
            END IF
            IF(IHMOD.GT.0) THEN
C              CARTESIAN UPDATE HARDWIRED
               NTMP=NZVAR
               NZVAR=0
               CALL BKRUPM(NCVAL,NPUN,OUT)
               NZVAR=NTMP
            END IF
         END IF
      ELSE
         IF (MASWRK) WRITE(IW,9080)
      END IF
C
      WRITE (IW,8001) NSERCH,MICRO,ENERGY
      WRITE (IW,8011)
      DO 105 IAT = 1,NAT
         N = 3*(IAT-1)
         ZNUC = ZAN(IAT) + IZCORE(IAT)
         WRITE (IW,8012) IAT,ANAM(IAT),BNAM(IAT),ZNUC,
     *                   (EG(N+I),I=1,3)
  105 CONTINUE
      CALL PRATM(IW,2)
      IF(NZMAT.GT.0) THEN
         CALL DCOPY(NC1,EG,1,TMP1,1)
         CALL TRANG(TMP1,NZVAR,NC1)
         CALL PZANDG(TMP1,1)
      END IF
 8001 FORMAT(/10X,'NSERCH=',I3,5X,'MICRO=',I3,5X,'ENERGY=',F16.7)
 8011 FORMAT(/33X,23(1H-)/33X,'GRADIENT (HARTREE/BOHR)'/33X,23(1H-)/
     *         8X,'ATOM     ZNUC',7X,'DE/DX',9X,'DE/DY',9X,'DE/DZ'/
     *         1X,62(1H-))
 8012 FORMAT(I3,2X,A8,A2,F6.1,3F14.7)
C
C     ----- PROJECT OUT T,R MODES -----
C     USE UNIT MASSES TO PROJECT OUT DIRECTLY IN CARTESIANS
C
      LRM=3*NAT+21*NFRG
      LFRG=6*NFRG
      CALL VCLR(RM,1,LRM)
      CALL VCLR(FRGMI,1,LFRG)
      I0=1
      DO 10 I=1,3*(NAT+NFRG)
         RM(I0  ) = ONE
         I0=I0+1
   10 CONTINUE
      I0=3*(NAT+NFRG)+1
      I1=3*(NAT+4*NFRG)+1
      DO 20 I=1,NFRG
         RM(I0  ) = ONE
         RM(I0+4) = ONE
         RM(I0+8) = ONE
         RM(I1  ) = ONE
         RM(I1+4) = ONE
         RM(I1+8) = ONE
         FRGMI(1,I) = ONE
         FRGMI(3,I) = ONE
         FRGMI(6,I) = ONE
         I0=I0+9
         I1=I1+9
   20 CONTINUE
      ZMASST=NAT+NFRG
C
      CALL VCLR(CMASS,1,3)
      DO 40 I=1,NAT
         DO 30 J=1,3
            CMASS(J)=CMASS(J)+C(J,I)
   30    CONTINUE
   40 CONTINUE
      DO 45 I=1,NFRG
         DO 44 J=1,3
            CMASS(J)=CMASS(J)+EFCENT(J,I)
   44    CONTINUE
   45 CONTINUE
      DO 50 I=1,3
         CMASS(I)=CMASS(I)/ZMASST
   50 CONTINUE
C
      KK=0
      DO 70 I=1,NAT
         DO 60 J=1,3
            KK=KK+1
            COMC(KK) = C(J,I)-CMASS(J)
   60    CONTINUE
   70 CONTINUE
      DO 90 I=1,NFRG
         DO 80 J=1,3
            KK=KK+1
            COMC(KK) = EFCENT(J,I)-CMASS(J)
   80    CONTINUE
   90 CONTINUE
C
      CALL DAREAD(IDAF,IODA,FC,NCVF*NCVF,4,0)
      CALL PRJFC(.FALSE.,.TRUE.,ZMASST,FC,D,COMC,RM,FRGMI,
     *              VEC,VECP,NAT,NCVAL,NCVF)
      IJ = 0
      DO 150 I = 1,NCOORD
         DO 140 J = 1,I
            IJ = IJ + 1
            FC(IJ) = A(J,I)
  140    CONTINUE
  150 CONTINUE
C
C     ----- OBTAIN CURRENT NORMAL MODE DIRECTIONS -----
C
      IF(OUT) WRITE(IW,9000)
      IF(OUT) CALL PRTRI(FC,NCOORD)
C
      IERR = 0
      CALL GLDIAG(NCVF,NCVF,NCVF,FC,SCR,EIG,VEC,IERR,IA)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'GLDIAG FAILURE IN -CONOPT-'
         CALL ABRT
      END IF
C
CFRJ  SHIFT T, R MODES TO BE THE LAST 6(5)
C
      NTR=0
      DO 300 I=NCVF,1,-1
         IF(ABS(EIG(I)).LT.1.0D-09) NTR=NTR+1
         IF(ABS(EIG(I)).LT.1.0D-09) ISHIFT=I
  300 CONTINUE
      IF (NTR.NE.5 .AND. NTR.NE.6) THEN
         WRITE(IW,*)'ERROR! NOT 5 OR 6 TR MODES',(EIG(I),I=1,NCVF)
         CALL ABRT
      END IF
      JSHIFT=ISHIFT-1
      DO 315 J=1,NTR
         JSHIFT=JSHIFT+1
         SCR(8,J)=EIG(JSHIFT)
         DO 310 I=1,NCVF
            SCR(J,I)=VEC(I,JSHIFT)
  310    CONTINUE
  315 CONTINUE
      DO 340 J=ISHIFT,NCVF-NTR
         EIG(J)=EIG(J+NTR)
         DO 330 I=1,NCVF
            VEC(I,J)=VEC(I,J+NTR)
  330    CONTINUE
  340 CONTINUE
      JTMP=0
      DO 360 J=NCVF-NTR+1,NCVF
         JTMP=JTMP+1
         EIG(J)=SCR(8,JTMP)
         DO 350 I=1,NCVF
            VEC(I,J)=SCR(JTMP,I)
  350    CONTINUE
  360 CONTINUE
      IF(OUT) WRITE(IW,9010)
      IF(OUT) CALL PREVNL(VEC,EIG,NCVF,NCVF,NCVF)
C
      NEG=0
      DO 200 I = 1,NCVF
         IF(ABS(EIG(I)).LT.TMSIX) EIG(I)=ZERO
         IF(EIG(I).LT.ZERO) NEG = NEG+1
  200 CONTINUE
C
      IF(MASWRK) WRITE(IW,9050) NEG
C
C     ----- PROJECT GRADIENT AND COORDINATES ONTO EACH NORMAL MODE -----
C
      TEST=ZERO
      DO 220 I=1,NCVF
         FX(I)=DDOT(NCVF,EG,1,VEC(1,I),1)
         YVEC(I)=DDOT(NCVF,X,1,VEC(1,I),1)
         BVEC(I)=DDOT(NCVF,AVEC,1,VEC(1,I),1)
         TMP=DDOT(NCVF,VMODE,1,VEC(1,I),1)
         IF (ABS(TMP).GT.ABS(TEST))IMODE=I
         IF (ABS(TMP).GT.ABS(TEST))TEST=TMP
         IF(EIG(I).EQ.ZERO) FX(I) = ZERO
  220 CONTINUE
      WRITE(IW,9051)IMODE,ABS(TEST),ABS(IFOLOW)
      IF (IMODE.NE.ABS(IFOLOW)) THEN
         WRITE(IW,9052)IFOLOW,IMODE
         IF (IFOLOW.LT.0) IMODE = -IMODE
         IFOLOW = IMODE
      END IF
      IIF=ABS(IFOLOW)
C     ALWAYS CHOOSE TS MODE TO HAVE SAME DIRECTION TO FACILATE
C     MANEGING SIGN OF DIR
      IF (TEST.LT.ZERO) THEN
         FX(IIF)=-FX(IIF)
         YVEC(IIF)=-YVEC(IIF)
         BVEC(IIF)=-BVEC(IIF)
         DO 219 I=1,NC1
            VEC(I,IIF)=-VEC(I,IIF)
  219    CONTINUE
      END IF
      DO 221 I=1,NC1
         VMODE(I) = VEC(I,IIF)
  221 CONTINUE
      CALL VCLR(D,1,NC1)
      DO 230 I=1,NC1
         IF (EIG(I).EQ. ZERO) THEN
            TMP=ZERO
         ELSE
            TMP=-FX(I)/EIG(I)
         END IF
         DO 222 J=1,NC1
            D(J)=D(J)+TMP*VEC(J,I)
  222    CONTINUE
  230 CONTINUE
      RADIUS = SQRT(DDOT(NC1,D,1,D,1))
      WRITE(IW,9055)RADIUS
      DTMP=MAX(0.10D+00,DXMAXT/TWO)
      IF ( (RADIUS.LE.DTMP .OR. DONR) .AND. NSERCH.GT.1 ) THEN
         DONR=.TRUE.
         GNORM = SQRT(DDOT(NC1,EG,1,EG,1))
         WRITE(IW,9018)
         WRITE(IW,9250) ENERGY,GNORM,ZERO,GNORM,CONVF,RADIUS,CONVF*TEN
         CALL SYMDR(D)
         CALL UPCOOR(D,NCOORD,OUT)
         IF (GNORM.LT.CONVF .AND. RADIUS.LT.CONVF*TEN) THEN
            WRITE(IW,9251)
            NPRINT=MPRINT
            CALL SIGEND(.TRUE.,NSERCH,NCVAL,NCOORD,NPRT,NPUN)
            IF(HSSEND) THEN
               IF (MASWRK) WRITE(IW,9100)
               CALL HESSX(.TRUE.,.TRUE.)
            END IF
            CALL ABRT
         END IF
         NSERCH=NSERCH+1
         IF (NSERCH.GT.NSTEP) THEN
            WRITE(IW,9200)
            CALL ABRT
         END IF
         MICRO=0
         GO TO 5
      END IF
C
C     CONSTRUCTION OF THE DERIVATIVES OF THE REDUCED ENERGY FUNCTION
C
      II=0
      DIR=ONE
      IF (IFOLOW.LT.0)DIR=-ONE
      DO 250 I=1,NC1-NTR
         IF (I.EQ.IIF) GO TO 250
         II = II+1
         YPVC(II)=YVEC(I)
  250 CONTINUE
      TMP = YVEC(IIF)-BVEC(IIF)
      II = 0
      DO 260 I=1,NC1-NTR
         IF (I.EQ.IIF) GO TO 260
         II = II+1
         FPX(II)=FX(I) - DIR*FX(IIF)*(YVEC(I)-BVEC(I))/TMP
         JJ = 0
         DO 255 J=1,NC1-NTR
            IF (J.EQ.IIF) GO TO 255
            TMPP = (YVEC(I)-BVEC(I))*(YVEC(J)-BVEC(J))
            TMPP = -DIR*TMPP/(TMP**3)
            IF (I.EQ.J) TMPP = TMPP - DIR/TMP
            JJ = JJ+1
            EIGP(II,JJ) = FX(IIF)*TMPP
            EIGP(II,JJ) = EIGP(II,JJ) +
     $      EIG(IIF)*(YVEC(I)-BVEC(I))*(YVEC(J)-BVEC(J))/(TMP*TMP)
            IF (I.EQ.J) EIGP(II,JJ) = EIGP(II,JJ) + EIG(I)
  255    CONTINUE
  260 CONTINUE
      GNORM = SQRT(DDOT(NC1,EG,1,EG,1))
      DEDR = DIR*FX(IIF)*RDIST/TMP
      II = 0
      DO 270 I=1,NC1-NTR-1
         DO 265 J=1,I
            II = II+1
            FC(II) = EIGP(I,J)
  265    CONTINUE
  270 CONTINUE
C
      IERR=0
      CALL GLDIAG(NCVF,NCVF-NTR-1,NCVF-NTR-1,FC,SCR,EIPP,VECP,IERR,IA)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'GLDIAG FAILURE IN -CONOPT- SITE 2'
         CALL ABRT
      END IF
C
      DO 280 I=1,NCVF-NTR-1
         FPPX(I)=DDOT(NCVF-NTR-1,FPX,1,VECP(1,I),1)
  280 CONTINUE
      FPPXNR=SQRT(DDOT(NCVF-NTR-1,FPPX,1,FPPX,1))
C     DO STRAIGHT NR STEP AND SCALE
      CALL VCLR(D,1,NC1)
      DO 530 I=1,NC1-NTR-1
         IF (EIPP(I).EQ. ZERO) THEN
            TMP=ZERO
         ELSE
            TMP=-FPPX(I)/EIPP(I)
         END IF
         DO 522 J=1,NC1-NTR-1
            D(J)=D(J)+TMP*VECP(J,I)
  522    CONTINUE
  530 CONTINUE
      RADIUS = SQRT(DDOT(NC1-NTR-1,D,1,D,1))
      IF (RADIUS.GT.DXMAXT) THEN
         SCALE = DXMAXT/RADIUS
         IF (MASWRK) WRITE (IW,9071) RADIUS,DXMAXT,SCALE
         RADIUS = DXMAXT
         CALL DSCAL(NC1-NTR-1,SCALE,D,1)
      END IF
 9071 FORMAT(10X,'CONSTRAINED NR STEP =',F11.5,1X,
     *'EXCEEDS DXMAX =',F11.5,/,10X,'STEP SCALED BY',F10.5)
C
C     ADD THE CORRECTION STEP, BACKTRANSFORM TO ORIGINAL COORD. SYSTEM
C
      CALL VADD(D,1,YPVC,1,YPVC,1,NC1-NTR-1)
      II=0
      TMP=ZERO
      DO 290 I=1,NC1-NTR
         IF (I.EQ.IIF) GO TO 290
         II = II+1
         TMP = TMP + (YPVC(II)-BVEC(I))**2
  290 CONTINUE
      IF (RDIST**2.GT.TMP) THEN
         TMP = SQRT(RDIST**2 - TMP)
      ELSE
         TMP = ZERO
      END IF
      YPTS = BVEC(IIF) + DIR*TMP
      II=0
      DO 295 I=1,NC1-NTR
         IF (I.EQ.IIF) THEN
            TMP2(I) = YPTS
         ELSE
            II = II+1
            TMP2(I) = YPVC(II)
         END IF
  295 CONTINUE
      DO 296 I=NC1-NTR+1,NC1
         TMP2(I) = YVEC(I)
  296 CONTINUE
C
      CALL VCLR(TMP1,1,NC1)
      DO 331 I=1,NC1
         TMP = TMP2(I)
         DO 322 J=1,NC1
            TMP1(J)=TMP1(J)+TMP*VEC(J,I)
  322    CONTINUE
  331 CONTINUE
C
C     CALCULATE TANGENT GRADIENT NORM
C
C     CALL VSUB(AVEC,1,X,1,TMP2,1,NC1)
C     TMP=SQRT(DDOT(NC1,TMP2,1,TMP2,1))
C     TMP=ONE/TMP
C     CALL DSCAL(NC1,TMP,TMP2,1)
C     TMP=DDOT(NC1,EG,1,TMP2,1)
C     CALL DSCAL(NC1,TMP,TMP2,1)
C     USE FX FOR SCRATCH
C     CALL VSUB(TMP2,1,EG,1,FX,1,NC1)
C     GTNORM=SQRT(DDOT(NC1,FX,1,FX,1))
C
      CALL VSUB(AVEC,1,TMP1,1,TMP2,1,NC1)
      TMP=SQRT(DDOT(NC1,TMP2,1,TMP2,1))
      WRITE(IW,9210)TMP
C
      ANG=DDOT(NC1,TMP2,1,BMODE,1)
      ANG=ANG/TMP
      IF (ABS(ANG).GT.ONE) ANG=ANG/ABS(ANG)
      ANG=TODEG*ACOS(ANG)
      WRITE(IW,9220)ANG
C
      CALL VSUB(X,1,TMP1,1,D,1,NC1)
      RADIUS=SQRT(DDOT(NC1,D,1,D,1))
      CALL SYMDR(D)
      CALL UPCOOR(D,NCOORD,OUT)
C
      CALL VSUB(OPNT,1,TMP1,1,TMP2,1,NC1)
      TMP=SQRT(DDOT(NC1,TMP2,1,TMP2,1))
      DELE=ENERGY-EMICRO
      WRITE(IW,9230)TMP,DELE
C
      WRITE(IW,9250) ENERGY,GNORM,DEDR,FPPXNR,GCUT,RADIUS,RCUT
      IF (FPPXNR.LT.GCUT .AND. RADIUS.LT.RCUT) THEN
         WRITE(IW,9251)
         LCONV=.TRUE.
      END IF
      IF (FPPXNR.LT.GCUT*1.0D-02 .AND. RADIUS.GT.RCUT
     *                          .AND. .NOT.LCONV) THEN
         WRITE(IW,9252)
         LCONV=.TRUE.
      END IF
      IF (FPPXNR.GT.GCUT .AND. RADIUS.LT.RCUT*1.0D-02
     *                          .AND. .NOT.LCONV) THEN
         WRITE(IW,9253)
         LCONV=.TRUE.
      END IF
C     IF THE CURRENT GEOMETRY IS CONVERGED, TAKE STEP OF DXMAXT ALONG
C     THE LINE FORMED BY THE TWO PREVIOUS POINTS
      IF(LCONV) THEN
         WRITE(IW,8910)
C
         CALL VSUB(PVEC,1,X,1,TMP2,1,NC1)
         TMP=SQRT(DDOT(NC1,TMP2,1,TMP2,1))
         WRITE(IW,9261)TMP
         IF (NSERCH.GT.1 .AND. ENERGY.LT.OLDE) THEN
            WRITE(IW,9262)
C           CALL ABRT
         END IF
         IF (DEDR.LT.ZERO) THEN
            WRITE(IW,9263)
C           CALL ABRT
         END IF
         NSERCH=NSERCH+1
         LCONV=.FALSE.
         MICRO=0
         IF (NSERCH.GT.NSTEP) THEN
            WRITE(IW,9200)
            CALL ABRT
         END IF
C        INCREASE RADIUS BY DXMAXT ALONG THE LINE FORMED BY THE
C        CURRENT AND PREVIOUS OPTIMIZED POINT
         OLDE=ENERGY
         TMP=DXMAXT/TMP
         CALL DSCAL(NC1,TMP,TMP2,1)
         CALL DCOPY(NC1,X,1,PVEC,1)
         CALL SYMDR(TMP2)
         CALL UPCOOR(TMP2,NCOORD,OUT)
         CALL DCOPY(NC1,X,1,OPNT,1)
         CALL VADD(TMP2,1,D,1,D,1,NC1)
         RADIUS=SQRT(DDOT(NC1,D,1,D,1))
         CALL VSUB(AVEC,1,X,1,TMP2,1,NC1)
         RDIST=SQRT(DDOT(NC1,TMP2,1,TMP2,1))
         WRITE(IW,9264)RDIST
      END IF
      MICRO=MICRO+1
      IF (MICRO.GT.MSTEP) THEN
         WRITE(IW,9201)
         CALL ABRT
      END IF
      GO TO 5
C
 8900 FORMAT(/,10X,'*************************************',/,
     *         10X,'* STARTING HYPERSPHERE OPTIMIZATION *',/,
     *         10X,'*************************************',/)
 8910 FORMAT(10X,'*************************************',/,
     *       10X,'* ENDING   HYPERSPHERE OPTIMIZATION *',/,
     *       10X,'*************************************',/)
 9000 FORMAT(16X,'FORCE CONSTANT MATRIX')
 9010 FORMAT(/10X,39HFORCE CONSTANT EIGENVALUES AND VECTORS ,/)
 9018 FORMAT(1X,'INSIDE NR REGION, TAKING PURE NR STEP')
 9050 FORMAT(/,1X,'CURRENT HESSIAN HAS',I3,' NEGATIVE EIGENVALUES.')
 9051 FORMAT(1X,'CURRENT MODE',I3,1X,'HAS OVERLAP =',F8.5,1X,
     *          'WITH PREVIOUS MODE',I3)
 9052 FORMAT(1X,'INFORMATION: OLD MODE',I3,1X,'IS NOW MODE',I3)
 9055 FORMAT(1X,'PURE NEWTON-RAPHSON STEP HAS LENGTH',11X,'=',F15.8)
 9070 FORMAT(10X,'FORCE CONSTANT MATRIX NOT UPDATED ---',
     *            ' TAKING FIRST STEP')
 9075 FORMAT(10X,'FORCE CONSTANT MATRIX NOT UPDATED ---',
     *            ' HESSIAN WAS JUST RECALCULATED')
 9080 FORMAT(10X,'HESSIAN UPDATE SKIPPED AT USER REQUEST')
 9100 FORMAT(//5X,57(1H*)/
     *         5X,'THE HESSIAN WILL NOW BE COMPUTED AT THE ',
     *             'STATIONARY POINT.'/
     *         5X,57(1H*))
 9110 FORMAT(10X,'WARNING! INITIAL GRADIENT NORM =',F10.6,/
     *       30X,'BUT OPTTOL =',F10.6,/,
     *       10X,'ARE YOU SURE YOUR START GEOMETRY IS A',
     *           'STATIONARY POINT?')
 9200 FORMAT(10X,'EXCEES NUMBER OF OPTIMIZATION STEPS')
 9201 FORMAT(10X,'EXCEES NUMBER OF MICRO OPTIMIZATION STEPS')
 9210 FORMAT(1X,'CURRENT DISTANCE FROM MINIMUM',17X,'=',F15.8)
 9220 FORMAT(1X,'CURRENT ANGLE WITH ORIGINAL DIRECTION',9X,'=',F10.3)
 9230 FORMAT(1X,'TOTAL GEOMETRY CHANGE DURING MICRO ITERATIONS =',F15.8,
     *     /,1X,'TOTAL ENERGY   CHANGE DURING MICRO ITERATIONS =',F15.8)
 9250 FORMAT(/,10X,'ENERGY',31X,'=',F15.8,/,
     *         10X,'GRADIENT NORM',24X,'=',F15.8,/,
     *         10X,'GRADIENT ALONG CONSTRAINT',12X,'=',F15.8,/,
     *         10X,'GNORM PERPENDICULAR TO CONSTRAINT',4X,'=',F15.8,5X,
     *         'CUTOFF =',F13.8,/,
     *         10X,'STEPLENGTH',27X,'=',F15.8,5X,'CUTOFF =',F13.8,/)
 9251 FORMAT(10X,'CONVERGENCE ON GRADIENT AND STEPLENGTH')
 9252 FORMAT(10X,'CONVERGENCE ON GRADIENT ONLY')
 9253 FORMAT(10X,'CONVERGENCE ON STEPLENGTH ONLY')
 9261 FORMAT(10X,'DISTANCE BETWEEN CURRENT AND PREVIOUS POINT =',F15.8)
 9262 FORMAT(10X,'*** WARNING!! CURRENT ENERGY =',F15.10,3X,
     *           'IS LOWER THAN THE PREVIOUS =',F15.10)
 9263 FORMAT(10X,'*** WARNING!! THE CONSTRAINT GRADIENT IS NEGATIVE')
 9264 FORMAT(10X,'INCREASING HYPERSPHERE RADIUS. NEW VALUE    =',F15.8)
      END
C*MODULE STATPT  *DECK DISPLC
      SUBROUTINE DISPLC(CVGED,XQUAD,XNEW,NCVAL,NCOORD,NPUN,OUT,METHOD,
     *                  ITBMAT,STPT,STSTEP,PROJCT,RUNTYP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION METHOD
C
      LOGICAL CVGED,LINEAR,OUT,UPDATE,GOPARR,MASWRK,DSKWRK,
     *        HSSEND,STPT,PROJCT
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00)
C
      DIMENSION XQUAD(*),XNEW(*)
C
      COMMON /DLCFRZ/ FVALUE(50),ITABLE(50),IFTYPE(50),NCONST
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NATEF(MXDFG),NUMEF(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /EFPOTD/ METHOF,ISCCHG,MOVE
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FMCOM / XX(1)
      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 /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /FROZNC/ IFREEZ(3*MXATM),NFRZ
      COMMON /FRZCRT/ IFZCRT(3*MXATM),NFZCRT
      COMMON /FUNCT / ENERGY,F(3*MXATM)
      COMMON /HSSCTL/ IHESSM,IHREP,HSSEND
      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 /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
C
      DATA SCHLGL/8HSCHLEGEL/, SQA   /8HQA      /
      DATA SRFO  /8HRFO     /, SNR   /8HNR      /
C
C     ----- FORM DISPLACEMENT TO NEXT POINT -----
C     THIS ROUTINE ALSO TESTS FOR CONVERGENCE (SMALL GRADIENT)
C     SKIP UPDATE IF UPHESS=SKIP
C
      NCF=3*NFRG
      NC1=NCVAL+2*NCF
C
      UPDATE=.TRUE.
      IF(IUPHSS.EQ.4) UPDATE=.FALSE.
C
C     ----- PRINT CURRENT COORDINATES, AND GRADIENT -----
C
      IF (MASWRK  .AND.  NPRTGO.NE.2) THEN
         WRITE (IW,9000) NSERCH,ENERGY
         IF(NAT.GT.0 .AND. NPRTGO.NE.2) WRITE(IW,9010)
         DO IAT = 1,NAT
            N = 3*(IAT-1)
            ZNUC = ZAN(IAT) + IZCORE(IAT)
            WRITE (IW,9012) IAT,ANAM(IAT),BNAM(IAT),ZNUC,
     *                      (F(N+I),I=1,3)
         ENDDO
         IF(NFRG.GT.0 .AND. NPRTGO.NE.2) WRITE(IW,9015)
         DO IFRG=1,NFRG
            WRITE(IW,9017) IFRG,(DEFT(III,IFRG),III=1,3),
     *                          (TORQ(III,IFRG),III=1,3)
         ENDDO
      END IF
C
      IF (STPT) GO TO 150
C
C      IF ANY CARTESIAN COORDINATES ARE FROZEN,
C      ZERO OUT THE CORRESPONDING GRADIENTS
C
      IF (NFZCRT.GT.0) THEN
        DO I=1,NFZCRT
           F(IFZCRT(I))=ZERO
        END DO
        IF(MASWRK) WRITE(IW,9005)
      END IF
C
C
C     ----- TEST GRADIENT FOR CONVERGENCE -----
C
      IF(NZMAT.GT.0) THEN
C
C     DLC
C     ZERO OUT THE GRADIENT(S) OF CONSTRAINT COORDINATE(S).
C
         CALL TRANG(F,NCVAL,NCOORD)
         IF (NCONST.GT.0) THEN
           DO 70 I=1,NCONST
              F(ITABLE(I))=ZERO
 70        CONTINUE
         END IF
         CALL PZANDG(F,1)
      END IF
C--JHJ---
      DO 120 I=1,NFRZ
         F(IFREEZ(I)) = ZERO
  120 CONTINUE
C--JHJ---
C
C     -----ALWAYS USE CARTESIAN GRADIENTS TO CHECK CONVERGENCE
C       IF THE OPTIMIZATION IS BEING RUN IN INTERNALS, TRANSFORM FROM
C       INTERNALS TO CARTESIANS, OBTAIN THE RMS, THEN PUT GRADIENT
C       BACK INTO INTERNALS.
C
      IF(NZMAT.GT.0) CALL TRANGB(F,NVAR,NCOORD)
      CALL EGMAX(F,NCOORD,DEFT,TORQ,NFRG,FMAX,FRMS)
      IF(NZMAT.GT.0) CALL TRANG(F,NCVAL,NCOORD)
C
C        --CORRECT FRMS FOR FROZEN CARTESIAN COORDINATES--
C
      IF(NFZCRT.GT.0) THEN
         DUM1=NCOORD
         DUM2=NCOORD-NFZCRT
         FRMS=FRMS*(SQRT(DUM1)/SQRT(DUM2))
      END IF
C
      IF (MASWRK  .AND.  NZMAT.GT.0  .AND.  NPRTGO.NE.2) WRITE (IW,9025)
      IF (MASWRK  .AND.  NPRTGO.NE.2)
     *      WRITE (IW,9030) FMAX,FRMS
      CVGED= (FRMS .LT. CONVF/THREE) .AND. (FMAX .LT. CONVF)
      IF(CVGED) GO TO 700
C
      IF(FMAX .GE. FMAXT) THEN
         IF (MASWRK) WRITE (IW,9040) FMAXT
         IF(NACC.EQ.0) CALL ABRT
      END IF
C
C     ----- CORRECTIONS TO 2ND DERIVATIVES -----
C
      IF(UPDATE) THEN
         IF(NSERCH.EQ.0 .AND. MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9050)
         IF(NSERCH.GT.0) THEN
            IF(IHREP.GT.0) THEN
               IHMOD = MOD(NSERCH,IHREP)
               IF(IHMOD.EQ.0 .AND. MASWRK) WRITE(IW,9055)
            ELSE
               IHMOD = 1
            END IF
            IF(IHMOD.GT.0) THEN
               IF(METHOD.EQ.SCHLGL) THEN
                  CALL SCHUPM(NCVAL,NPMAX,NPUN,OUT)
               ELSE
                  CALL BKRUPM(NCVAL,NPUN,OUT)
               END IF
            END IF
         END IF
      ELSE
         IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9060)
      END IF
C
  150 CONTINUE
C
C     ----- SAVE CURRENT POINT, UPDATE NP -----
C
      IF(METHOD.EQ.SCHLGL) CALL SCHSAM(NCVAL,NPMAX)
C
C     ----- TAKE QUASI-NEWTON OPTIMIZATION STEP
C           ON SURFACE ASSUMED TO BE QUADRATIC -----
C
      IF(METHOD.EQ.SCHLGL) CALL SCHNRM(XQUAD,NCVAL,OUT)
      IF(METHOD.EQ.SNR)    CALL BKRNRM(NCVAL,OUT,1,STPT,STSTEP,PROJCT)
      IF(METHOD.EQ.SRFO)   CALL BKRNRM(NCVAL,OUT,2,STPT,STSTEP,PROJCT)
      IF(METHOD.EQ.SQA)    CALL BKRNRM(NCVAL,OUT,3,STPT,STSTEP,PROJCT)
C
C  ---- LVS PATCH FOR MC RUNS
      IF(IDPUNC .EQ. 1) RETURN
C
C     ----- FORM DISPLACEMENT TO NEXT POINT -----
C
      IF(METHOD.EQ.SCHLGL) CALL DCOPY(NCVAL,XQUAD,1,XNEW,1)
      IF(METHOD.EQ.SQA .OR. METHOD.EQ.SRFO .OR.
     *   METHOD.EQ.SNR) CALL DCOPY(NC1,D,1,XNEW,1)
C
C     DLC
C     ZERO OUT THE NEXT STEP OF CONSTRAINT COORDINATES.
C
      IF (NCONST .GT. 0) THEN
         DO 250 I=1,NCONST
            XNEW(ITABLE(I)) = ZERO
 250     CONTINUE
      END IF
      DO 200 I=1,NFRZ
         XNEW(IFREEZ(I)) = ZERO
  200 CONTINUE
C
C     ----- TEST MAGNITUDE OF DISPLACEMENT -----
C
      RADIUS = DDOT(NC1,XNEW,1,XNEW,1)
      RADIUS = SQRT(RADIUS)
C
      IF(NFZCRT.GT.0.AND.NSERCH.LE.3) THEN
         DUM1=NCOORD
         DUM2=NCOORD-NFZCRT
         RADIUS=RADIUS*(DUM1/DUM2)
      END IF
C
      IF(RADIUS.GT.DXMAXT+1.0D-06 .AND. METHOD.NE.SNR) THEN
         SCALE = DXMAXT/RADIUS
         RADIUS = DXMAXT
         IF (MASWRK) WRITE (IW,9070) SCALE
         CALL DSCAL(NC1,SCALE,XNEW,1)
         IF(METHOD.EQ.SQA .OR. METHOD.EQ.SRFO)
     *      CALL DCOPY(NC1,XNEW,1,D,1)
      END IF
      IF (MASWRK  .AND.  NPRTGO.NE.2)
     *      WRITE(IW,9075) RADIUS,DXMAXT
      IF(OUT) WRITE(IW,9080) (XNEW(I),I=1,NC1)
      IF(MOVE.EQ.0) GO TO 175
C
C  ROTATE AND TRANSLATE FRAGMENTS
C
      NMST=0
      NPST=0
      NDPST=0
      NRST=0
      NDST=0
      NATST=0
      NORST=0
      NAOST=0
      II=NCVAL+1
C
      MXBF=0
      DO I=1,NFRG
         MXBF=MAX(MXBF,NPBF(I))
      END DO
      CALL VALFM(LOADFM)
      LPROVEC = LOADFM  + 1
      LCANVEC = LPROVEC + MXBF*NTMO
      LAST    = LCANVEC + MXBF*NTAO
      NEED=LAST-LOADFM-1
      CALL GETFM(NEED)
      LENPV=MXBF*NTMO
      IF (NFRG.GT.0.AND.NTMO.GT.0)
     *   CALL DAREAD(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
      LENCV=MXBF*NTAO
      IF (NFRG.GT.0.AND.NTAO.GT.0)
     *   CALL DAREAD(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
C
      DO 170 I=1,NFRG
      XDEL=D(II)
      YDEL=D(II+1)
      ZDEL=D(II+2)
      THETAX=D(II+3)
      THETAY=D(II+4)
      THETAZ=D(II+5)
      II=II+6
C
      CALL EFDSPL(I,XDEL,YDEL,ZDEL,THETAX,THETAY,THETAZ,
     *            NMST,NPST,NDPST,NRST,NDST,NATST,NORST,
     *            XX(LPROVEC),NAOST,XX(LCANVEC),MXBF)
C
      NMST  = NMST  + NMPTS(I)
      NPST  = NPST  + NPPTS(I)
      NDPST = NDPST + NDPPTS(I)
      NRST  = NRST  + NRPTS(I)
      NDST  = NDST  + NDPTS(I)
      NATST = NATST + NATEF(ISET(I))
      NORST = NORST + NORB(I)
      NAOST = NAOST + NAO(ISET(I))
 170  CONTINUE
C
      IF (NFRG.GT.0.AND.NTMO.GT.0)
     *   CALL DAWRIT(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
      IF (NFRG.GT.0.AND.NTAO.GT.0)
     *   CALL DAWRIT(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
C
      CALL RETFM(NEED)
C
C
C     ----- TRANSFORM INTERNAL DISPLACEMENTS TO CARTESIANS -----
C
 175  CONTINUE
      IF(NZMAT.GT.0) THEN
         ICONV = 0
         CALL UPDISP(XNEW,NCVAL,NCOORD,DXMAXT,OUT,ITBMAT,
     *                           ICONV,RUNTYP)
      END IF
      RETURN
C
C     ----- STATIONARY POINT SEARCH ENDING -----
C
  700 CONTINUE
      IF (MASWRK  .AND.  NPRTGO.GT.-1) THEN
         IF(NNEG.EQ.0 .OR. METHOD.EQ.SNR) WRITE(IW,9100)
         IF(NNEG.GT.0 .AND. METHOD.NE.SNR) WRITE(IW,9110)
         IF(NFRZ.GT.0) WRITE(IW,9120) NFRZ
      END IF
      RETURN
C
 9000 FORMAT(/10X,'NSERCH=',I3,5X,'ENERGY=',F16.7)
 9005 FORMAT(//1X,'NOTE: SOME CARTESIAN COORDINATES ARE FROZEN,'/
     *  7X,'THE CORRESPONDING GRADIENTS ARE SET TO BE ZERO.')
 9010 FORMAT(/33X,23(1H-)/33X,'GRADIENT (HARTREE/BOHR)'/33X,23(1H-)/
     *         8X,'ATOM     ZNUC',7X,'DE/DX',9X,'DE/DY',9X,'DE/DZ'/
     *         1X,62(1H-))
 9012 FORMAT(I3,2X,A8,A2,F6.1,3F14.7,8X,3F14.7)
 9015 FORMAT(1X,' EFP',11X,'TOTAL GRADIENT',27X,'TORQUES')
 9017 FORMAT(1X,I4,1X,3F11.7,3X,3F11.7)
 9025 FORMAT(/1X,'NOTE: CARTESIAN GRADIENTS ARE ALWAYS TAKEN TO TEST ',
     *  'CONVERGENCE,'/7X,'SO THE FOLLOWING GRADIENTS ARE CARTESIAN.')
 9030 FORMAT(/10X,19HMAXIMUM GRADIENT = ,F10.7,4X,
     *     'RMS GRADIENT =',F10.7)
 9040 FORMAT(1H0,21HOPTIMIZATION ABORTED.  /1X,
     *     27H   -- GRADIENT OUT OF RANGE  /1X,
     *     38H   -- MAXIMUM ALLOWED FORCE (FMAXT) = ,F8.3)
 9050 FORMAT(10X,'FORCE CONSTANT MATRIX NOT UPDATED ---',
     *            ' TAKING FIRST STEP')
 9055 FORMAT(10X,'FORCE CONSTANT MATRIX NOT UPDATED ---',
     *            ' HESSIAN WAS JUST RECALCULATED')
 9060 FORMAT(10X,'HESSIAN UPDATE SKIPPED AT USER REQUEST')
 9070 FORMAT(10X,'MAXIMUM STEP EXCEEDED, STEP SCALED BY',F13.8)
 9075 FORMAT(10X,'RADIUS OF STEP TAKEN=',F10.5,
     *           '  CURRENT TRUST RADIUS=',F10.5)
 9080 FORMAT(1X,'IN DISPLC, XNEW='/(1X,10F12.7))
 9100 FORMAT(/6X,'***** EQUILIBRIUM GEOMETRY LOCATED *****')
 9110 FORMAT(/6X,'***** SADDLE POINT LOCATED *****')
 9120 FORMAT(12X,'(SUBJECT TO',I4,' CONSTRAINT(S))')
      END
C*MODULE STATPT  *DECK EEFOPT
      SUBROUTINE EEFOPT(NC,NFRG,F,EFCONV,DOSBEF,EFOPTT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL EFCONV,DOSBEF
C
      DIMENSION F(NC)
C
      PARAMETER (MXFRG=1050, MXFGPT=12000)
C
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
C
      DATA THREE/3.0D+00/
C
      CALL EGMAX(F,NC,DEFT,TORQ,NFRG,FMAX,FRMS)
      CALL GEFCOV(DEFT,TORQ,NFRG,EFGMAX,EFGRMS,EFCONV,EFOPTT)
      IF ((EFGMAX.LE.FMAX/THREE).AND.(EFGRMS.LE.FRMS/THREE))
     *               EFCONV=.TRUE.
C
      IF (EFCONV) RETURN
      DOSBEF=.TRUE.
C
      NCF=3*NFRG
      CALL VCLR(DEFT,1,NCF)
      CALL VCLR(TORQ,1,NCF)
      CALL STVDER
      IREST = 0
      CALL VCLR(F,1,NC)
C
      RETURN
      END
C*MODULE EFSTAT   *DECK EFDSPL
      SUBROUTINE EFDSPL(N,XDEL,YDEL,ZDEL,THETAX,THETAY,THETAZ,
     *        NMST,NPST,NDPST,NRST,NDST,NATST,NORST,PROVEC,
     *        NAOST,CANVEC,MXBF)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000, MXDFG=5,
     *           MXAO=8192, MXSH=5000, MXGTOT=20000, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (CONST=2.0D+00/1.7320508D+00)
      PARAMETER (SQRT3=1.732050808D+00,SQRT5=2.236067978D+00)
      PARAMETER (SQRT7=2.645751311D+00)
      PARAMETER (TWO=2.0D+00,THREE=3.0D+00,FOUR=4.0D+00,SIX=6.0D+00)
      PARAMETER (TWELVE=12.0D+00)
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM,REPNAM,DNAME,DPSNAM
C
      DIMENSION T3(3,3),T3T(3,3)
      DIMENSION T1(3,3), T2(3,3)
      DIMENSION TEMP(3,MXPT),TEMP2(6),TEMP3(3),TEMP4(6,3),TEMP5(6,3)
      DIMENSION DTEMP(3,MXIFRQ*MXPT)
      DIMENSION TPXX(6),TPXY(6),TPYY(6),TPXZ(6),TPYZ(6),TPZZ(6)
      DIMENSION TPXX2(6),TPXY2(6),TPYY2(6),TPXZ2(6),TPYZ2(6),TPZZ2(6)
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NAT(MXDFG),NUM(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /EFPMP2/ MP2TYP
      COMMON /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ*MXFGPT),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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 /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
      DIMENSION PROVEC(MXBF,NTMO),CANVEC(MXBF,NTAO)
C
      NPTS = NMPTS(N)
C
      CALL EFROTT(THETAX,THETAY,THETAZ,T3)
C
C  COMPUTE TRANSPOSE
C
      CALL TRPOSE(T3,T3T,3,3,0)
C
C   5.  ROTATE AND TRANSLATE STANDARD FRAGMENT TO COINCIDE WITH FRAG N
C
C  FIND FRAGMENT COORDINATES RELATIVE TO POINT OF ROTATION
      DO 505 I=1,NPTS
        DO 504 J=1,3
          TEMP(J,I) = EFC(J,I+NMST) - EFCENT(J,N)
  504   CONTINUE
  505 CONTINUE
C
C  NOW ROTATE FRAGMENT
C
      CALL MRARBR(T3,3,3,3,TEMP,3,NPTS,EFC(1,NMST+1),3)
C
C CHANGE COORDINATES RELATIVE TO EFCENT BACK TO OLD COORDINATE SYSTEM
C
      DO 605 I=1,NPTS
        DO 604 J=1,3
          EFC(J,I+NMST) = EFC(J,I+NMST) + EFCENT(J,N)
  604   CONTINUE
  605 CONTINUE
C
C  FEED IN INFORMATION INTO FINAL ARRAYS AFTER ROTATION
C
C DO TRANSLATION
C     WRITE(6,*)'ROTATED COORDINATES,ME,NSERCH',ME,NSERCH
      DO 550 I = 1,NPTS
        EFC(1,NMST+I) = EFC(1,NMST+I) + XDEL
        EFC(2,NMST+I) = EFC(2,NMST+I) + YDEL
        EFC(3,NMST+I) = EFC(3,NMST+I) + ZDEL
C       WRITE(6,FMT='(3F9.5)') (EFC(J,I+NMST), J=1,3)
  550 CONTINUE
C
C ROTATING DIPOLE MOMENTS
C
      CALL MRARBR(T3,3,3,3,EFDIP(1,NMST+1),3,NPTS,TEMP,3)
      DO 555 I=1,NPTS
      DO 555 J=1,3
      EFDIP(J,NMST+I)=TEMP(J,I)
 555  CONTINUE
C
      IF(IEFP2.EQ.1) THEN
        CALL MRARBR(T3,3,3,3,DIPHF(1,NMST+1),3,NPTS,TEMP,3)
        DO 601 I=1,NPTS
          DO 601 J=1,3
            DIPHF(J,NMST+I)=TEMP(J,I)
 601    CONTINUE
C
        TEMP3(1) = 0.0D+00
        TEMP3(2) = 0.0D+00
        TEMP3(3) = 0.0D+00
        DO 602 I=1,NPTS
          TEMP2(1)=QADHF(1,I+NMST)
          TEMP2(2)=QADHF(4,I+NMST)
          TEMP2(3)=QADHF(2,I+NMST)
          TEMP2(4)=QADHF(5,I+NMST)
          TEMP2(5)=QADHF(6,I+NMST)
          TEMP2(6)=QADHF(3,I+NMST)
          CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
          QADHF(1,NMST+I)=TEMP4(1,1)
          QADHF(4,NMST+I)=TEMP4(2,1)
          QADHF(2,NMST+I)=TEMP4(3,1)
          QADHF(5,NMST+I)=TEMP4(4,1)
          QADHF(6,NMST+I)=TEMP4(5,1)
          QADHF(3,NMST+I)=TEMP4(6,1)
 602    CONTINUE
C
      END IF
C
C ROTATING QUADRUPOLE MOMENTS
C
      TEMP3(1) = 0.0D+00
      TEMP3(2) = 0.0D+00
      TEMP3(3) = 0.0D+00
      DO 600 I=1,NPTS
        TEMP2(1)=EFQAD(1,I+NMST)
        TEMP2(2)=EFQAD(4,I+NMST)
        TEMP2(3)=EFQAD(2,I+NMST)
        TEMP2(4)=EFQAD(5,I+NMST)
        TEMP2(5)=EFQAD(6,I+NMST)
        TEMP2(6)=EFQAD(3,I+NMST)
        CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
        EFQAD(1,NMST+I)=TEMP4(1,1)
        EFQAD(4,NMST+I)=TEMP4(2,1)
        EFQAD(2,NMST+I)=TEMP4(3,1)
        EFQAD(5,NMST+I)=TEMP4(4,1)
        EFQAD(6,NMST+I)=TEMP4(5,1)
        EFQAD(3,NMST+I)=TEMP4(6,1)
  600 CONTINUE
C
C ROTATING OCTUPOLE MOMENTS
C
      DO 650 I=1,NPTS
        TEMP2(1) = EFOCT(1,I+NMST)
        TEMP2(2) = EFOCT(4,I+NMST)
        TEMP2(3) = EFOCT(6,I+NMST)
        TEMP2(4) = EFOCT(5,I+NMST)
        TEMP2(5) = EFOCT(10,I+NMST)
        TEMP2(6) = EFOCT(8,I+NMST)
        CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
        TEMP2(1)=EFOCT(4,I+NMST)
        TEMP2(2)=EFOCT(6,I+NMST)
        TEMP2(3)=EFOCT(2,I+NMST)
        TEMP2(4)=EFOCT(10,I+NMST)
        TEMP2(5)=EFOCT(7,I+NMST)
        TEMP2(6)=EFOCT(9,I+NMST)
        CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
        TEMP2(1)=EFOCT(5,I+NMST)
        TEMP2(2)=EFOCT(10,I+NMST)
        TEMP2(3)=EFOCT(7,I+NMST)
        TEMP2(4)=EFOCT(8,I+NMST)
        TEMP2(5)=EFOCT(9,I+NMST)
        TEMP2(6)=EFOCT(3,I+NMST)
        CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
        CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
        EFOCT(1,NMST+I)=TEMP5(1,1)
        EFOCT(2,NMST+I)=TEMP5(3,2)
        EFOCT(3,NMST+I)=TEMP5(6,3)
        EFOCT(4,NMST+I)=TEMP5(2,1)
        EFOCT(5,NMST+I)=TEMP5(4,1)
        EFOCT(6,NMST+I)=TEMP5(3,1)
        EFOCT(7,NMST+I)=TEMP5(5,2)
        EFOCT(8,NMST+I)=TEMP5(6,1)
        EFOCT(9,NMST+I)=TEMP5(6,2)
        EFOCT(10,NMST+I)=TEMP5(5,1)
  650 CONTINUE
C
C  ----- ROTATING POLARIZABILITY ... COORDINATES AND TENSOR -----
C  THE COORDINATE CODE UPDATES POLARIZABILITY -AND- 2ND ORDER CORRECTION
C
      IPPTS=NPPTS(N)
      DO 670 I=1,IPPTS
        DO 660 J=1,3
          TEMP(J,I) = EFP(J,I+NPST) - EFCENT(J,N)
  660   CONTINUE
  670 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,IPPTS,EFP(1,NPST+1),3)
C
      DO 770 I=1,IPPTS
        DO 760 J=1,3
          EFP(J,I+NPST) = EFP(J,I+NPST) + EFCENT(J,N)
  760   CONTINUE
  770 CONTINUE
C
      DO 680 I = 1,IPPTS
        EFP(1,I+NPST) = EFP(1,I+NPST) + XDEL
        EFP(2,I+NPST) = EFP(2,I+NPST) + YDEL
        EFP(3,I+NPST) = EFP(3,I+NPST) + ZDEL
  680 CONTINUE
C
C     ---- ROTATE THE POLARIZABILITY TENSORS ----
C     MP2 POLARIZABILITY USES LAST POLARIZABILITY POINT FOR COORDINATE
C     STORAGE, BUT THERE ISN'T A DIPOLE TENSOR FOR THAT LAST POINT
C
      NUMPTS = IPPTS
      IF(IEFP2.EQ.1) NUMPTS=NUMPTS-1
      DO 690 I=1,NUMPTS
         T1(1,1) = EFPOL(1,NPST+I)
         T1(1,2) = EFPOL(4,NPST+I)
         T1(1,3) = EFPOL(5,NPST+I)
         T1(2,1) = EFPOL(7,NPST+I)
         T1(2,2) = EFPOL(2,NPST+I)
         T1(2,3) = EFPOL(6,NPST+I)
         T1(3,1) = EFPOL(8,NPST+I)
         T1(3,2) = EFPOL(9,NPST+I)
         T1(3,3) = EFPOL(3,NPST+I)
         CALL MRARBR(T3,3,3,3,T1,3,3,T2,3)
         CALL MRARBR(T2,3,3,3,T3T,3,3,T1,3)
         EFPOL(1,NPST+I) = T1(1,1)
         EFPOL(4,NPST+I) = T1(1,2)
         EFPOL(5,NPST+I) = T1(1,3)
         EFPOL(7,NPST+I) = T1(2,1)
         EFPOL(2,NPST+I) = T1(2,2)
         EFPOL(6,NPST+I) = T1(2,3)
         EFPOL(8,NPST+I) = T1(3,1)
         EFPOL(9,NPST+I) = T1(3,2)
         EFPOL(3,NPST+I) = T1(3,3)
  690 CONTINUE
C
C          UPDATE THE 2ND ORDER CORRECTION TO THE POLARIZABILITY
C
      IF(IEFP2.EQ.1) THEN
         T1(1,1) = EFPOL2(1,N)
         T1(1,2) = EFPOL2(4,N)
         T1(1,3) = EFPOL2(5,N)
         T1(2,1) = EFPOL2(7,N)
         T1(2,2) = EFPOL2(2,N)
         T1(2,3) = EFPOL2(6,N)
         T1(3,1) = EFPOL2(8,N)
         T1(3,2) = EFPOL2(9,N)
         T1(3,3) = EFPOL2(3,N)
         CALL MRARBR(T3,3,3,3,T1,3,3,T2,3)
         CALL MRARBR(T2,3,3,3,T3T,3,3,T1,3)
         EFPOL2(1,N) = T1(1,1)
         EFPOL2(4,N) = T1(1,2)
         EFPOL2(5,N) = T1(1,3)
         EFPOL2(7,N) = T1(2,1)
         EFPOL2(2,N) = T1(2,2)
         EFPOL2(6,N) = T1(2,3)
         EFPOL2(8,N) = T1(3,1)
         EFPOL2(9,N) = T1(3,2)
         EFPOL2(3,N) = T1(3,3)
      END IF
C
C     --- ROTATING DYNAMIC POLARIZABILITY ... COORDINATES AND TENSOR ---
C
      IDPPTS=NDPPTS(N)
      DO 671 I=1,IDPPTS
        DO 661 J=1,3
          DTEMP(J,I) = EFDP(J,I+NDPST) - EFCENT(J,N)
  661   CONTINUE
  671 CONTINUE
C
      CALL MRARBR(DT3,3,3,3,DTEMP,3,IDPPTS,EFDP(1,NDPST+1),3)
C
      DO 771 I=1,IDPPTS
        DO 761 J=1,3
          EFDP(J,I+NDPST) = EFDP(J,I+NDPST) + EFCENT(J,N)
  761   CONTINUE
  771 CONTINUE
C
      DO 681 I = 1,IDPPTS
        EFDP(1,I+NDPST) = EFDP(1,I+NDPST) + XDEL
        EFDP(2,I+NDPST) = EFDP(2,I+NDPST) + YDEL
        EFDP(3,I+NDPST) = EFDP(3,I+NDPST) + ZDEL
  681 CONTINUE
C
      DO 691 I=1,IDPPTS
        T1(1,1) = EFDPOL(1,I+NDPST)
        T1(1,2) = EFDPOL(4,I+NDPST)
        T1(1,3) = EFDPOL(5,I+NDPST)
        T1(2,1) = EFDPOL(7,I+NDPST)
        T1(2,2) = EFDPOL(2,I+NDPST)
        T1(2,3) = EFDPOL(6,I+NDPST)
        T1(3,1) = EFDPOL(8,I+NDPST)
        T1(3,2) = EFDPOL(9,I+NDPST)
        T1(3,3) = EFDPOL(3,I+NDPST)
        CALL MRARBR(T3,3,3,3,T1,3,3,T2,3)
        CALL MRARBR(T2,3,3,3,T3T,3,3,T1,3)
        EFDPOL(1,NDPST+I) = T1(1,1)
        EFDPOL(4,NDPST+I) = T1(1,2)
        EFDPOL(5,NDPST+I) = T1(1,3)
        EFDPOL(7,NDPST+I) = T1(2,1)
        EFDPOL(2,NDPST+I) = T1(2,2)
        EFDPOL(6,NDPST+I) = T1(2,3)
        EFDPOL(8,NDPST+I) = T1(3,1)
        EFDPOL(9,NDPST+I) = T1(3,2)
        EFDPOL(3,NDPST+I) = T1(3,3)
  691 CONTINUE
C
C          --- UPDATE THE FITTED REPULSION POTENTIAL ---
C
      IRPTS = NRPTS(N)
      DO 720 I=1,IRPTS
        DO 710 J=1,3
          TEMP(J,I) = CREP(J,I+NRST) - EFCENT(J,N)
  710   CONTINUE
  720 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,IRPTS,CREP(1,NRST+1),3)
C
      DO 820 I=1,IRPTS
        DO 810 J=1,3
          CREP(J,I+NRST) = CREP(J,I+NRST) + EFCENT(J,N)
  810   CONTINUE
  820 CONTINUE
C
      DO 740 I = 1,IRPTS
        CREP(1,I+NRST) = CREP(1,I+NRST) + XDEL
        CREP(2,I+NRST) = CREP(2,I+NRST) + YDEL
        CREP(3,I+NRST) = CREP(3,I+NRST) + ZDEL
  740 CONTINUE
C
C          --- UPDATE THE DISPERSION POTENTIAL ---
C
      IF(IEFP2.EQ.1 .OR. MP2TYP.EQ.1) THEN
        IDPTS = NDPTS(N)
        DO 830 I=1,IDPTS
          DO 825 J=1,3
            TEMP(J,I) = CDIS(J,I+NDST) - EFCENT(J,N)
  825     CONTINUE
  830   CONTINUE
C
        CALL MRARBR(T3,3,3,3,TEMP,3,IDPTS,CDIS(1,NDST+1),3)
C
        DO 840 I=1,IDPTS
          DO 835 J=1,3
            CDIS(J,I+NDST) = CDIS(J,I+NDST) + EFCENT(J,N)
  835     CONTINUE
  840   CONTINUE
C
        DO 845 I = 1,IDPTS
          CDIS(1,I+NDST) = CDIS(1,I+NDST) + XDEL
          CDIS(2,I+NDST) = CDIS(2,I+NDST) + YDEL
          CDIS(3,I+NDST) = CDIS(3,I+NDST) + ZDEL
  845   CONTINUE
      END IF
C
C  PAULI REPULSION INFORMATION
C
      INAT = NAT(ISET(N))
      DO I=1,INAT
         DO J=1,3
            TEMP(J,I) = PRCORD(J,I+NATST) - EFCENT(J,N)
         END DO
      END DO
      CALL MRARBR(T3,3,3,3,TEMP,3,INAT,PRCORD(1,NATST+1),3)
      DO I=1,INAT
         PRCORD(1,I+NATST) = PRCORD(1,I+NATST) + XDEL + EFCENT(1,N)
         PRCORD(2,I+NATST) = PRCORD(2,I+NATST) + YDEL + EFCENT(2,N)
         PRCORD(3,I+NATST) = PRCORD(3,I+NATST) + ZDEL + EFCENT(3,N)
      END DO
C
      IMO = NORB(N)
      DO NSHL = 1,NSHELL(ISET(N))
         ITYP = KMAX(NSHL,ISET(N)) - KMIN(NSHL,ISET(N)) + 1
         LOC = KLOC(NSHL,ISET(N))
C
C  S: DO NOTHING
C
C  P:
C
         IF(ITYP.EQ.3) THEN
            DO I = 1,IMO
               TEMP3(1) = PROVEC(LOC,NORST+I)
               TEMP3(2) = PROVEC(LOC+1,NORST+I)
               TEMP3(3) = PROVEC(LOC+2,NORST+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               PROVEC(LOC,NORST+I) = TEMP4(1,1)
               PROVEC(LOC+1,NORST+I) = TEMP4(2,1)
               PROVEC(LOC+2,NORST+I) = TEMP4(3,1)
            END DO
         END IF
C  L:
         IF(ITYP.EQ.4) THEN
            DO I = 1,IMO
               TEMP3(1) = PROVEC(LOC+1,NORST+I)
               TEMP3(2) = PROVEC(LOC+2,NORST+I)
               TEMP3(3) = PROVEC(LOC+3,NORST+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               PROVEC(LOC+1,NORST+I) = TEMP4(1,1)
               PROVEC(LOC+2,NORST+I) = TEMP4(2,1)
               PROVEC(LOC+3,NORST+I) = TEMP4(3,1)
            END DO
         END IF
C  D:
C              THE NORMALIZATION FOR XY,XZ,YZ GAUSSIANS IS SQRT(3)
C              LARGER THAN XX,YY,ZZ. FACTOR OF TWO ALLOWS SUMMATION
C              OVER ALL INDICES RATHER THAN I,J<=I
C
         IF(ITYP.EQ.6) THEN
            DO I = 1,IMO
               TEMP2(1) = PROVEC(LOC,NORST+I)
               TEMP2(2) = PROVEC(LOC+3,NORST+I)/CONST
               TEMP2(3) = PROVEC(LOC+1,NORST+I)
               TEMP2(4) = PROVEC(LOC+4,NORST+I)/CONST
               TEMP2(5) = PROVEC(LOC+5,NORST+I)/CONST
               TEMP2(6) = PROVEC(LOC+2,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               PROVEC(LOC,NORST+I) = TEMP4(1,1)
               PROVEC(LOC+3,NORST+I) = TEMP4(2,1)*CONST
               PROVEC(LOC+1,NORST+I) = TEMP4(3,1)
               PROVEC(LOC+4,NORST+I) = TEMP4(4,1)*CONST
               PROVEC(LOC+5,NORST+I) = TEMP4(5,1)*CONST
               PROVEC(LOC+2,NORST+I) = TEMP4(6,1)
            END DO
         END IF
C  F:
         IF(ITYP.EQ.10) THEN
            DO I = 1,IMO
               PROVEC(LOC+3,NORST+I) = PROVEC(LOC+3,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+4,NORST+I) = PROVEC(LOC+4,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+5,NORST+I) = PROVEC(LOC+5,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+6,NORST+I) = PROVEC(LOC+6,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+7,NORST+I) = PROVEC(LOC+7,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+8,NORST+I) = PROVEC(LOC+8,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+9,NORST+I) = PROVEC(LOC+9,NORST+I)*
     *                                 SQRT5/THREE
               PROVEC(LOC+9,NORST+I) = PROVEC(LOC+9,NORST+I)*
     *                                 SQRT3/TWO
C
               TEMP2(1) = PROVEC(LOC  ,NORST+I)
               TEMP2(2) = PROVEC(LOC+3,NORST+I)
               TEMP2(3) = PROVEC(LOC+5,NORST+I)
               TEMP2(4) = PROVEC(LOC+4,NORST+I)
               TEMP2(5) = PROVEC(LOC+9,NORST+I)
               TEMP2(6) = PROVEC(LOC+7,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = PROVEC(LOC+3,NORST+I)
               TEMP2(2) = PROVEC(LOC+5,NORST+I)
               TEMP2(3) = PROVEC(LOC+1,NORST+I)
               TEMP2(4) = PROVEC(LOC+9,NORST+I)
               TEMP2(5) = PROVEC(LOC+6,NORST+I)
               TEMP2(6) = PROVEC(LOC+8,NORST+I)
               CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = PROVEC(LOC+4,NORST+I)
               TEMP2(2) = PROVEC(LOC+9,NORST+I)
               TEMP2(3) = PROVEC(LOC+6,NORST+I)
               TEMP2(4) = PROVEC(LOC+7,NORST+I)
               TEMP2(5) = PROVEC(LOC+8,NORST+I)
               TEMP2(6) = PROVEC(LOC+2,NORST+I)
               CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
               CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
C
               PROVEC(LOC  ,NORST+I) = TEMP5(1,1)
               PROVEC(LOC+1,NORST+I) = TEMP5(3,2)
               PROVEC(LOC+2,NORST+I) = TEMP5(6,3)
               PROVEC(LOC+3,NORST+I) = TEMP5(2,1)/SQRT5*THREE
               PROVEC(LOC+4,NORST+I) = TEMP5(4,1)/SQRT5*THREE
               PROVEC(LOC+5,NORST+I) = TEMP5(3,1)/SQRT5*THREE
               PROVEC(LOC+6,NORST+I) = TEMP5(5,2)/SQRT5*THREE
               PROVEC(LOC+7,NORST+I) = TEMP5(6,1)/SQRT5*THREE
               PROVEC(LOC+8,NORST+I) = TEMP5(6,2)/SQRT5*THREE
               PROVEC(LOC+9,NORST+I) = TEMP5(5,1)/SQRT5*THREE/
     *                                 SQRT3*TWO
C
            END DO
         END IF
C  G:
C
         IF(ITYP.EQ.15) THEN
            DO I = 1,IMO
               PROVEC(LOC+ 3,NORST+I) = PROVEC(LOC+ 3,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 4,NORST+I) = PROVEC(LOC+ 4,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 5,NORST+I) = PROVEC(LOC+ 5,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 6,NORST+I) = PROVEC(LOC+ 6,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 7,NORST+I) = PROVEC(LOC+ 7,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 8,NORST+I) = PROVEC(LOC+ 8,NORST+I)*
     *                                  SQRT7/FOUR
               PROVEC(LOC+ 9,NORST+I) = PROVEC(LOC+ 9,NORST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               PROVEC(LOC+10,NORST+I) = PROVEC(LOC+10,NORST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               PROVEC(LOC+11,NORST+I) = PROVEC(LOC+11,NORST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               PROVEC(LOC+12,NORST+I) = PROVEC(LOC+12,NORST+I)*SQRT7*
     *                                  SQRT5/TWELVE
               PROVEC(LOC+13,NORST+I) = PROVEC(LOC+13,NORST+I)*SQRT7*
     *                                  SQRT5/TWELVE
               PROVEC(LOC+14,NORST+I) = PROVEC(LOC+14,NORST+I)*SQRT7*
     *                                  SQRT5/TWELVE
C
C              PERFORM THE FIRST AND SECOND ROTATION
C
               TEMP2(1) = PROVEC(LOC   ,NORST+I)
               TEMP2(2) = PROVEC(LOC+ 3,NORST+I)
               TEMP2(3) = PROVEC(LOC+ 9,NORST+I)
               TEMP2(4) = PROVEC(LOC+ 4,NORST+I)
               TEMP2(5) = PROVEC(LOC+12,NORST+I)
               TEMP2(6) = PROVEC(LOC+10,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX(1) = TEMP4(1,1)
               TPXX(2) = TEMP4(2,1)
               TPXX(3) = TEMP4(3,1)
               TPXX(4) = TEMP4(4,1)
               TPXX(5) = TEMP4(5,1)
               TPXX(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 3,NORST+I)
               TEMP2(2) = PROVEC(LOC+ 9,NORST+I)
               TEMP2(3) = PROVEC(LOC+ 5,NORST+I)
               TEMP2(4) = PROVEC(LOC+12,NORST+I)
               TEMP2(5) = PROVEC(LOC+13,NORST+I)
               TEMP2(6) = PROVEC(LOC+14,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY(1) = TEMP4(1,1)
               TPXY(2) = TEMP4(2,1)
               TPXY(3) = TEMP4(3,1)
               TPXY(4) = TEMP4(4,1)
               TPXY(5) = TEMP4(5,1)
               TPXY(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 9,NORST+I)
               TEMP2(2) = PROVEC(LOC+ 5,NORST+I)
               TEMP2(3) = PROVEC(LOC+ 1,NORST+I)
               TEMP2(4) = PROVEC(LOC+13,NORST+I)
               TEMP2(5) = PROVEC(LOC+ 6,NORST+I)
               TEMP2(6) = PROVEC(LOC+11,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY(1) = TEMP4(1,1)
               TPYY(2) = TEMP4(2,1)
               TPYY(3) = TEMP4(3,1)
               TPYY(4) = TEMP4(4,1)
               TPYY(5) = TEMP4(5,1)
               TPYY(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 4,NORST+I)
               TEMP2(2) = PROVEC(LOC+12,NORST+I)
               TEMP2(3) = PROVEC(LOC+13,NORST+I)
               TEMP2(4) = PROVEC(LOC+10,NORST+I)
               TEMP2(5) = PROVEC(LOC+14,NORST+I)
               TEMP2(6) = PROVEC(LOC+ 7,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ(1) = TEMP4(1,1)
               TPXZ(2) = TEMP4(2,1)
               TPXZ(3) = TEMP4(3,1)
               TPXZ(4) = TEMP4(4,1)
               TPXZ(5) = TEMP4(5,1)
               TPXZ(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+12,NORST+I)
               TEMP2(2) = PROVEC(LOC+13,NORST+I)
               TEMP2(3) = PROVEC(LOC+ 6,NORST+I)
               TEMP2(4) = PROVEC(LOC+14,NORST+I)
               TEMP2(5) = PROVEC(LOC+11,NORST+I)
               TEMP2(6) = PROVEC(LOC+ 8,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ(1) = TEMP4(1,1)
               TPYZ(2) = TEMP4(2,1)
               TPYZ(3) = TEMP4(3,1)
               TPYZ(4) = TEMP4(4,1)
               TPYZ(5) = TEMP4(5,1)
               TPYZ(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+10,NORST+I)
               TEMP2(2) = PROVEC(LOC+14,NORST+I)
               TEMP2(3) = PROVEC(LOC+11,NORST+I)
               TEMP2(4) = PROVEC(LOC+ 7,NORST+I)
               TEMP2(5) = PROVEC(LOC+ 8,NORST+I)
               TEMP2(6) = PROVEC(LOC+ 2,NORST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ(1) = TEMP4(1,1)
               TPZZ(2) = TEMP4(2,1)
               TPZZ(3) = TEMP4(3,1)
               TPZZ(4) = TEMP4(4,1)
               TPZZ(5) = TEMP4(5,1)
               TPZZ(6) = TEMP4(6,1)
C
C              PERFORM THE THIRD AND FOURTH ROTATION
C
               TEMP2(1) = TPXX(1)
               TEMP2(2) = TPXY(1)
               TEMP2(3) = TPYY(1)
               TEMP2(4) = TPXZ(1)
               TEMP2(5) = TPYZ(1)
               TEMP2(6) = TPZZ(1)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX2(1) = TEMP4(1,1)
               TPXX2(2) = TEMP4(2,1)
               TPXX2(3) = TEMP4(3,1)
               TPXX2(4) = TEMP4(4,1)
               TPXX2(5) = TEMP4(5,1)
               TPXX2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(2)
               TEMP2(2) = TPXY(2)
               TEMP2(3) = TPYY(2)
               TEMP2(4) = TPXZ(2)
               TEMP2(5) = TPYZ(2)
               TEMP2(6) = TPZZ(2)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY2(1) = TEMP4(1,1)
               TPXY2(2) = TEMP4(2,1)
               TPXY2(3) = TEMP4(3,1)
               TPXY2(4) = TEMP4(4,1)
               TPXY2(5) = TEMP4(5,1)
               TPXY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(3)
               TEMP2(2) = TPXY(3)
               TEMP2(3) = TPYY(3)
               TEMP2(4) = TPXZ(3)
               TEMP2(5) = TPYZ(3)
               TEMP2(6) = TPZZ(3)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY2(1) = TEMP4(1,1)
               TPYY2(2) = TEMP4(2,1)
               TPYY2(3) = TEMP4(3,1)
               TPYY2(4) = TEMP4(4,1)
               TPYY2(5) = TEMP4(5,1)
               TPYY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(4)
               TEMP2(2) = TPXY(4)
               TEMP2(3) = TPYY(4)
               TEMP2(4) = TPXZ(4)
               TEMP2(5) = TPYZ(4)
               TEMP2(6) = TPZZ(4)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ2(1) = TEMP4(1,1)
               TPXZ2(2) = TEMP4(2,1)
               TPXZ2(3) = TEMP4(3,1)
               TPXZ2(4) = TEMP4(4,1)
               TPXZ2(5) = TEMP4(5,1)
               TPXZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(5)
               TEMP2(2) = TPXY(5)
               TEMP2(3) = TPYY(5)
               TEMP2(4) = TPXZ(5)
               TEMP2(5) = TPYZ(5)
               TEMP2(6) = TPZZ(5)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ2(1) = TEMP4(1,1)
               TPYZ2(2) = TEMP4(2,1)
               TPYZ2(3) = TEMP4(3,1)
               TPYZ2(4) = TEMP4(4,1)
               TPYZ2(5) = TEMP4(5,1)
               TPYZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(6)
               TEMP2(2) = TPXY(6)
               TEMP2(3) = TPYY(6)
               TEMP2(4) = TPXZ(6)
               TEMP2(5) = TPYZ(6)
               TEMP2(6) = TPZZ(6)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ2(1) = TEMP4(1,1)
               TPZZ2(2) = TEMP4(2,1)
               TPZZ2(3) = TEMP4(3,1)
               TPZZ2(4) = TEMP4(4,1)
               TPZZ2(5) = TEMP4(5,1)
               TPZZ2(6) = TEMP4(6,1)
C
               PROVEC(LOC   ,NORST+I) = TPXX2(1)
               PROVEC(LOC+ 1,NORST+I) = TPYY2(3)
               PROVEC(LOC+ 2,NORST+I) = TPZZ2(6)
               PROVEC(LOC+ 3,NORST+I) = TPXY2(1)/SQRT7*FOUR
               PROVEC(LOC+ 4,NORST+I) = TPXZ2(1)/SQRT7*FOUR
               PROVEC(LOC+ 5,NORST+I) = TPYY2(2)/SQRT7*FOUR
               PROVEC(LOC+ 6,NORST+I) = TPYZ2(3)/SQRT7*FOUR
               PROVEC(LOC+ 7,NORST+I) = TPXZ2(6)/SQRT7*FOUR
               PROVEC(LOC+ 8,NORST+I) = TPYZ2(6)/SQRT7*FOUR
               PROVEC(LOC+ 9,NORST+I) = TPYY2(1)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               PROVEC(LOC+10,NORST+I) = TPZZ2(1)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               PROVEC(LOC+11,NORST+I) = TPZZ2(3)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               PROVEC(LOC+12,NORST+I) = TPYZ2(1)/SQRT7/SQRT5*
     *                                  TWELVE
               PROVEC(LOC+13,NORST+I) = TPYZ2(2)/SQRT7/SQRT5*
     *                                  TWELVE
               PROVEC(LOC+14,NORST+I) = TPZZ2(2)/SQRT7/SQRT5*
     *                                  TWELVE
            END DO
         END IF
      END DO
C
      DO I=1,IMO
         DO J=1,3
            TEMP(J,I) = CENTCD(J,I+NORST) - EFCENT(J,N)
         END DO
      END DO
      CALL MRARBR(T3,3,3,3,TEMP,3,IMO,CENTCD(1,NORST+1),3)
      DO I=1,IMO
         CENTCD(1,I+NORST) = CENTCD(1,I+NORST) + XDEL + EFCENT(1,N)
         CENTCD(2,I+NORST) = CENTCD(2,I+NORST) + YDEL + EFCENT(2,N)
         CENTCD(3,I+NORST) = CENTCD(3,I+NORST) + ZDEL + EFCENT(3,N)
      END DO
C
C
C HUI
C  ROTATE CANONICAL VEC
C
      IAO = NPBF(N)
      DO NSHL = 1,NSHELL(ISET(N))
         ITYP = KMAX(NSHL,ISET(N)) - KMIN(NSHL,ISET(N)) + 1
         LOC = KLOC(NSHL,ISET(N))
C
C  S: DO NOTHING
C
C  P:
C
         IF(ITYP.EQ.3) THEN
            DO I = 1,IAO
               TEMP3(1) = CANVEC(LOC,NAOST+I)
               TEMP3(2) = CANVEC(LOC+1,NAOST+I)
               TEMP3(3) = CANVEC(LOC+2,NAOST+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               CANVEC(LOC,NAOST+I) = TEMP4(1,1)
               CANVEC(LOC+1,NAOST+I) = TEMP4(2,1)
               CANVEC(LOC+2,NAOST+I) = TEMP4(3,1)
            END DO
         END IF
C  L:
         IF(ITYP.EQ.4) THEN
            DO I = 1,IAO
               TEMP3(1) = CANVEC(LOC+1,NAOST+I)
               TEMP3(2) = CANVEC(LOC+2,NAOST+I)
               TEMP3(3) = CANVEC(LOC+3,NAOST+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               CANVEC(LOC+1,NAOST+I) = TEMP4(1,1)
               CANVEC(LOC+2,NAOST+I) = TEMP4(2,1)
               CANVEC(LOC+3,NAOST+I) = TEMP4(3,1)
            END DO
         END IF
C  D:
C              THE NORMALIZATION FOR XY,XZ,YZ GAUSSIANS IS SQRT(3)
C              LARGER THAN XX,YY,ZZ. FACTOR OF TWO ALLOWS SUMMATION
C              OVER ALL INDICES RATHER THAN I,J<=I
C
         IF(ITYP.EQ.6) THEN
            DO I = 1,IAO
               TEMP2(1) = CANVEC(LOC,NAOST+I)
               TEMP2(2) = CANVEC(LOC+3,NAOST+I)/CONST
               TEMP2(3) = CANVEC(LOC+1,NAOST+I)
               TEMP2(4) = CANVEC(LOC+4,NAOST+I)/CONST
               TEMP2(5) = CANVEC(LOC+5,NAOST+I)/CONST
               TEMP2(6) = CANVEC(LOC+2,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               CANVEC(LOC,NAOST+I) = TEMP4(1,1)
               CANVEC(LOC+3,NAOST+I) = TEMP4(2,1)*CONST
               CANVEC(LOC+1,NAOST+I) = TEMP4(3,1)
               CANVEC(LOC+4,NAOST+I) = TEMP4(4,1)*CONST
               CANVEC(LOC+5,NAOST+I) = TEMP4(5,1)*CONST
               CANVEC(LOC+2,NAOST+I) = TEMP4(6,1)
            END DO
         END IF
C  F:
         IF(ITYP.EQ.10) THEN
            DO I = 1,IAO
               CANVEC(LOC+3,NAOST+I) = CANVEC(LOC+3,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+4,NAOST+I) = CANVEC(LOC+4,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+5,NAOST+I) = CANVEC(LOC+5,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+6,NAOST+I) = CANVEC(LOC+6,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+7,NAOST+I) = CANVEC(LOC+7,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+8,NAOST+I) = CANVEC(LOC+8,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+9,NAOST+I) = CANVEC(LOC+9,NAOST+I)*
     *                                 SQRT5/THREE
               CANVEC(LOC+9,NAOST+I) = CANVEC(LOC+9,NAOST+I)*
     *                                 SQRT3/TWO
C
               TEMP2(1) = CANVEC(LOC  ,NAOST+I)
               TEMP2(2) = CANVEC(LOC+3,NAOST+I)
               TEMP2(3) = CANVEC(LOC+5,NAOST+I)
               TEMP2(4) = CANVEC(LOC+4,NAOST+I)
               TEMP2(5) = CANVEC(LOC+9,NAOST+I)
               TEMP2(6) = CANVEC(LOC+7,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = CANVEC(LOC+3,NAOST+I)
               TEMP2(2) = CANVEC(LOC+5,NAOST+I)
               TEMP2(3) = CANVEC(LOC+1,NAOST+I)
               TEMP2(4) = CANVEC(LOC+9,NAOST+I)
               TEMP2(5) = CANVEC(LOC+6,NAOST+I)
               TEMP2(6) = CANVEC(LOC+8,NAOST+I)
               CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = CANVEC(LOC+4,NAOST+I)
               TEMP2(2) = CANVEC(LOC+9,NAOST+I)
               TEMP2(3) = CANVEC(LOC+6,NAOST+I)
               TEMP2(4) = CANVEC(LOC+7,NAOST+I)
               TEMP2(5) = CANVEC(LOC+8,NAOST+I)
               TEMP2(6) = CANVEC(LOC+2,NAOST+I)
               CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
               CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
C
               CANVEC(LOC  ,NAOST+I) = TEMP5(1,1)
               CANVEC(LOC+1,NAOST+I) = TEMP5(3,2)
               CANVEC(LOC+2,NAOST+I) = TEMP5(6,3)
               CANVEC(LOC+3,NAOST+I) = TEMP5(2,1)/SQRT5*THREE
               CANVEC(LOC+4,NAOST+I) = TEMP5(4,1)/SQRT5*THREE
               CANVEC(LOC+5,NAOST+I) = TEMP5(3,1)/SQRT5*THREE
               CANVEC(LOC+6,NAOST+I) = TEMP5(5,2)/SQRT5*THREE
               CANVEC(LOC+7,NAOST+I) = TEMP5(6,1)/SQRT5*THREE
               CANVEC(LOC+8,NAOST+I) = TEMP5(6,2)/SQRT5*THREE
               CANVEC(LOC+9,NAOST+I) = TEMP5(5,1)/SQRT5*THREE/
     *                                 SQRT3*TWO
C
            END DO
         END IF
C  G:
C
         IF(ITYP.EQ.15) THEN
            DO I = 1,IAO
               CANVEC(LOC+ 3,NAOST+I) = CANVEC(LOC+ 3,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 4,NAOST+I) = CANVEC(LOC+ 4,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 5,NAOST+I) = CANVEC(LOC+ 5,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 6,NAOST+I) = CANVEC(LOC+ 6,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 7,NAOST+I) = CANVEC(LOC+ 7,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 8,NAOST+I) = CANVEC(LOC+ 8,NAOST+I)*
     *                                  SQRT7/FOUR
               CANVEC(LOC+ 9,NAOST+I) = CANVEC(LOC+ 9,NAOST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               CANVEC(LOC+10,NAOST+I) = CANVEC(LOC+10,NAOST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               CANVEC(LOC+11,NAOST+I) = CANVEC(LOC+11,NAOST+I)*SQRT7*
     *                                  SQRT5/SQRT3/SIX
               CANVEC(LOC+12,NAOST+I) = CANVEC(LOC+12,NAOST+I)*SQRT7*
     *                                  SQRT5/TWELVE
               CANVEC(LOC+13,NAOST+I) = CANVEC(LOC+13,NAOST+I)*SQRT7*
     *                                  SQRT5/TWELVE
               CANVEC(LOC+14,NAOST+I) = CANVEC(LOC+14,NAOST+I)*SQRT7*
     *                                  SQRT5/TWELVE
C
C              PERFORM THE FIRST AND SECOND ROTATION
C
               TEMP2(1) = CANVEC(LOC   ,NAOST+I)
               TEMP2(2) = CANVEC(LOC+ 3,NAOST+I)
               TEMP2(3) = CANVEC(LOC+ 9,NAOST+I)
               TEMP2(4) = CANVEC(LOC+ 4,NAOST+I)
               TEMP2(5) = CANVEC(LOC+12,NAOST+I)
               TEMP2(6) = CANVEC(LOC+10,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX(1) = TEMP4(1,1)
               TPXX(2) = TEMP4(2,1)
               TPXX(3) = TEMP4(3,1)
               TPXX(4) = TEMP4(4,1)
               TPXX(5) = TEMP4(5,1)
               TPXX(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 3,NAOST+I)
               TEMP2(2) = CANVEC(LOC+ 9,NAOST+I)
               TEMP2(3) = CANVEC(LOC+ 5,NAOST+I)
               TEMP2(4) = CANVEC(LOC+12,NAOST+I)
               TEMP2(5) = CANVEC(LOC+13,NAOST+I)
               TEMP2(6) = CANVEC(LOC+14,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY(1) = TEMP4(1,1)
               TPXY(2) = TEMP4(2,1)
               TPXY(3) = TEMP4(3,1)
               TPXY(4) = TEMP4(4,1)
               TPXY(5) = TEMP4(5,1)
               TPXY(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 9,NAOST+I)
               TEMP2(2) = CANVEC(LOC+ 5,NAOST+I)
               TEMP2(3) = CANVEC(LOC+ 1,NAOST+I)
               TEMP2(4) = CANVEC(LOC+13,NAOST+I)
               TEMP2(5) = CANVEC(LOC+ 6,NAOST+I)
               TEMP2(6) = CANVEC(LOC+11,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY(1) = TEMP4(1,1)
               TPYY(2) = TEMP4(2,1)
               TPYY(3) = TEMP4(3,1)
               TPYY(4) = TEMP4(4,1)
               TPYY(5) = TEMP4(5,1)
               TPYY(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 4,NAOST+I)
               TEMP2(2) = CANVEC(LOC+12,NAOST+I)
               TEMP2(3) = CANVEC(LOC+13,NAOST+I)
               TEMP2(4) = CANVEC(LOC+10,NAOST+I)
               TEMP2(5) = CANVEC(LOC+14,NAOST+I)
               TEMP2(6) = CANVEC(LOC+ 7,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ(1) = TEMP4(1,1)
               TPXZ(2) = TEMP4(2,1)
               TPXZ(3) = TEMP4(3,1)
               TPXZ(4) = TEMP4(4,1)
               TPXZ(5) = TEMP4(5,1)
               TPXZ(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+12,NAOST+I)
               TEMP2(2) = CANVEC(LOC+13,NAOST+I)
               TEMP2(3) = CANVEC(LOC+ 6,NAOST+I)
               TEMP2(4) = CANVEC(LOC+14,NAOST+I)
               TEMP2(5) = CANVEC(LOC+11,NAOST+I)
               TEMP2(6) = CANVEC(LOC+ 8,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ(1) = TEMP4(1,1)
               TPYZ(2) = TEMP4(2,1)
               TPYZ(3) = TEMP4(3,1)
               TPYZ(4) = TEMP4(4,1)
               TPYZ(5) = TEMP4(5,1)
               TPYZ(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+10,NAOST+I)
               TEMP2(2) = CANVEC(LOC+14,NAOST+I)
               TEMP2(3) = CANVEC(LOC+11,NAOST+I)
               TEMP2(4) = CANVEC(LOC+ 7,NAOST+I)
               TEMP2(5) = CANVEC(LOC+ 8,NAOST+I)
               TEMP2(6) = CANVEC(LOC+ 2,NAOST+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ(1) = TEMP4(1,1)
               TPZZ(2) = TEMP4(2,1)
               TPZZ(3) = TEMP4(3,1)
               TPZZ(4) = TEMP4(4,1)
               TPZZ(5) = TEMP4(5,1)
               TPZZ(6) = TEMP4(6,1)
C
C              PERFORM THE THIRD AND FOURTH ROTATION
C
               TEMP2(1) = TPXX(1)
               TEMP2(2) = TPXY(1)
               TEMP2(3) = TPYY(1)
               TEMP2(4) = TPXZ(1)
               TEMP2(5) = TPYZ(1)
               TEMP2(6) = TPZZ(1)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX2(1) = TEMP4(1,1)
               TPXX2(2) = TEMP4(2,1)
               TPXX2(3) = TEMP4(3,1)
               TPXX2(4) = TEMP4(4,1)
               TPXX2(5) = TEMP4(5,1)
               TPXX2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(2)
               TEMP2(2) = TPXY(2)
               TEMP2(3) = TPYY(2)
               TEMP2(4) = TPXZ(2)
               TEMP2(5) = TPYZ(2)
               TEMP2(6) = TPZZ(2)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY2(1) = TEMP4(1,1)
               TPXY2(2) = TEMP4(2,1)
               TPXY2(3) = TEMP4(3,1)
               TPXY2(4) = TEMP4(4,1)
               TPXY2(5) = TEMP4(5,1)
               TPXY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(3)
               TEMP2(2) = TPXY(3)
               TEMP2(3) = TPYY(3)
               TEMP2(4) = TPXZ(3)
               TEMP2(5) = TPYZ(3)
               TEMP2(6) = TPZZ(3)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY2(1) = TEMP4(1,1)
               TPYY2(2) = TEMP4(2,1)
               TPYY2(3) = TEMP4(3,1)
               TPYY2(4) = TEMP4(4,1)
               TPYY2(5) = TEMP4(5,1)
               TPYY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(4)
               TEMP2(2) = TPXY(4)
               TEMP2(3) = TPYY(4)
               TEMP2(4) = TPXZ(4)
               TEMP2(5) = TPYZ(4)
               TEMP2(6) = TPZZ(4)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ2(1) = TEMP4(1,1)
               TPXZ2(2) = TEMP4(2,1)
               TPXZ2(3) = TEMP4(3,1)
               TPXZ2(4) = TEMP4(4,1)
               TPXZ2(5) = TEMP4(5,1)
               TPXZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(5)
               TEMP2(2) = TPXY(5)
               TEMP2(3) = TPYY(5)
               TEMP2(4) = TPXZ(5)
               TEMP2(5) = TPYZ(5)
               TEMP2(6) = TPZZ(5)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ2(1) = TEMP4(1,1)
               TPYZ2(2) = TEMP4(2,1)
               TPYZ2(3) = TEMP4(3,1)
               TPYZ2(4) = TEMP4(4,1)
               TPYZ2(5) = TEMP4(5,1)
               TPYZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(6)
               TEMP2(2) = TPXY(6)
               TEMP2(3) = TPYY(6)
               TEMP2(4) = TPXZ(6)
               TEMP2(5) = TPYZ(6)
               TEMP2(6) = TPZZ(6)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ2(1) = TEMP4(1,1)
               TPZZ2(2) = TEMP4(2,1)
               TPZZ2(3) = TEMP4(3,1)
               TPZZ2(4) = TEMP4(4,1)
               TPZZ2(5) = TEMP4(5,1)
               TPZZ2(6) = TEMP4(6,1)
C
               CANVEC(LOC   ,NAOST+I) = TPXX2(1)
               CANVEC(LOC+ 1,NAOST+I) = TPYY2(3)
               CANVEC(LOC+ 2,NAOST+I) = TPZZ2(6)
               CANVEC(LOC+ 3,NAOST+I) = TPXY2(1)/SQRT7*FOUR
               CANVEC(LOC+ 4,NAOST+I) = TPXZ2(1)/SQRT7*FOUR
               CANVEC(LOC+ 5,NAOST+I) = TPYY2(2)/SQRT7*FOUR
               CANVEC(LOC+ 6,NAOST+I) = TPYZ2(3)/SQRT7*FOUR
               CANVEC(LOC+ 7,NAOST+I) = TPXZ2(6)/SQRT7*FOUR
               CANVEC(LOC+ 8,NAOST+I) = TPYZ2(6)/SQRT7*FOUR
               CANVEC(LOC+ 9,NAOST+I) = TPYY2(1)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               CANVEC(LOC+10,NAOST+I) = TPZZ2(1)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               CANVEC(LOC+11,NAOST+I) = TPZZ2(3)/SQRT7/SQRT5*
     *                                  SQRT3*SIX
               CANVEC(LOC+12,NAOST+I) = TPYZ2(1)/SQRT7/SQRT5*
     *                                  TWELVE
               CANVEC(LOC+13,NAOST+I) = TPYZ2(2)/SQRT7/SQRT5*
     *                                  TWELVE
               CANVEC(LOC+14,NAOST+I) = TPZZ2(2)/SQRT7/SQRT5*
     *                                  TWELVE
            END DO
         END IF
      END DO
C
      CALL EFCM
C
      RETURN
      END
C*MODULE STATPT   *DECK EFROTT
      SUBROUTINE EFROTT(X,Y,Z,T)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION T(3,3)
C
      PARAMETER (ONE = 1.0D+00, SMALL = 1.0D-08, HALF = 0.5D+00)
C
      X2=X**2
      Y2=Y**2
      Z2=Z**2
      XY=X*Y
      XZ=X*Z
      YZ=Z*Y
      TAL2=X2+Y2+Z2
      TALL=SQRT(TAL2)
      IF (TALL.LT.SMALL) THEN
        T1=ONE
        T2=HALF
      ELSE
        T1=SIN(TALL)/TALL
        T2=(1-COS(TALL))/TAL2
      END IF
C
      T(1,1) =  ONE  - (Y2+Z2)*T2
      T(1,2) = -Z*T1 + XY*T2
      T(1,3) =  Y*T1 + XZ*T2
      T(2,1) =  Z*T1 + XY*T2
      T(2,2) =  ONE  - (X2+Z2)*T2
      T(2,3) = -X*T1 + YZ*T2
      T(3,1) = -Y*T1 + XZ*T2
      T(3,2) =  X*T1 + YZ*T2
      T(3,3) =  ONE  - (X2+Y2)*T2
C
      RETURN
      END
C*MODULE STATPT  *DECK EGMOVE
      SUBROUTINE EGMOVE(F,EG,DEFT,TORQ,NC,NFRG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION F(*),EG(*),DEFT(3,*),TORQ(3,*)
C
      CALL DCOPY(NC,EG,1,F,1)
      I=NC
      DO 120 INFR=1,NFRG
         DO 100 IX=1,3
            I=I+1
            F(I)=DEFT(IX,INFR)
 100     CONTINUE
         DO 110 IX=1,3
            I=I+1
            F(I)=TORQ(IX,INFR)
 110     CONTINUE
 120  CONTINUE
      RETURN
      END
C*MODULE STATPT  *DECK GEFCOV
      SUBROUTINE GEFCOV(DEFT,TORQ,NFRG,EFGMAX,EFGRMS,EFCONV,EFOPTT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL EFCONV
      DIMENSION DEFT(3*NFRG),TORQ(3*NFRG)
      DATA THREE/3.0D+00/
C
      EFCONV=.TRUE.
      IF (NFRG.EQ.0) RETURN
C
      NCF2=NFRG*3
      NC1=2*NCF2
      LOC = IDAMAX(NCF2,DEFT,1)
      GMAX1 = ABS(DEFT(LOC))
      LOC = IDAMAX(NCF2,TORQ,1)
      GMAX2 = ABS(TORQ(LOC))
      EFGMAX=MAX(GMAX1,GMAX2)
      GRMS1 = DDOT(NCF2,DEFT,1,DEFT,1)
      GRMS2 = DDOT(NCF2,TORQ,1,TORQ,1)
      EFGRMS = SQRT((GRMS1+GRMS2)/NC1)
      IF (EFGMAX.GT.EFOPTT.OR.EFGRMS.GT.(EFOPTT/THREE)) EFCONV=.FALSE.
C
      RETURN
      END
C*MODULE STATPT  *DECK GETQ0
      SUBROUTINE GETQ0(Q0,NCVAL,IZMAT,NZMAT,DELCOR,PI)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION Q0(NCVAL),IZMAT(NZMAT),DELCOR(NCVAL)
C
      PARAMETER (ZERO=0.00D+00,TWO=2.00D+00)
C
C   THIS ROUTINE CALCULATES THE UPDATED INTERNALS.
C
      IADD  = 1
      TWOPI = TWO * PI
C
      DO 200 I = 1,NCVAL
         Q0(I) = Q0(I) + DELCOR(I)
         ITYPE = IZMAT(IADD)
         GO TO (110,120,130,140,150,160,170,180),ITYPE
C
C    ---- BOND STRETCH ----
C
  110    CONTINUE
         IADD = IADD + 3
         GO TO 200
C
C    ---- ANGLE BEND ----
C
  120    CONTINUE
         IF (Q0(I).GT.PI) Q0(I) = TWOPI - Q0(I)
         IADD = IADD + 4
         GO TO 200
C
C    ---- TORSION ----
C
  130    CONTINUE
         IF (ABS(Q0(I)).GT.PI) THEN
            IF (Q0(I).LT.ZERO) THEN
               Q0(I) = Q0(I) + TWOPI
            ELSE
               Q0(I) = Q0(I) - TWOPI
            END IF
         END IF
         IADD = IADD + 5
         GO TO 200
C
C    ---- OUT OF PLANE ANGLE BEND ----
C
  140    CONTINUE
         IF (ABS(Q0(I)).GT.(PI/TWO)) THEN
            IF (Q0(I).LT.ZERO) THEN
               Q0(I) = ABS(Q0(I)) - PI
            ELSE
               Q0(I) = PI - Q0(I)
            END IF
         END IF
         IADD = IADD + 5
         GO TO 200
C
C    ---- LINEAR ANGLE BEND ----
C
  150    CONTINUE
         IADD = IADD + 4
         GO TO 200
C
C    ---- DIHEDRAL ANGLE BETWEEN TWO PLANES ----
C
  160    CONTINUE
         IF (ABS(Q0(I)).GT.PI) THEN
            IF (Q0(I).LT.ZERO) THEN
               Q0(I) = Q0(I) + TWOPI
            ELSE
               Q0(I) = Q0(I) - TWOPI
            END IF
         END IF
         IADD = IADD + 6
         GO TO 200
C
C    ---- GHOST TORSION ----
C
  170    CONTINUE
         IF (ABS(Q0(I)).GT.PI) THEN
            IF (Q0(I).LT.ZERO) THEN
               Q0(I) = Q0(I) + TWOPI
            ELSE
               Q0(I) = Q0(I) - TWOPI
            END IF
         END IF
         IADD = IADD + 7
         GO TO 200
C
C    ----- SYMMETRY COORDINATE -----
C
  180    CONTINUE
         IADD = IADD + 1
         GO TO 200
C
  200 CONTINUE
      RETURN
      END
C*MODULE STATPT  *DECK HESGES
      SUBROUTINE HESGES(HGUESS,HESS,LDHESS,NFRG,
     *                  IZMAT,LIZMAT,ZMAT,LZMAT,DIST,NATM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL LINEAR,GOPARR,MASWRK,DSKWRK,SYM,BADZ
C
      PARAMETER (MXATM=2000)
C
      DIMENSION HESS(LDHESS,LDHESS),IZMAT(LIZMAT),ZMAT(LZMAT),
     *          DIST(NATM,NATM)
      DIMENSION IROW(86),DPARM(6,6),APARM(6,6),RCOV(86)
      DIMENSION BONDH(3,3)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(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 /NEOJOB/ NEORUN,NELERM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SYMINT/ SYM
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
C
      PARAMETER (ZERO=0.0D+00, QUARTR=0.25D+00, ONE=1.0D+00,
     *           THIRD=ONE/3.0D+00, BITSY=1.0D-05, TOHB2=6.423D-02,
     *           TOANGS=0.52917724924D+00)
C
C          DATA TABLES FOR BADGER'S RULES (SEE J.C.P. 2, 128(1934))
C          A GENERALIZED BADGER'S RULE, AND THESE PARAMETERS ARE FROM
C          D.R.HERSCHBACH, V.W.LAURIE, J.CHEM.PHYS. 35, 458-463(1961).
C
      DATA IROW/2*1,8*2,8*3,18*4,18*5,32*6/
      DATA APARM/1.26D+00,1.66D+00,1.84D+00,1.98D+00,2.03D+00,2.03D+00,
     *           1.66D+00,1.91D+00,2.28D+00,2.35D+00,2.33D+00,2.50D+00,
     *           1.84D+00,2.28D+00,2.41D+00,2.52D+00,2.61D+00,2.60D+00,
     *           1.98D+00,2.35D+00,2.52D+00,2.58D+00,2.66D+00,2.75D+00,
     *           2.03D+00,2.33D+00,2.61D+00,2.66D+00,2.85D+00,2.76D+00,
     *           2.03D+00,2.50D+00,2.60D+00,2.75D+00,2.75D+00,3.00D+00/
      DATA DPARM/2.50D-02,0.30D+00,0.38D+00,0.49D+00,0.51D+00,0.81D+00,
     *           0.30D+00,0.68D+00,0.74D+00,0.85D+00,0.68D+00,0.97D+00,
     *           0.38D+00,0.74D+00,1.18D+00,1.02D+00,1.28D+00,0.84D+00,
     *           0.49D+00,0.85D+00,1.02D+00,1.41D+00,0.86D+00,1.14D+00,
     *           0.51D+00,0.68D+00,1.28D+00,0.86D+00,1.62D+00,1.25D+00,
     *           0.81D+00,0.97D+00,0.84D+00,1.14D+00,1.25D+00,1.83D+00/
C
C      COVALENT RADII FROM J.EMSLEY, "THE ELEMENTS", 2ND EDITION, 1991
C      EXCEPT VAN DER WAALS RADII FOR HE,NE,AR,KR (SAME SOURCE),
C      AND GUESSES FOR NA,V,CR,RB,TC,PM,EU,YB,AT,RN
C
      DATA (RCOV(NUCZ),NUCZ=1,2)/0.30D+00,1.22D+00/
      DATA (RCOV(NUCZ),NUCZ=3,10)
     *  /1.23D+00,0.89D+00,0.88D+00,0.77D+00,
     *   0.70D+00,0.66D+00,0.58D+00,1.60D+00/
      DATA (RCOV(NUCZ),NUCZ=11,18)
     *  /1.66D+00,1.36D+00,1.25D+00,1.17D+00,
     *   1.10D+00,1.04D+00,0.99D+00,1.91D+00/
      DATA (RCOV(NUCZ),NUCZ=19,36)
     *  /2.03D+00,1.74D+00,
     *   1.44D+00,1.32D+00,1.22D+00,1.19D+00,1.17D+00,
     *   1.165D+00,1.16D+00,1.15D+00,1.17D+00,1.25D+00,
     *   1.25D+00,1.22D+00,1.21D+00,1.17D+00,1.14D+00,1.98D+00/
      DATA (RCOV(NUCZ),NUCZ=37,54)
     *  /2.22D+00,1.92D+00,
     *   1.62D+00,1.45D+00,1.34D+00,1.29D+00,1.27D+00,
     *   1.24D+00,1.25D+00,1.28D+00,1.34D+00,1.41D+00,
     *   1.50D+00,1.40D+00,1.41D+00,1.37D+00,1.33D+00,2.09D+00/
      DATA (RCOV(NUCZ),NUCZ=55,86)
     *  /2.35D+00,1.98D+00,
     *   1.69D+00,1.65D+00,1.65D+00,1.64D+00,1.65D+00,1.66D+00,1.65D+00,
     *   1.61D+00,1.59D+00,1.59D+00,1.58D+00,1.57D+00,1.56D+00,1.56D+00,
     *   1.56D+00,1.44D+00,1.34D+00,1.30D+00,1.28D+00,
     *   1.26D+00,1.26D+00,1.29D+00,1.34D+00,1.44D+00,
     *   1.55D+00,1.54D+00,1.52D+00,1.53D+00,1.50D+00,2.20D+00/
C
      DATA GUESS,GUESS1,GUESS2/8HGUESS   ,8HGUESS1  ,8HGUESS2  /
C
      BADZ(IARG) = IARG.LE.0  .OR.  IARG.GT.86
C
C     THIS ROUTINE MAKES A DIAGONAL GUESS OF THE HESSIAN,
C     RETURNING IT IN CARTESIAN OR INTERNAL COORDINATE SPACE.
C
      CALL VCLR(HESS,1,LDHESS*LDHESS)
      IF(NZMAT.GT.0) GO TO 300
C
C     ----- AB INITIO PART OF SYSTEM, IN CARTESIAN COORDINATES -----
C     ALL POSSIBLE "BONDS" (ATOM PAIRS) ARE GIVEN A STRETCHING
C     FORCE CONSTANT, BASED ON DISTANCE BETWEEN THEM COMPARED TO
C     COVALENT RADII.
C
      IF(MASWRK .AND.  NAT.GT.0  .AND.  NPRTGO.NE.2) WRITE(IW,9010)
C
      DO I=1,NAT
       DO J=1,I-1
         IF(NEORUN.EQ.0) THEN
            IZA = INT(ZAN(I)) + IZCORE(I)
            IZB = INT(ZAN(J)) + IZCORE(J)
         ELSE
            CALL NEOIZ(ZAN(I),ZAN(J),IZA,IZB,I,J)
         END IF
         RX = (C(1,I)-C(1,J)) * TOANGS
         RY = (C(2,I)-C(2,J)) * TOANGS
         RZ = (C(3,I)-C(3,J)) * TOANGS
         RR = RX*RX + RY*RY + RZ*RZ
         RAB = SQRT(RR)
         IF(BADZ(IZA)) THEN
           CAB = 2.2D0
         ELSE
           CAB = RCOV(IZA)
         END IF
         IF(BADZ(IZB)) THEN
           CAB = CAB + 2.2D0
         ELSE
           CAB = CAB + RCOV(IZB)
         END IF
C          HESS2 IS HESSIAN WITH RESPECT TO RAB (SEE FISCHER/ALMLOF)
         HESS2 = 0.3601D+00 * EXP(-1.944D+00*(RAB - CAB))
C          NOW CONVERT TO CARTESIANS BY CHAIN RULE
         BONDH(1,1) = (RX*RX*HESS2)/RR
         BONDH(1,2) = (RX*RY*HESS2)/RR
         BONDH(1,3) = (RX*RZ*HESS2)/RR
         BONDH(2,2) = (RY*RY*HESS2)/RR
         BONDH(2,3) = (RY*RZ*HESS2)/RR
         BONDH(3,3) = (RZ*RZ*HESS2)/RR
         BONDH(2,1) = BONDH(1,2)
         BONDH(3,1) = BONDH(1,3)
         BONDH(3,2) = BONDH(2,3)
C
         IPOST = (I - 1)*3
         JPOST = (J - 1)*3
         DO II = 1,3
          DO JJ = 1,3
           HESS(IPOST+II,IPOST+JJ)=HESS(IPOST+II,IPOST+JJ)+BONDH(II,JJ)
           HESS(JPOST+II,JPOST+JJ)=HESS(JPOST+II,JPOST+JJ)+BONDH(II,JJ)
           HESS(IPOST+II,JPOST+JJ)=HESS(IPOST+II,JPOST+JJ)-BONDH(II,JJ)
           HESS(JPOST+II,IPOST+JJ)=HESS(JPOST+II,IPOST+JJ)-BONDH(II,JJ)
          END DO
         END DO
       END DO
      END DO
C
C     MAKE SURE WE ARE NOT MESSED UP BY LINEAR BENDS, OR FAR AWAY ATOMS
C
      DO I=1,NAT*3
       IF (HESS(I,I) .LT. BITSY) HESS(I,I) = BITSY
      END DO
C
      IF(NFRG.EQ.0) RETURN
C                   ******
C
      HESSII1 = 0.01D+00
      HESSII2 = 0.03D+00
      IJ=3*NAT
      DO 250 I=1,NFRG
         DO 230 J=1,3
            IJ=IJ+1
            HESS(IJ,IJ) = HESSII1
  230    CONTINUE
         DO 240 J=1,3
            IJ=IJ+1
            HESS(IJ,IJ) = HESSII2
  240    CONTINUE
  250 CONTINUE
      IF(MASWRK  .AND.  NPRTGO.NE.2) THEN
         WRITE(IW,9021) HESSII1
         WRITE(IW,9022) HESSII2
      ENDIF
      RETURN
C     ******
C
C     ----- INTERNAL COORDINATES -----
C     FOR MORE INFORMATION ON -GUESS1- OR -GUESS2- SEE
C     H.B.SCHLEGEL, THEORET.CHIM.ACTA, 66, 333-340 (1984).
C     T.H.FISCHER, J.ALMLOF, J.PHYS.CHEM. 96, 9768-9774 (1992).
C     -GUESS1- AND -GUESS2- ARE UNDOCUMENTED WAYS TO GET PURE
C     BADGER'S RULES, OR PURE FISCHER/ALMLOF RULES.
C     THE DEFAULT -GUESS- USES F/A FOR STRETCHES AND BENDS,
C     BUT NOT FOR TORSIONS OR OUT-OF-PLANE BENDS.
C
  300 CONTINUE
C                        GENERATE DISTANCE MATRIX
      DO 330 I=1,NAT
         DO 320 J=1,I
            DIST(J,I) = SQRT((C(1,I)-C(1,J))**2
     *                     + (C(2,I)-C(2,J))**2
     *                     + (C(3,I)-C(3,J))**2) * TOANGS
            DIST(I,J) = DIST(J,I)
  320    CONTINUE
  330 CONTINUE
C
      CALL DAREAD(IDAF,IODA,ZMAT, NZVAR,39,0)
      CALL DAREAD(IDAF,IODA,IZMAT,NZMAT,40,1)
C
C         SET UP HESSIAN FOR AB INITIO MOLECULE
C
      IZ=1
      NDEGEN=0
      DO 490 I=1,NZVAR
         IF(I.LE.NZVAR) THEN
            ITYPE=IZMAT(IZ)
         END IF
C
C                  BOND STRETCH, B-A
C
         IF(ITYPE.GT.1) GO TO 420
         IZ1 = IZMAT(IZ+1)
         IZ2 = IZMAT(IZ+2)
         IZA = INT(ZAN(IZ1)) + IZCORE(IZ1)
         IZB = INT(ZAN(IZ2)) + IZCORE(IZ2)
         IF(BADZ(IZA)  .OR.  BADZ(IZB)) THEN
            HESS(I,I) = THIRD
            GO TO 480
         END IF
C
         IROWA = IROW(IZA)
         IROWB = IROW(IZB)
         AIJ = APARM(IROWA,IROWB)
         DIJ = DPARM(IROWA,IROWB)
         RRR = TOANGS*ZMAT(I)
         HII = (AIJ-DIJ)/(RRR-DIJ)
         HESS1 = TOHB2 * HII * HII * HII
C
         RAB = DIST(IZ1,IZ2)
         CAB = RCOV(IZA) + RCOV(IZB)
         HESS2 = 0.3601D+00 * EXP(-1.944D+00*(RAB - CAB))
C
         IF(HGUESS.EQ.GUESS)  HESS(I,I) = HESS2
         IF(HGUESS.EQ.GUESS1) HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS2) HESS(I,I) = HESS2
         GO TO 480
C
C                  ANGLE BEND, B-A-C
C
  420    CONTINUE
         IF(ITYPE.GT.2) GO TO 430
         IZ1 = IZMAT(IZ+1)
         IZ2 = IZMAT(IZ+2)
         IZ3 = IZMAT(IZ+3)
         IZB = INT(ZAN(IZ1)) + IZCORE(IZ1)
         IZA = INT(ZAN(IZ2)) + IZCORE(IZ2)
         IZC = INT(ZAN(IZ3)) + IZCORE(IZ3)
         IF(BADZ(IZA)  .OR.  BADZ(IZB)  .OR.  BADZ(IZC)) THEN
            HESS(I,I) = QUARTR
            GO TO 480
         END IF
C
         HESS1 = QUARTR
         IF(IZB.EQ.1  .OR.  IZC.EQ.1) HESS1 = 0.16D+00
C
         RAB = DIST(IZ2,IZ1)
         RAC = DIST(IZ2,IZ3)
         CAB = RCOV(IZA) + RCOV(IZB)
         CAC = RCOV(IZA) + RCOV(IZC)
         HESS2 = 0.089D+00 + 0.11D+00 * (CAB*CAC)**0.42D+00
     *                   * EXP(-0.44D+00*(RAB + RAC - CAB - CAC))
C
         IF(HGUESS.EQ.GUESS)  HESS(I,I) = HESS2
         IF(HGUESS.EQ.GUESS1) HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS2) HESS(I,I) = HESS2
         GO TO 480
C
C                  TORSION, D-A-B-C
C
  430    CONTINUE
         IF(ITYPE.GT.3) GO TO 440
         IZ1 = IZMAT(IZ+1)
         IZ2 = IZMAT(IZ+2)
         IZ3 = IZMAT(IZ+3)
         IZ4 = IZMAT(IZ+4)
         IZD = INT(ZAN(IZ1)) + IZCORE(IZ1)
         IZA = INT(ZAN(IZ2)) + IZCORE(IZ2)
         IZB = INT(ZAN(IZ3)) + IZCORE(IZ3)
         IZC = INT(ZAN(IZ4)) + IZCORE(IZ4)
         IF(BADZ(IZA) .OR. BADZ(IZB) .OR. BADZ(IZC) .OR. BADZ(IZD)) THEN
            HESS(I,I) = QUARTR
            GO TO 480
         END IF
C
         HESS1 = QUARTR
C
C            COUNT BONDS TO ATOMS A AND B, EXCEPT FOR A-B ITSELF
C
         NBA = 0
         NBB = 0
         DO 435 J=1,NAT
            IZJ = INT(ZAN(J)) + IZCORE(J)
            IF(IZJ.LE.0) GO TO 435
            IF(IZJ.LE.86) THEN
               CAJ = RCOV(IZA) + RCOV(IZJ)
               CBJ = RCOV(IZB) + RCOV(IZJ)
            ELSE
               CAJ = RCOV(IZA) + 1.70D+00
               CBJ = RCOV(IZB) + 1.70D+00
            END IF
            IF(DIST(IZ2,J)  .LT.  1.2D+00*CAJ  .AND.
     *         J.NE.IZ2  .AND.  J.NE.IZ3) NBA = NBA+1
            IF(DIST(IZ3,J)  .LT.  1.2D+00*CBJ  .AND.
     *         J.NE.IZ3  .AND.  J.NE.IZ2) NBB = NBB+1
  435    CONTINUE
C
C     THE FACTOR 14.0 IN PREEXP SEEMS LARGE, SO BRACKET THE RESULT
C
         RAB = DIST(IZ2,IZ3)
         CAB = RCOV(IZA) + RCOV(IZB)
         PREEXP = 14.0D+00 * (NBA+NBB)**0.57D+00 / (RAB*CAB)**4
         HESS2 = 0.0015D+00 + PREEXP * EXP(-2.85D+00*(RAB-CAB))
         IF(HESS2.GT.0.30D+00) HESS2 = 0.30D+00
         IF(HESS2.LT.0.05D+00) HESS2 = 0.05D+00
C
         IF(HGUESS.EQ.GUESS)  HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS1) HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS2) HESS(I,I) = HESS2
         GO TO 480
C
C                  OUT OF PLANE BEND, X-A-B-C, X IS HOOKED TO A
C
  440    CONTINUE
         IF(ITYPE.GT.4) GO TO 450
         IZ1 = IZMAT(IZ+1)
         IZ2 = IZMAT(IZ+2)
         IZ3 = IZMAT(IZ+3)
         IZ4 = IZMAT(IZ+4)
         IZX = INT(ZAN(IZ1)) + IZCORE(IZ1)
         IZA = INT(ZAN(IZ2)) + IZCORE(IZ2)
         IZB = INT(ZAN(IZ3)) + IZCORE(IZ3)
         IZC = INT(ZAN(IZ4)) + IZCORE(IZ4)
         IF(BADZ(IZA) .OR. BADZ(IZB) .OR. BADZ(IZC) .OR. BADZ(IZX)) THEN
            HESS(I,I) = QUARTR
            GO TO 480
         END IF
C
         HESS1 = QUARTR
C
         CAX = RCOV(IZA) + RCOV(IZX)
         CAB = RCOV(IZA) + RCOV(IZB)
         CAC = RCOV(IZA) + RCOV(IZC)
         RAX = DIST(IZ1,IZ2)
         PREEXP = 0.0061D+00 *
     *            (CAB*CAC)**0.80D+00 * (COS(ZMAT(I)))**4.00D+00
         HESS2 = 0.0025D+00 + PREEXP * EXP(-3.00D+00*(RAX-CAX))
C
         IF(HGUESS.EQ.GUESS)  HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS1) HESS(I,I) = HESS1
         IF(HGUESS.EQ.GUESS2) HESS(I,I) = HESS2
         GO TO 480
C
C                  ALL OTHER COORDINATE TYPES...
C
  450    CONTINUE
         HESS(I,I)=QUARTR
C
  480    CONTINUE
         IF(ITYPE.EQ.1) IZ=IZ+3
         IF(ITYPE.EQ.2) IZ=IZ+4
         IF(ITYPE.EQ.3) IZ=IZ+5
         IF(ITYPE.EQ.4) IZ=IZ+5
         IF(ITYPE.EQ.5) THEN
            NDEGEN=NDEGEN+1
            IF(NDEGEN.EQ.2) IZ=IZ+4
            IF(NDEGEN.EQ.2) NDEGEN=0
         END IF
         IF(ITYPE.EQ.6) IZ=IZ+6
         IF(ITYPE.EQ.7) IZ=IZ+7
         IF(ITYPE.LE.0  .OR.  ITYPE.GE.8) CALL ABRT
  490 CONTINUE
C
      IF(MASWRK) THEN
         WRITE(IW,9040)
         WRITE(IW,9050) (I,HESS(I,I),I=1,NZVAR)
      END IF
C
C        IF THE HESSIAN WAS GENERATED IN A REDUNDANT INTERNAL
C        COORDINATE SET, TRANSFORM IT TO THE NONREDUNDANT SET,
C        BY WAY OF CARTESIAN SPACE.
C        THIS WILL RESULT IN A NON-DIAGONAL INITIAL HESSIAN.
C
      IF(SYM) THEN
         IF(MASWRK) WRITE(IW,9060)
         CALL TFHB(HESS,HESS,NZVAR,3*NAT,LDHESS,LDHESS,41)
         CALL TFHF(HESS,HESS,NVAR ,3*NAT,LDHESS,LDHESS,50)
      END IF
C
      IF(NFRG.GT.0) THEN
         HESSII = 0.1D+00
         MINF=NVAR+1
         MAXF=NVAR+6*NFRG
         DO 520 I=MINF,MAXF
            DO 510 J=MINF,I
               HESS(I,J) = ZERO
               HESS(J,I) = ZERO
  510       CONTINUE
            HESS(I,I) = HESSII
  520    CONTINUE
         IF(MASWRK) WRITE(IW,9020) HESSII
      END IF
C
C        NOTE THAT THE HESSIAN MUST BE RESHAPED,
C        SO THAT IT CAN BE -DAWRIT-TEN CORRECTLY.
C
      NDIM = NVAR+6*NFRG
      CALL SQZMAT(HESS,NDIM,NDIM,LDHESS)
C
      RETURN
C
 9010 FORMAT(1X,'CARTESIAN COORDINATE OPTIMIZATION USING BADGER''S',
     *          ' RULE FORCE CONSTANT GUESS')
 9020 FORMAT(1X,'DIAGONAL GUESS HESSIAN FOR FRAGMENTS=',F8.4)
 9021 FORMAT(1X,'DIAGONAL GUESS HESSIAN FOR FRAGMENTS(TRANS)=',F8.4)
 9022 FORMAT(1X,'DIAGONAL GUESS HESSIAN FOR FRAGMENTS(ROT)  =',F8.4)
 9040 FORMAT(1X,'DIAGONAL GUESS HESSIAN IN INTERNAL COORDS IS')
 9050 FORMAT(5(1X,I5,1X,F7.4))
 9060 FORMAT(1X,'TRANSFORMING HESSIAN TO SYMMETRY COORDINATES')
      END
C*MODULE STATPT  *DECK HESSET
      SUBROUTINE HESSET(HESS,NCVAL,NCOORD,OUT,GOTEG,PURIFY)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOTEG,GOTEH,PURIFY,GOPARR,MASWRK,DSKWRK
      LOGICAL NUCOPT,CLSTEP,NEOTS,NEOSAV
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXPT=2000, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /FMCOM / XX(1)
      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 /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      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 /NEOJOB/ NEORUN,NELERM
      COMMON /NEOOPT/ NUCOPT,CLSTEP,NEOTS
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      PARAMETER (ZERO=0.0D+00, SMALL=1.0D-02)
C
      DATA GUESS /8HGUESS   /, GUESS1/8HGUESS1  /, GUESS2/8HGUESS2  /,
     *     CARDS /8HREAD    /, CALC  /8HCALC    /, RDAB  /8HRDAB    /,
     *     RDALL /8HRDALL   /
C
C     ----- OBTAIN THE INITIAL HESSIAN MATRIX -----
C     THIS CAN BE GUESSED, READ FROM CARDS, OR COMPUTED.
C     THIS ROUTINE WRITTEN BY MIKE SCHMIDT, MAY 9 1983.
C
      LIZMAT=1
      LZMAT=1
      IF(NVAR.GT.0) LIZMAT=7*NVAR
      IF(NVAR.GT.0) LZMAT=NVAR
      NC1 = NCOORD + 6*NFRG
      NZ1 = NZVAR  + 6*NFRG
      NQ1 = NVAR   + 6*NFRG
C
      IF(NVAR.GT.0) THEN
         LIZMAT = 7*NZVAR
         LZMAT  = NZVAR
         NHESS  = MAX(NZ1,NC1)
         LDHESS = NHESS
      ELSE
         LIZMAT=1
         LZMAT =1
         NHESS =1
         LDHESS = NC1
      END IF
C
      IF (HESS.EQ.RDALL) THEN
         NREAD=0
         KMASS=0
         DO 110 I=1,NFRG
            DO 100 J=1,NMPTS(I)
               IF (ABS(FMASS(J+KMASS)).GT.SMALL) NREAD=NREAD+1
  100       CONTINUE
            KMASS=KMASS+NMPTS(I)
  110    CONTINUE
         NREAD=NREAD*3
      ENDIF
C
      CALL VALFM(LOADFM)
      LFCM  = LOADFM + 1
      LIZM  = LFCM  + NC1*NC1
      IF (HESS.EQ.RDALL) LIZM=LIZM + (NCOORD+NREAD)**2
      LZM   = LIZM  + LIZMAT
      LFCMI = LZM   + LZMAT
      LDIST = LFCMI + NHESS*NHESS
      LAST  = LDIST + NAT*NAT
C
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     ----- OBTAIN HESSIAN, AND MAYBE THE GRADIENT -----
C
      IF(HESS.EQ.GUESS .OR. HESS.EQ.GUESS1 .OR. HESS.EQ.GUESS2) THEN
         E=ZERO
         CALL EGIN(EG,NCOORD,GOTEG,' $GRAD  ')
         GOTEH=.FALSE.
         IF(NVAR.GT.0) THEN
            CALL HESGES(HESS,XX(LFCMI),LDHESS,NFRG,
     *                  XX(LIZM),LIZMAT,XX(LZM),LZMAT,XX(LDIST),NAT)
         ELSE
            CALL HESGES(HESS,XX(LFCM) ,LDHESS,NFRG,
     *                  XX(LIZM),LIZMAT,XX(LZM),LZMAT,XX(LDIST),NAT)
         END IF
      END IF
C
      IF(HESS.EQ.CARDS.OR.HESS.EQ.RDAB.OR.HESS.EQ.RDALL) THEN
         E=ZERO
         CALL EGIN(EG,NCOORD,GOTEG,' $GRAD  ')
         NCP = NC1
         IF (HESS.EQ.RDAB) NCP = NCOORD
         IF (HESS.EQ.RDALL) NCP = NCOORD+NREAD
         CALL FCMIN(XX(LFCM),NCP,GOTEH)
         IF(.NOT.GOTEH) THEN
            IF (MASWRK) WRITE(IW,9010)
            CALL ABRT
         END IF
      END IF
C
      IF(HESS.EQ.CALC) THEN
         IF(NEORUN.EQ.1) THEN
            NEOSAV = NUCOPT
            NUCOPT = .FALSE.
         END IF
         CALL HESSX(.FALSE.,.FALSE.)
         GOTEG=.TRUE.
         GOTEH=.TRUE.
         CALL DAREAD(IDAF,IODA,EG      ,NCOORD ,3,0)
         CALL DAREAD(IDAF,IODA,XX(LFCM),NC1*NC1,4,0)
         IF(NEORUN.EQ.1) NUCOPT = NEOSAV
      END IF
C
C     ----- TRANSFORM INITIAL HESSIAN TO INTERNAL COORDS -----
C
      IF(NVAR.EQ.0) GO TO 700
      IF(HESS.EQ.GUESS.OR.HESS.EQ.GUESS1.OR.HESS.EQ.GUESS2) GO TO 700
C
      IF(PURIFY) THEN
         IF(GOTEG) THEN
            CALL TRANG(EG,NCVAL,NCOORD)
            CALL TRANGB(EG,NCVAL,NCOORD)
         END IF
         CALL PURFCM(XX(LFCM),XX(LFCMI),XX(LIZMAT),NCOORD,NCVAL,NCVAL,
     *               NZMAT,PURIFY,.FALSE.,.FALSE.)
      END IF
      CALL TFHF(XX(LFCM),XX(LFCMI),NVAR,NCOORD,NQ1,NC1,50)
C
C     ----- STORE HESSIAN ON THE DAF -----
C
  700 CONTINUE
      IF(NVAR.GT.0) THEN
         CALL DAWRIT(IDAF,IODA,XX(LFCMI),NQ1*NQ1,43,0)
         IF(OUT) WRITE(IW,9005)
         IF(OUT) CALL PRSQ(XX(LFCMI),NQ1,NQ1,NQ1)
      ELSE
         CALL DAWRIT(IDAF,IODA,XX(LFCM) ,NC1*NC1, 4,0)
         IF(OUT) WRITE(IW,9000)
         IF(OUT) CALL PRSQ(XX(LFCM),NC1,NC1,NC1)
      END IF
      CALL RETFM(NEED)
      RETURN
C
 9000 FORMAT(1X,'INITIAL CARTESIAN HESSIAN MATRIX IS')
 9005 FORMAT(1X,'INITIAL INTERNAL HESSIAN MATRIX IS')
 9010 FORMAT(1X,'***** ERROR, YOU DID NOT SUPPLY A $HESS GROUP.')
      END
C*MODULE STATPT  *DECK NORMAO
      SUBROUTINE NORMAO(MODE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      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),KMIN(MXSH),KMAX(MXSH),NSHELL
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00, TM10=1.0D-10,
     *           PT75=0.75D+00, PT187=1.875D+00, PT6562=6.5625D+00)
C
C     BASIS FUNCTION NORMALIZATION USED IN VIRIAL SCALING.
C        MODE = 1 : UNNORMALIZE BASIS FUNCTIONS
C        MODE = 2 :   NORMALIZE BASIS FUNCTIONS
C
      PI = ACOS(-ONE)
      PI32 = PI*SQRT(PI)
C
      DO 900 III=1,NSHELL
      K1 = KSTART(III)
      K2 = K1 + KNG(III) - 1
C
      DO 720 IG = K1,K2
         EE = EX(IG)+EX(IG)
         FACS = PI32/(EE*SQRT(EE))
         FACP = HALF*FACS/EE
         FACD = PT75*FACS/(EE*EE)
         FACF = PT187*FACS/(EE**3)
         FACG = PT6562*FACS/(EE**4)
         IF (MODE.EQ.1) THEN
            CS(IG) = CS(IG)*SQRT(FACS)
            CP(IG) = CP(IG)*SQRT(FACP)
            CD(IG) = CD(IG)*SQRT(FACD)
            CF(IG) = CF(IG)*SQRT(FACF)
            CG(IG) = CG(IG)*SQRT(FACG)
         END IF
         IF (MODE.EQ.2) THEN
            CS(IG) = CS(IG)/SQRT(FACS)
            CP(IG) = CP(IG)/SQRT(FACP)
            CD(IG) = CD(IG)/SQRT(FACD)
            CF(IG) = CF(IG)/SQRT(FACF)
            CG(IG) = CG(IG)/SQRT(FACG)
         END IF
  720 CONTINUE
      IF(MODE.EQ.1) GO TO 900
C
      FACS = ZERO
      FACP = ZERO
      FACD = ZERO
      FACF = ZERO
      FACG = ZERO
      DO 770 IG = K1,K2
         DO 760 JG = K1,IG
            EE = EX(IG)+EX(JG)
            FAC = EE*SQRT(EE)
            DUMS = CS(IG)*CS(JG)/FAC
            DUMP = HALF*CP(IG)*CP(JG)/(EE*FAC)
            DUMD = PT75*CD(IG)*CD(JG)/(EE*EE*FAC)
            DUMF = PT187*CF(IG)*CF(JG)/(EE**3*FAC)
            DUMG = PT6562*CG(IG)*CG(JG)/(EE**4*FAC)
            IF(IG .NE. JG) THEN
               DUMS = DUMS+DUMS
               DUMP = DUMP+DUMP
               DUMD = DUMD+DUMD
               DUMF = DUMF+DUMF
               DUMG = DUMG+DUMG
            END IF
            FACS = FACS+DUMS
            FACP = FACP+DUMP
            FACD = FACD+DUMD
            FACF = FACF+DUMF
            FACG = FACG+DUMG
  760    CONTINUE
  770 CONTINUE
C
      IF(FACS .LT. TM10) THEN
         FACS=ZERO
      ELSE
         FACS = ONE/SQRT(FACS*PI32)
      END IF
C
      IF(FACP .LT. TM10) THEN
         FACP=ZERO
      ELSE
         FACP = ONE/SQRT(FACP*PI32)
      END IF
C
      IF(FACD .LT. TM10) THEN
         FACD=ZERO
      ELSE
         FACD = ONE/SQRT(FACD*PI32)
      END IF
C
      IF(FACF .LT. TM10) THEN
         FACF=ZERO
      ELSE
         FACF = ONE/SQRT(FACF*PI32)
      END IF
C
      IF(FACG .LT. TM10) THEN
         FACG=ZERO
      ELSE
         FACG = ONE/SQRT(FACG*PI32)
      END IF
C
      DO 790 IG = K1,K2
         CS(IG) = CS(IG) * FACS
         CP(IG) = CP(IG) * FACP
         CD(IG) = CD(IG) * FACD
         CF(IG) = CF(IG) * FACF
         CG(IG) = CG(IG) * FACG
  790 CONTINUE
  900 CONTINUE
      RETURN
      END
C*MODULE STATPT  *DECK PRMOV
      SUBROUTINE PRMOV(LU,IMODE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      CHARACTER*4 ATMLAB(106)
C
      PARAMETER (MXATM=2000, MXAO=8192, MXPT=2000, MXFRG=1050,
     *           MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      CHARACTER*8 FRGNME
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      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 /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
C
      PARAMETER (TOANGS=0.52917724924D+00)
      PARAMETER (ZERO=0.0D+00)
C
C                           104 TRUE ELEMENTS, AND 2 DUMMIES
C
      DATA ATMLAB/'H   ','HE  ','LI  ','BE  ','B   ','C   ',
     *            'N   ','O   ','F   ','NE  ','NA  ','MG  ',
     *            'AL  ','SI  ','P   ','S   ','CL  ','AR  ',
     *            'K   ','CA  ','SC  ','TI  ','V   ','CR  ',
     *            'MN  ','FE  ','CO  ','NI  ','CU  ','ZN  ',
     *            'GA  ','GE  ','AS  ','SE  ','BR  ','KR  ',
     *            'RB  ','SR  ','Y   ','ZR  ','NB  ','MO  ',
     *            'TC  ','RU  ','RH  ','PD  ','AG  ','CD  ',
     *            'IN  ','SN  ','SB  ','TE  ','I   ','XE  ',
     *            'CS  ','BA  ','LA  ','CE  ','PR  ','ND  ',
     *            'PM  ','SM  ','EU  ','GD  ','TB  ','DY  ',
     *            'HO  ','ER  ','TM  ','YB  ','LU  ','HF  ',
     *            'TA  ','W   ','RE  ','OS  ','IR  ','PT  ',
     *            'AU  ','HG  ','TL  ','PB  ','BI  ','PO  ',
     *            'AT  ','RN  ','FR  ','RA  ','AC  ','TH  ',
     *            'PA  ','U   ','NP  ','PU  ','AM  ','CM  ',
     *            'BK  ','CF  ','ES  ','FM  ','MD  ','NO  ',
     *            'LR  ','RF  ','X   ','BQ  '/
C
C     ----- WRITE ATOMIC COORDINATES AND FRAGMENT COORDINATES (IF USING
C            FRAGMENTS) TO UNIT LU (NORMALLY USE 4,.IRC FILE)
C     IF ABS(IMODE).EQ.1, ALL ATOMS
C     IF ABS(IMODE).EQ.2 (NOT AVAILABLE), ONLY THE SYMMETRY UNIQUE ATOMS
C     PRINT IN BOHR IF IMODE IS NEGATIVE, ANGSTROMS OTHERWISE.
C
      MODE = IABS(IMODE)
      IF(MODE.EQ.0) RETURN
C
      IF(IMODE.GT.0) THEN
         UNIT = TOANGS
      ELSE
         UNIT = 1.0D+00
      END IF
C
      NFRN=0
      IF(NFRG.GT.0) THEN
         KMASS=0
         DO 303 IFRG=1,NFRG
            DO 302 III=1,NMPTS(IFRG)
               IF(FMASS(III+KMASS).GT.ZERO) NFRN=NFRN+1
  302       CONTINUE
            KMASS=KMASS+NMPTS(IFRG)
  303    CONTINUE
      END IF
C
      NNTOT=NAT+NFRN
      IF(MASWRK) WRITE(LU,9029) NNTOT
      DO 310 IAT=1,NAT
         X = UNIT * C(1,IAT)
         Y = UNIT * C(2,IAT)
         Z = UNIT * C(3,IAT)
         IF (MASWRK) WRITE(LU,9031) ANAM(IAT),X,Y,Z
  310 CONTINUE
C
      IF(NFRG.GT.0) THEN
         IAT=0
         KMASS=0
         DO 912 IFRG=1,NFRG
            DO 911 III=1,NMPTS(IFRG)
               IAT=IAT+1
               IF(FMASS(III+KMASS).GT.ZERO) THEN
                  X = UNIT * EFC(1,IAT)
                  Y = UNIT * EFC(2,IAT)
                  Z = UNIT * EFC(3,IAT)
                  IZNUC = INT(FGNUC(IAT)+0.001D+00)
                  IF (MASWRK) WRITE(LU,9032) ATMLAB(IZNUC),X,Y,Z
               END IF
  911       CONTINUE
            KMASS=KMASS+NMPTS(IFRG)
  912    CONTINUE
      END IF
      RETURN
C
 9029 FORMAT(I3)
 9031 FORMAT(1X,A8,7X,3F15.10)
 9032 FORMAT(1X,A4,7X,3F15.10)
      END
C*MODULE STATPT  *DECK SCHNR
      SUBROUTINE SCHNR(XQUAD,NCVAL,FC,A,VEC,SCR,EIGEN,XXX,IA,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXATM=2000)
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00)
      PARAMETER (PT02=0.02D+00, R24=24.0D+00)
C
      DIMENSION VEC(NCVAL,NCVAL),A(NCVAL,NCVAL),FC(1),
     *          SCR(NCVAL,8),EIGEN(NCVAL),IA(NCVAL),XXX(NCVAL)
      DIMENSION XQUAD(*)
C
      COMMON /FROZNC/ IFREEZ(3*MXATM),NFRZ
      COMMON /FUNCT / ENERGY,F(3*MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
C     ----- THE CURRENT SECOND DERIVATIVE MATRIX AND GRADIENT ARE
C           USED TO COMPUTE THE DISPLACEMNT FROM THE CURRENT POINT
C           NEEDED TO FIND THE MINIMUM OF A PURELY QUADRATIC
C           SURFACE.  THIS IS CALL THE QUADRATIC SURFACE AND USES
C           THE NEWTON-RAPHSON FORMULA. -----
C
C     ----- READ IN THE CURRENT FORCE CONSTANT MATRIX, SYMMETRIZE
C           IT, STORE IN SYMMETRIC STORAGE MODE, AND DIAGONALIZE.
C           IF A COORDINATE IS FROZEN, ZERO ITS OFF DIAGONAL
C           HESSIAN ELEMENTS, AND LEVEL SHIFT IT AWAY.
C
      NQ3 = NCVAL*NCVAL
      IF(NZVAR.EQ.0) THEN
         CALL DAREAD(IDAF,IODA,A,NQ3, 4,0)
      ELSE
         CALL DAREAD(IDAF,IODA,A,NQ3,43,0)
         DO 110 I = 1,NFRZ
            IFRZ = IFREEZ(I)
            CALL VCLR (A(   1,IFRZ), 1    , NCVAL)
            CALL VCLR (A(IFRZ,   1), NCVAL, NCVAL)
            A(IFRZ,IFRZ) = R24 + PT02*IFRZ
  110    CONTINUE
      END IF
C
      IJ = 0
      DO 130 I = 1,NCVAL
         DO 120 J = 1,I
            IJ = IJ + 1
            FC(IJ) = (A(I,J) + A(J,I))*HALF
  120    CONTINUE
  130 CONTINUE
C
      IF(OUT) WRITE(IW,9090)
      IF(OUT) CALL PRTRI(FC,NCVAL)
C
      IERR = 0
      CALL GLDIAG(NCVAL,NCVAL,NCVAL,FC,SCR,EIGEN,VEC,IERR,IA)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'GLDIAG FAILURE IN -SCHNR-'
         CALL ABRT
      END IF
C
C     ----- SWITCH THE FIRST VECTOR AND THE IFOLOW ONE -----
C
      IF(NSERCH .GT. 0) GO TO 300
      ETMP = EIGEN(1)
      EIGEN(1) = EIGEN(IFOLOW)
      EIGEN(IFOLOW) = ETMP
      CALL DSWAP(NCVAL,VEC(1,1),1,VEC(1,IFOLOW),1)
C
C        ----- TEST EIGENVALUES OF 2ND DERIVATIVE MATRIX -----
C              ENSURE PROPER NUMBER OF NEGATIVE EIGENVALUES
C               SKIP SIX MODES IF USING CARTESIAN COORDS.
C
  300 CONTINUE
      IF(OUT) WRITE (IW,9048)
      IF(OUT) CALL PREV(VEC,EIGEN,NCVAL,NCVAL,NCVAL)
      DO 380 I = 1,NCVAL
         IF(NZMAT.EQ.0  .AND.  (I.GT.NNEG)  .AND.
     *      (I.LE.NNEG+6)) GO TO 380
         RX = EIGEN(I)
         IF(ABS(RX) .LT. EIGMIN) EIGEN(I) = SIGN(EIGMIN,RX)
         IF(ABS(RX) .GT. EIGMAX) EIGEN(I) = SIGN(EIGMAX,RX)
         IF((I.LE.NNEG).AND.(EIGEN(I).GT.ZERO))
     *           EIGEN(I) = -EIGEN(I)
         IF((I.GT.NNEG).AND.(EIGEN(I).LT.ZERO))
     *           EIGEN(I) = -EIGEN(I)
         IF(EIGEN(I) .EQ. RX) GO TO 380
            IF (MASWRK) WRITE (IW,9068) I,RX,EIGEN(I)
  380 CONTINUE
      IF(NNEG.EQ.0) GO TO 395
         IF (MASWRK) THEN
         DO 390 I=1,NNEG
            WRITE (IW,9028) EIGEN(I),(J,VEC(J,I),J = 1,NCVAL)
 390     CONTINUE
         END IF
 395  CONTINUE
C
C     ----- RECONSTRUCT FC FROM ITS SPECTRAL DECOMPOSITION,
C           AND FORM ITS INVERSE IN VEC -----
C
      DO 480 I = 1,NCVAL
         DO 440 J = I,NCVAL
            RX = ZERO
            DDX = ZERO
            DO 420 K = 1,NCVAL
               RX  = RX  + VEC(I,K) * VEC(J,K) / EIGEN(K)
               DDX = DDX + VEC(I,K) * VEC(J,K) * EIGEN(K)
  420       CONTINUE
            A(I,J) = DDX
            A(J,I) = DDX
            XXX(J) = RX
  440    CONTINUE
         DO 460 J = 1,NCVAL
            IF(J .LT. I) VEC(I,J) = VEC(J,I)
            IF(J .GE. I) VEC(I,J) = XXX(J)
  460    CONTINUE
  480 CONTINUE
C
C     ----- SAVE FC -----
C
      IF(NZVAR.EQ.0) THEN
         CALL DAWRIT(IDAF,IODA,A,NQ3, 4,0)
      ELSE
         CALL DAWRIT(IDAF,IODA,A,NQ3,43,0)
      END IF
C
C     ----- CALCULATE DISPLACEMENTS -----
C
      IF(OUT) WRITE(IW,9070)
      IF(OUT) CALL PRSQ(VEC,NCVAL,NCVAL,NCVAL)
      IF(OUT) WRITE(IW,9080) (F(I),I=1,NCVAL)
      DXRMS = ZERO
      DXMAX = ZERO
      DO 520 I = 1,NCVAL
         DX = ZERO
         DO 500 J = 1,NCVAL
            DX = DX+VEC(J,I)*F(J)
  500    CONTINUE
         XQUAD(I) = DX
         DXRMS = DXRMS+DX*DX
         IF(ABS(DX) .GT. DXMAX) DXMAX = ABS(DX)
  520 CONTINUE
      DXRMS = SQRT(DXRMS/NCVAL)
      IF(OUT) WRITE(IW,9080) (XQUAD(I),I=1,NCVAL)
      RETURN
C
 9028 FORMAT(10X,'THE IMAGINARY MODE HAS EIGENVALUE',F11.5,
     *           ' AND COMPONENTS',15(/12X,10(I3,F7.3)))
 9048 FORMAT(/10X,39HFORCE CONSTANT EIGENVALUES AND VECTORS ,/)
 9068 FORMAT(10X,'EIGENVALUE',I3,'=',F11.5,' IS OUT OF BOUNDS.',
     *           ' RESET TO',F11.5)
 9070 FORMAT(1X,'IN SCHNR,  FC**-1/ F/ XQUAD ARE')
 9080 FORMAT(1X,10F12.7)
 9090 FORMAT(1X,'IN SCHNR, FC=')
      END
C*MODULE STATPT  *DECK SCHNRM
      SUBROUTINE SCHNRM(XQUAD,NCVAL,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      DIMENSION XQUAD(*)
C
      COMMON /FMCOM / XX(1)
C
C     ----- GROW MEMORY FOR SCHNR -----
C       -FC-      AT I10
C       -A-       AT I15
C       -VEC-     AT I20
C       -SCR-     AT I30
C       -EIGEN-   AT I40
C       -XXX-     AT I50
C       -IA-      AT I60
C
      L3 = NCVAL*NCVAL
      LOADFM = 0
      CALL VALFM(LOADFM)
      I10 = 1 + LOADFM
      I15 = I10 + (L3+NCVAL)/2
      I20 = I15 + L3
      I30 = I20 + L3
      I40 = I30 + 8*NCVAL
      I50 = I40 + NCVAL
      I60 = I50 + NCVAL
      I70 = I60 + NCVAL
      LAST = I70
      NEED = LAST - I10
      CALL GETFM(NEED)
      CALL SCHNR(XQUAD,NCVAL,XX(I10),XX(I15),XX(I20),
     *            XX(I30),XX(I40),XX(I50),XX(I60),OUT)
C
C     ----- RETURN FAST MEMORY -----
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK SCHSAM
      SUBROUTINE SCHSAM(NCVAL,NPMX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      COMMON /FMCOM / XX(1)
C
C     ----- GROW MEMORY FAST -----
C
      LOADFM = 0
      CALL VALFM(LOADFM)
      I10 = 1 + LOADFM
      I20 = I10 + NCVAL*NPMX
      I30 = I20 + NCVAL*NPMX
      I40 = I30 + NCVAL
      LAST = I40
      LENGTH = LAST - I10
      NEED = LENGTH
      CALL GETFM(NEED)
      CALL SCHSAV(NCVAL,NPMX,XX(I10),XX(I20),XX(I30))
C
C     ----- RETURN FAST MEMORY -----
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK SCHSAV
      SUBROUTINE SCHSAV(NCVAL,NPMX,FF,FX,XI)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR
C
      DIMENSION ESAVE(20)
      DIMENSION FF(NCVAL,NPMX),FX(NCVAL,NPMX),XI(NCVAL)
C
      PARAMETER (MXATM=2000)
C
      COMMON /FUNCT / ENERGY,F(3*MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
C
      EQUIVALENCE (ES,ESAVE(1))
C
C     ----- PUSH THE CURRENT VALUES OF THE FUNCTION, GRADIENT,
C           AND POSITION VECTOR ONTO THE APPROPRIATE STACKS -----
C
C     ----- PUSH FORMER VALUES UP THE STACKS -----
C
      NN = NCVAL * NPMX
      NP = NP+1
      IF(NP .LT. 2) GO TO 120
      CALL DAREAD(IDAF,IODA,FX,NN,98,0)
      CALL DAREAD(IDAF,IODA,FF,NN,99,0)
      DO 100 IIP = 2,NP
         IPP = NP+1-IIP
         II = IPP+1
         ESAVE(II) = ESAVE(IPP)
         IC(II) = IC(IPP)
         CALL DCOPY(NCVAL,FF(1,IPP),1,FF(1,II),1)
         CALL DCOPY(NCVAL,FX(1,IPP),1,FX(1,II),1)
  100 CONTINUE
C
C     ----- STORE CURRENT VALUES -----
C
  120 CONTINUE
      IF(NZMAT.GT.0) CALL DAREAD(IDAF,IODA,XI,NCVAL,39,0)
      ESAVE(1) = ENERGY
      IC(1) = NSERCH
      DO 140 I = 1,NCVAL
         IF(NZMAT.GT.0) FX(I,1) = XI(I)
         IF(NZMAT.EQ.0) FX(I,1)=X(I)
         FF(I,1) = F(I)
  140 CONTINUE
      IF(NP .GT. NPMAX) NP = NPMAX
C
C     ----- SAVE FF AND FX -----
C
      CALL DAWRIT(IDAF,IODA,FX,NN,98,0)
      CALL DAWRIT(IDAF,IODA,FF,NN,99,0)
C
C     ----- SAVE /OPTGRD/ IN DAF -----
C
      LENOPR = 3*MXATM + 34
      LENOPI = (31-1)/NWDVAR+1
      CALL DAWRIT(IDAF,IODA,X ,LENOPR,37,0)
      CALL DAWRIT(IDAF,IODA,IC,LENOPI,38,1)
      RETURN
      END
C*MODULE STATPT  *DECK SCHUPD
      SUBROUTINE SCHUPD(NCVAL,NCOORD,NPMX,FC,FCCART,A,FX,FF,FCOLD,FCNEW,
     *                  ISS,XI,NPUN,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOPARR,MASWRK,DSKWRK
C
      PARAMETER (ZERO=0.0D+00)
C
      DIMENSION A(NCVAL,NPMX),FC(1),FX(NCVAL,NPMX),
     *          FF(NCVAL,NPMX),FCNEW(NCVAL),FCOLD(NCVAL),
     *          FCCART(NCOORD,NCOORD),ISS(NPMX),XI(NCVAL)
      DIMENSION ESAVE(20)
C
      PARAMETER (MXATM=2000)
C
      COMMON /FUNCT / ENERGY,F(3*MXATM)
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
C
      EQUIVALENCE (ES,ESAVE(1))
C
C      ----- UPDATE THE SECOND DERIVATIVE MATRIX USING VALUES OF
C            THE FIRST DERIVATIVE COMPUTED HERE AND THERE ON THE
C            SURFACE -----
C
C         F    = CURRENT FORCES ( -DE/DX )
C         XI   = CURRENT COORDINATES
C         FX   = FORMER COORDINATES
C         FF   = FORMER FORCES
C         FC   = CURRENT FORCE CONSTANTS (TO BE UPDATED)
C
      L1 = NCVAL
      L3 = L1*L1
      NN = NCVAL * NPMX
C
C     ----- SCHMIDT ORTHOGONALIZE THE VECTORS FROM THE CURRENT
C           POINT TO ALL FORMER GEOMETRIES -----
C
      IF(NZMAT.GT.0) CALL DAREAD(IDAF,IODA,XI,NCVAL,39,0)
      IF(NZMAT.GT.0) GO TO 103
         DO 102 I=1,NCVAL
            XI(I) = X(I)
  102    CONTINUE
  103 CONTINUE
      CALL DAREAD(IDAF,IODA,FX,NN,98,0)
      DO 110 J = 1,NP
         DO 105 I = 1,NCVAL
            A(I,J) = (FX(I,J)-XI(I))
  105    CONTINUE
  110 CONTINUE
      CALL SCHVEC(A,ISS,NCVAL,NPMX)
C
C     ----- READ IN FC AND FF MATRICES -----
C
      IF(NZVAR.EQ.0) THEN
         CALL DAREAD(IDAF,IODA,FC,L3, 4,0)
      ELSE
         CALL DAREAD(IDAF,IODA,FC,L3,43,0)
      END IF
      CALL DAREAD(IDAF,IODA,FF,NN,99,0)
      IF(OUT) WRITE(IW,9020)
      IF(OUT) CALL PRSQ(FC,NCVAL,NCVAL,NCVAL)
      IF(OUT) CALL PRSQ(FF,NP,NCVAL,NCVAL)
C
C     ------ UPDATE THE HESSSIAN -----
C
      DO 200 IAA = 1,NP
      II = ISS(IAA)
      IJ = 0
      DX = ZERO
      RX = ZERO
      DO 130 I = 1,NCVAL
         DDX = (FX(I,II)-XI(I))
         DX = DX+DDX*DDX
         RX = RX+DDX*A(I,IAA)
         FCOLD(I) = ZERO
         FCNEW(I) = F(I)-FF(I,II)
         DO 120 J = 1,NCVAL
            IJ = IJ+1
            FCOLD(I) =  FCOLD(I) + FC(IJ) * (FX(J,II)-XI(J))
  120    CONTINUE
  130 CONTINUE
      DX = SQRT(DX)
      DO 180 IBB = IAA,NP
         DELTAK = ZERO
         DO 140 I = 1,NCVAL
            DELTAK = DELTAK + A(I,IBB) * (FCNEW(I)-FCOLD(I))
  140    CONTINUE
         DELTAK = DELTAK/RX
C
C        ----- TEST NUMERICAL ACCURACY AND
C              ADD CORRECTIONS TO THE 2ND DERIVATIVE MATRIX -----
C
         ERROR = GRDERR*DX/RX
         IF(ABS(DELTAK) .LT. ERROR) GO TO 180
         IJ = 0
         DO 170 I = 1,NCVAL
            DO 160 J = 1,NCVAL
               IJ = IJ+1
               FC(IJ) = FC(IJ) + A(I,IAA) * DELTAK * A(J,IBB)
               IF(IAA .NE. IBB) FC(IJ) =
     *                  FC(IJ) + A(I,IBB) * DELTAK * A(J,IAA)
  160       CONTINUE
  170    CONTINUE
  180 CONTINUE
  200 CONTINUE
C
C     ----- SAVE UPDATED FORCE CONSTANT MATRIX -----
C     (TRANSFORM FC TO CARTESIAN SPACE BEFORE PUNCHING)
C
      IF(NZVAR.EQ.0) THEN
         CALL DAWRIT(IDAF,IODA,FC,L3, 4,0)
         IF(NPUN.EQ.1  .OR.  NPUN.EQ.3) THEN
            IF(MASWRK) WRITE(IP,*) 'THE APPROXIMATE HESSIAN IS'
            CALL FCMPUN(FC,NCOORD)
         END IF
      ELSE
         CALL DAWRIT(IDAF,IODA,FC,L3,43,0)
         IF(NPUN.EQ.1  .OR.  NPUN.EQ.3) THEN
            CALL TFHB(FC,FCCART,NCVAL,NCOORD,NCVAL,NCOORD,49)
            IF(MASWRK) WRITE(IP,*) 'THE APPROXIMATE HESSIAN IS'
            CALL FCMPUN(FCCART,NCOORD)
         END IF
      END IF
      IF(OUT) WRITE (IW,9030)
      IF(OUT) CALL PRSQ(FC,NCVAL,NCVAL,NCVAL)
C
C        ----- DISCARD UNSUITABLE POINTS -----
C
      DO 260 II = 1,NP
         IPP = ISS(II)
         IC(II) = IC(IPP)
         ESAVE(II) = ESAVE(IPP)
         CALL DCOPY(NCVAL,FX(1,IPP),1,FX(1,II),1)
         CALL DCOPY(NCVAL,FF(1,IPP),1,FF(1,II),1)
  260 CONTINUE
      DO 280 I=1,NP
         ISS(I)=IC(NP-I+1)
  280 CONTINUE
      MAX = NP+1
      ISS(MAX) = NSERCH
      IF (MASWRK) WRITE(IW,9028) (ISS(I),I=1,MAX)
C
C     ----- SAVE GOOD POINTS, WITH THEIR FORCES -----
C
      CALL DAWRIT(IDAF,IODA,FX,NN,98,0)
      CALL DAWRIT(IDAF,IODA,FF,NN,99,0)
      RETURN
C
 9020 FORMAT(1X,'IN SCHUPD, FC AND FF ARE')
 9030 FORMAT(1H0,'IN SCHUPD, THE UPDATED FC=')
 9028 FORMAT(10X,'FORCE CONSTANT MATRIX UPDATED USING',
     *       ' INFORMATION FROM POINTS',(/10X,20I4))
      END
C*MODULE STATPT  *DECK SCHUPM
      SUBROUTINE SCHUPM(NCVAL,NPMX,NPUN,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      PARAMETER (MXATM=2000)
C
      COMMON /FMCOM / XX(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
C     ----- ALLOCATE MEMORY -----
C
C          -FC-      AT I10
C          -FCCART-  AT I20
C          -A-       AT I30
C          -FX-      AT I40
C          -FF-      AT I50
C          -FCOLD-   AT I60
C          -FCNEW-   AT I70
C          -ISS-     AT I80
C          -XI-      AT I90
C
      L1 = NCVAL
      L3 = L1*L1
      NN = L1 * NPMX
      NCOORD = 3*NAT
      LOADFM = 0
      CALL VALFM(LOADFM)
      I10 = 1 + LOADFM
      I20 = I10 + L3
      I30 = I20 + NCOORD*NCOORD
      I40 = I30 + NN
      I50 = I40 + NN
      I60 = I50 + NN
      I70 = I60 + L1
      I80 = I70 + L1
      I90 = I80 + NPMX
      I100= I90 + L1
      LAST = I100
      LENGTH = LAST - I10
      NEED = LENGTH
      CALL GETFM(NEED)
      CALL SCHUPD(NCVAL,NCOORD,NPMX,XX(I10),XX(I20),XX(I30),XX(I40),
     *            XX(I50),XX(I60),XX(I70),XX(I80),XX(I90),NPUN,OUT)
C
C     ----- RETURN FAST MEMORY -----
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE STATPT  *DECK SCHVEC
      SUBROUTINE SCHVEC(A,ISS,NCVAL,NPMX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      DIMENSION A(NCVAL,NPMX)
      DIMENSION ISS(NPMX)
C
      PARAMETER (MXATM=2000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ONE=1.0D+00)
C
C     ----- FORM AN ORTHONORMAL SET OF BASIS VECTORS FROM A
C           SET OF GIVEN VECTORS BY SCHMIDT ORTHOGONALIZATION
C           VECTORS SHORTER THAN RMIN, OR LONGER THAN RMAX, OR
C           CONTRIBUTING LESS THAN RLIM TO A NEW BASIS VECTOR
C           ARE DISCARDED -----
C
      I = 1
      II = 0
  100 CONTINUE
         II = II+1
         ISS(I) = II
         RR = DDOT(NCVAL,A(1,I),1,A(1,I),1)
         RMS = SQRT(RR/NCVAL)
         RR = SQRT(RR)
         IF((NP .GT. 1) .AND. (RMS .LT. RMIN)) GO TO 300
         IF((I .GT. 1) .AND. (RMS .GT. RMAX)) GO TO 320
         CALL DSCAL(NCVAL,ONE/RR,A(1,I),1)
         RR = ONE
         I1 = I-1
         IF(I1 .LT. 1) GO TO 260
         DO 200 K = 1,I1
            R = -DDOT(NCVAL,A(1,I),1,A(1,K),1)
            CALL DAXPY(NCVAL,R,A(1,K),1,A(1,I),1)
  200    CONTINUE
         RR = SQRT( DDOT(NCVAL,A(1,I),1,A(1,I),1))
         IF(RR .LT. RLIM) GO TO 340
         CALL DSCAL(NCVAL,ONE/RR,A(1,I),1)
  260    CONTINUE
         IF(I .GE. NP) RETURN
         I = I+1
      GO TO 100
C
C     ----- DISCARD ANY PREVIOUS POINTS THAT ARE UNSUITABLE -----
C
  300 CONTINUE
      IPT = IC(ISS(I))
      IF (MASWRK) WRITE(IW,9200) IPT,RMS,RMIN
      GO TO 500
C
  320 CONTINUE
      IPT = IC(ISS(I))
      IF (MASWRK) WRITE(IW,9210) IPT,RMS,RMAX
      GO TO 500
C
  340 CONTINUE
      IPT = IC(ISS(I))
      IF (MASWRK) WRITE(IW,9220) IPT,RR,RLIM
C
  500 CONTINUE
      NP = NP-1
      IF(I .GT. NP) RETURN
      CALL DCOPY(NCVAL*(NP-I+1),A(1,I+1),1,A(1,I),1)
      GO TO 100
C
 9200 FORMAT(10X,'DISCARDING POINT',I3,', TOO CLOSE TO CURRENT',
     *           ' POINT (RMS=',1PE9.2,' .LT. RMIN=',1PE9.2,')')
 9210 FORMAT(10X,'DISCARDING POINT',I3,', TOO FAR FROM CURRENT',
     *           ' POINT (RMS=',1PE9.2,' .GT. RMAX=',1PE9.2,')')
 9220 FORMAT(10X,'DISCARDING POINT',I3,', CANNOT FIND LINEARLY',
     *           ' INDEPENDENT VECTOR (RR=',1PE9.2,
     *           ' .LT. RLIM=',1PE9.2,')')
      END
C*MODULE STATPT  *DECK SIGEND
      SUBROUTINE SIGEND(CVGED,NSERCH,NCVAL,NCOORD,NPRT,NPUN)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION METHOD
C
      CHARACTER*4 PRPTYP
C
      LOGICAL LINEAR,CVGED,GOPARR,MASWRK,DSKWRK,SVDSKW,DIRTRF,
     *        VTSCAL,TMPVIR,VIROK,LVCLN,FOCAS,SOSCF,DROPC,
     *        CANONC,FCORE,FORS,NOCI,EKT,LINSER,MMONLY,QMMM
C
      CHARACTER*8 GWRD,EWRD
C
      DIMENSION TIMSTR(3)
C
      PARAMETER (MXATM=2000, MXRT=100, MXSH=5000, MXAO=8192,
     *           MXFRG=1050, MXNORO=250,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,SDET,SZDET,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACTDT,NORBDT,
     *                NADET,NBDET,KDET,KSTDET,IROOT,IPURES,MAXW1,NITDET,
     *                MAXP,NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /ENRGYS/ ENUCR,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 /FMCOM / X(1)
      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 /GVBWFN/ CICOEF(2,12),F(25),ALPHA(325),BETA(325),NO(10),
     *                NCO,NSETO,NOPEN,NPAIR,NORBG,NCONF(MXAO),NHAM
      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 /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,
     *                NORBMC,NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /OPTGRD/ RDMY(3*MXATM+34),IDMY(31)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      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 /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 /XYZPRP/ DUM(3),DIP(3),DUMM(32)
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
C
      PARAMETER (ZERO=0.0D+00, TOL=5.0D-02)
C
      DATA UHF,GVB,RMC/8HUHF     ,8HGVB     ,8HMCSCF   /
      DATA VECWRD,ENDWRD/8H $VEC   ,8H $END   /
      DATA ALDET,GUGA,GENCI,ORMAS,CIS
     *      /8HALDET   ,8HGUGA    ,8HGENCI   ,8HORMAS   ,8HCIS     /
      DATA RNONE/8HNONE    /
C
C     ----- OUTPUT FINAL RESULTS OF STATIONARY POINT SEARCH -----
C
      NC1=NCOORD+6*NFRG
      TMPVIR = VTSCAL
      VTSCAL = .FALSE.
      NSTATE = INT(STATN)
      L0 = NQMT
      L1 = NUM
      L3 = L1*L1
      NQ3 = NC1*NC1
      IF (SCFTYP.EQ.RMC) THEN
         IF(CISTEP.EQ.ALDET   .OR.  CISTEP.EQ.GENCI
     *          .OR.CISTEP.EQ.ORMAS) THEN
            NORB   = L0
            NCORBS = NCORSV
            NVAL   = NACTDT
            NORBS  = NCORBS+NVAL
            NVIRT  = NORB-NORBS
         END IF
         IF(CISTEP.EQ.GUGA) THEN
            SVDSKW = DSKWRK
            DSKWRK = .TRUE.
            CALL SEQREW(NFT11)
            CALL RDDRT(NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,NREFS,
     *                 IEXCT,NFOCI,INTACT,NCORBS)
            DSKWRK = SVDSKW
            IF (DROPC) NORBS = NORBS + NCORBS
            NORB = L0
            NVAL = NORBS - NCORBS
            NVIRT= NORB - NORBS
         END IF
      ELSE
         NWKS=0
         NROWS=0
         NORBS=0
         NORBMX=0
         NORB = 0
         NVAL = 0
         NVIRT= 0
      END IF
C
      CALL VALFM(LOADFM)
      LVEC  = LOADFM + 1
      LEIG  = LVEC   + L3
      LHESS = LEIG   + L1
      LHINT = LHESS  + NQ3
      LSYMB = LHINT  + NCVAL*NCVAL
      LAST  = LSYMB  + L1
      NEED  = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     ----- PRINT/PUNCH COORDINATES OF (UN)CONVERGED GEOMETRY -----
C
      IF (MASWRK) THEN
         IF (QMMM.AND.(ICOORD.EQ.-1)) WRITE(IW,9010) (TITLE(I),I=1,10)
         IF(.NOT.CVGED .AND. NPRTGO.NE.2) WRITE(IW,9020)
         IF (NPRT.NE.-2) THEN
            IF(     CVGED) WRITE(IP,8040) SCFTYP
            IF(.NOT.CVGED) WRITE(IP,8050) SCFTYP
         END IF
      END IF
      IF(NPRTGO.GT.-1) THEN
         IF(NT.GT.1) CALL PRATM(IW,2)
         CALL PRATM(IW,1)
         CALL PRATM(IP,2)
         IF (QMMM.AND.MASWRK) CALL PRTXYZ(IP)
      END IF
C  ---- LVS: PRINT OUT FOR GAURAV
C  ---- THIS PRINTS CENTERS OF MASS OF THE EFP FRAGMENTS
      IF(NPRT.EQ.-2 .AND. ICOORD .EQ. 4) THEN
         CALL PREFP(IP)
      END IF
      IF(                NZMAT.GT.0) CALL PZANDG(ZERO,0)
      IF(NZMTRD.EQ.1.AND.NZMAT.GT.0) CALL PZANDG(ZERO,2)
      IF(NZMTRD.EQ.1.AND.NZMAT.EQ.0) THEN
         NZVAR = NZVAR2
         NZMAT = NZMAT2
         NVAR = NVAR2
         CALL PZANDG(ZERO,2)
         NZVAR = 0
         NZMAT = 0
         NVAR = 0
      END IF
C
      IF(NPRT .GE. -2 .AND. ICOORD .NE. 4 .AND. NPRTGO.NE.2) CALL INTR
C
C     ----- PRINT ENERGY INFORMATION -----
C
      IF (ICOORD .NE. 4) THEN
         CALL DAREAD(IDAF,IODA,ENUCR,MXRT+15,2,0)
         IF(.NOT.CVGED) THEN
            ENUCR = ENUC(NAT,ZAN,C)
            EELCT = ZERO
            ETOT = ZERO
         END IF
         IF (MASWRK .AND. NPRTGO.NE.2) THEN
            WRITE(IW,9050) ENUCR,EELCT,ETOT
            IF(SCFTYP.EQ.UHF) WRITE(IW,9060) SZ,SZZ
         END IF
      ELSE
         IF(MASWRK) WRITE(IW,9055) E
      END IF
C
C     ----- SAVE /OPTGRD/ TO THE DAF -----
C
      LENOPR = 3*MXATM + 34
      LENOPI = (31-1)/NWDVAR+1
      CALL DAWRIT(IDAF,IODA,RDMY,LENOPR,37,0)
      CALL DAWRIT(IDAF,IODA,IDMY,LENOPI,38,1)
C
C     ----- PRINT MORE INFO FOR AN MCSCF CALCULATION -----
C
      IF (SCFTYP.EQ.RMC) THEN
C
C     ----- GENERATE MCSCF CANONICAL ORBITALS -----
C          ----- PRINT MCSCF NO-S AND MO-S -----
C
         SVDSKW = DSKWRK
         DSKWRK = .TRUE.
                        NPUNMC=2
         IF(NPUN.LE.-1) NPUNMC=1
         IF(NPUN.LE.-2) NPUNMC=0
         CALL CANMCV(0,.TRUE.,NPUNMC,NORB,NCORBS,NVAL,NVIRT,NORBS)
         DSKWRK = SVDSKW
C
C     ----- GET THE CI VECTOR AND PRINT DOMINANT CSF'S -----
C
         IF(CISTEP.EQ.ALDET) CALL DETPRT(IW,NFT12,MASWRK)
         IF(CISTEP.EQ.GENCI) CALL GCIPRT(IW,NFT12,MASWRK)
C
         IF(CISTEP.EQ.GUGA) THEN
            CALL VALFM(LOADFM)
            LNORB  = LOADFM + 1
            LNOCC  = LNORB  + L3
            LCVEC  = LNOCC  + NORBS
            LEVEC  = LCVEC  + NWKS
            LLEVIR = LEVEC  + NSTATE*NWKS
            LICASE = LLEVIR + NORBMX + 1
            LIECON = LICASE + NORBMX
            LIARC  = LIECON + NORBMX
            LAST   = LIARC  + 4*NROWS
            NEED2  = LAST - LOADFM - 1
            CALL GETFM(NEED2)
C
            SVDSKW = DSKWRK
            DSKWRK = .TRUE.
            CALL SEQREW(NFT12)
            READ(NFT12) NSTATE,NWKS
C
            I0=0
            DO 250 I=1,NSTATE
               CALL SQREAD(NFT12,X(LEVEC+I0),NWKS)
               I0 = I0 + NWKS
  250       CONTINUE
            CALL SEQREW(NFT12)
            DSKWRK = SVDSKW
C
            PRTTOL = ZERO
            IF(NWKS.GT.20) PRTTOL = TOL
            CALL PRCIVC(NFT11,NSTATE,NWKS,ESTATE,X(LEVEC),PRTTOL,
     *                  X(LLEVIR),X(LICASE),X(LIECON),X(LIARC),
     *                  NORBMX,4*NROWS,NROWS)
            CALL RETFM(NEED2)
         END IF
      END IF
C
C     ----- PRINT/PUNCH FINAL ORBITALS -----
C
      IF(ICOORD.EQ.4 .OR. NFG.NE.0) GO TO 160
      IF(NSERCH.EQ.0 .AND. NEORUN.EQ.0) THEN
         IF(MASWRK) WRITE(IW,9130)
         GO TO 160
      END IF
      IF(.NOT.DIRTRF  .AND.  SCFTYP.EQ.RMC) GO TO 150
C
      IF(MASWRK  .AND.  NPRT.GE.0 .AND. NPRTGO.NE.2) THEN
         WRITE(IW,9070)
         IF(SCFTYP.EQ.UHF) WRITE(IW,9080)
      END IF
C
      CALL TMDATE(TIMSTR)
      IF(MASWRK  .AND.  NPUN.GE.-1) THEN
         WRITE(IP,8010) SCFTYP,TIMSTR
         WRITE(IP,8020) ETOT,ENUCR
         IF(SCFTYP.EQ.GVB) THEN
            DO 110 I=1,NPAIR
               INDEX = 2*I - 1
               GWRD = '        '
               EWRD = '        '
               IF(I.EQ.1)     GWRD=' $SCF   '
               IF(I.EQ.NPAIR) EWRD=' $END   '
               WRITE(IP,8030) GWRD,INDEX,CICOEF(1,I),CICOEF(2,I),EWRD
  110       CONTINUE
         END IF
         WRITE(IP,8000) VECWRD
      END IF
C
      NOCC = NA
      IF(SCFTYP.EQ.GVB) NOCC = NORBG
      NMOPUN = NOCC
      IF(NPUN.GE.0) NMOPUN = L0
      NMOPRT = MIN(L0,NOCC+10)
      IPASS = 1
      NDAF = 15
C
C     ----- PRINT MO-S, WITH SYMMETRY LABEL IF POSSIBLE -----
C
  120 CONTINUE
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,NDAF,0)
C
      IF(NPRT.GE.0 .AND. NPRTGO.NE.2) THEN
         CALL DAREAD(IDAF,IODA,X(LEIG),L1,NDAF+2,0)
         IF(IPASS.EQ.1) CALL DAREAD(IDAF,IODA,X(LSYMB),L1,255,1)
         IF(IPASS.EQ.2) CALL DAREAD(IDAF,IODA,X(LSYMB),L1,256,1)
         CALL PREVS(X(LVEC),X(LEIG),X(LSYMB),NMOPRT,L1,L1,1)
      END IF
C
      IF(NPUN.GE.-1) CALL PUSQL(X(LVEC),NMOPUN,L1,L1)
C
C        LOOP BACK FOR BETA ORBITALS IF -UHF-
C
      IF(SCFTYP.NE.UHF) GO TO 140
      IF(IPASS .EQ. 2) GO TO 140
      IF (MASWRK) WRITE(IW,9090)
      IPASS = 2
      NMOPUN = NB
      IF(NPUN.GE.2) NMOPUN = L0
      NDAF = 19
      GO TO 120
C
  140 CONTINUE
      IF (MASWRK  .AND.  NPUN.GE.-1) WRITE(IP,8000) ENDWRD
C
C     --- IF NUCLEAR/ELECTRON ORBITAL RUN, OUPUT NUCLEAR MOS ---
C
      IF(MASWRK .AND. NEORUN.EQ.1) THEN
         IF(NPRT.GE.0 .AND. NPRTGO.NE.2) THEN
            CALL NMOOUT(NPUN)
            IF(NPUN.LT.1) CALL PUNNMO(NPUN)
         ELSE
            CALL PUNNMO(NPUN)
         END IF
      END IF
C
C           ----- PROPERTIES AT FINAL GEOMETRY -----
C     REMEMBER THAT NGLEVL=0 MEANS ANALYTIC GRADIENT, AND THUS
C     WE WILL HAVE A DENSITY MATRIX, WHEREAS 1 = NUMERICAL GRAD.
C
  150 CONTINUE
      IF(NFG.NE.0) GO TO 160
C
                                              PRPTYP='SCF '
      IF(DFTYPE.NE.RNONE)                     PRPTYP='DFT '
      IF( CITYP.NE.RNONE  .AND.  NGLEVL.EQ.0) PRPTYP='CI R'
      IF( CITYP.NE.RNONE  .AND.  NGLEVL.EQ.1) PRPTYP='CI E'
      IF( CITYP.EQ.CIS    .AND.  NGLEVL.EQ.0) PRPTYP='CISR'
      IF( CITYP.EQ.CIS    .AND.  NGLEVL.EQ.1) PRPTYP='CISE'
      IF(MPLEVL.EQ.2      .AND.  NGLEVL.EQ.0) PRPTYP='MP2 '
      IF(MPLEVL.EQ.2      .AND.  NGLEVL.EQ.1) PRPTYP='SCF '
      IF( CCTYP.NE.RNONE)                     PRPTYP='SCF '
      IF( CCTYP.NE.RNONE  .AND. IPROPCC.NE.0) THEN
         IF(IROOTCC(1).EQ.1  .AND.  IROOTCC(2).EQ.0) THEN
                                              PRPTYP='CCSD'
         ELSE
                                              PRPTYP='EOMD'
         END IF
      END IF
      IF( VBTYP.NE.RNONE)                     PRPTYP='VB  '
      IF(TDDFTYP.NE.RNONE)                    PRPTYP='TDDF'
C
      CALL PROPTY(PRPTYP)
C
C        PRINT ORBITAL KINETIC ENERGIES FOR THE VT SCALING OPTION
C
      IF (TMPVIR) CALL ORBKIN
C
C     ----- PUNCH CARTESIAN SPACE GRADIENT AND HESSIAN -----
C
  160 CONTINUE
C
C   ----  LVS: PRINTOUT FOR GAURAV
      IF(NPRT .EQ. -2 .AND. ICOORD .EQ. 4) THEN
         CALL EGPUN(EG,NAT,' $GRAD  ')
         GOTO 170
      END IF
C
      IF(NZVAR.EQ.0) THEN
         NQVAL3 = NC1**2
         CALL EGPUN(EG,NAT,' $GRAD  ')
C        IF(NPUN.EQ.1  .OR.  NPUN.EQ.3  .OR.  .NOT.CVGED) THEN
            CALL DAREAD(IDAF,IODA,X(LHESS),NQVAL3, 4,0)
            IF (MASWRK  .AND.  NPRTGO.GT.-1)
     *           WRITE(IP,*) 'CAUTION, APPROXIMATE HESSIAN!'
            CALL FCMPUN(X(LHESS),NC1)
C        END IF
      ELSE
         NQVAL3 = NCVAL**2
         CALL DAREAD(IDAF,IODA,EG,NCOORD,3,0)
         CALL EGPUN(EG,NAT,' $GRAD  ')
C        IF(NPUN.EQ.1  .OR.  NPUN.EQ.3  .OR.  .NOT.CVGED) THEN
            CALL DAREAD(IDAF,IODA,X(LHINT),NQVAL3,43,0)
            CALL TFHB(X(LHINT),X(LHESS),NCVAL,NCOORD,NCVAL,NCOORD,49)
            IF (MASWRK  .AND.  NPRTGO.GT.-1)
     *           WRITE(IP,*) 'CAUTION, APPROXIMATE HESSIAN!'
            CALL FCMPUN(X(LHESS),NCOORD)
C        END IF
      END IF
 170  CONTINUE
C
C     ----- WRAP IT UP ---
C
      IF (IGOFLG.EQ.2) CALL PUVIB(IP,IW,.FALSE.,NCOORD,0,0,0,E,EG,DIP)
      IF (MASWRK) WRITE(IP,FMT='(5H $END)')
      IF (MASWRK  .AND.  NPRTGO.GT.-1) WRITE(IW,9300)
      IF(NPRTGO.NE.2) CALL TIMIT(1)
      CALL RETFM(NEED)
      RETURN
C
 8000 FORMAT(A8)
 8010 FORMAT('--- OPTIMIZED ',A8,' MO-S --- GENERATED AT ',3A8)
 8020 FORMAT('E=',F20.10,', E(NUC)=',F16.10)
 8030 FORMAT(A8,' CICOEF(',I2,')=',F12.8,',',F12.8,A8)
 8040 FORMAT('----- RESULTS FROM SUCCESSFUL ',A8,
     *       ' GEOMETRY SEARCH -----'/
     *       '----- COORDS, ORBS, GRADIENT, AND APPROX. HESSIAN -----')
 8050 FORMAT('----- RESULTS FROM *-*-*INCOMPLETE*-*-* ',A8,
     *       ' GEOMETRY SEARCH'/
     *       '----- COORDS, ORBS, GRADIENT, AND APPROX. HESSIAN -----')
C
 9010 FORMAT(/1X,10A8)
 9020 FORMAT(1X,'**** THE GEOMETRY SEARCH IS NOT CONVERGED! ****'//
     *  1X,'THE NEXT PREDICTED SET OF COORDINATES FOLLOWS.  THEIR'/
     *  1X,'ENERGY AND GRADIENT IS UNKNOWN.  YOU MAY PREFER TO RESTART'/
     *  1X,'WITH SOME OTHER COORDINATES THAN THESE.'//
     *  1X,'YOU SHOULD RESTART "OPTIMIZE" RUNS WITH THE COORDINATES'/
     *  1X,'WHOSE ENERGY IS LOWEST.  RESTART "SADPOINT" RUNS WITH THE'/
     *  1X,'COORDINATES WHOSE RMS GRADIENT IS SMALLEST.  THESE ARE NOT'/
     *  1X,'ALWAYS THE LAST POINT COMPUTED!')
 9050 FORMAT(/10X,'NUCLEAR ENERGY    =',F20.10/
     *        10X,'ELECTRONIC ENERGY =',F20.10/
     *        10X,'TOTAL ENERGY      =',F20.10)
 9055 FORMAT(/5X,'EFFECTIVE FRAGMENT CALCULATION''S TOTAL ENERGY=',
     *            F15.10)
 9060 FORMAT(/10X,'SPIN SZ   =',F5.3/
     *        10X,'S-SQUARED =',F5.3)
 9070 FORMAT(/10X,18(1H-)/10X,18HMOLECULAR ORBITALS/10X,18(1H-))
 9080 FORMAT(/10X,20H**** ALPHA SET **** )
 9090 FORMAT(/10X,18H**** BETA SET ****)
 9130 FORMAT(/1X,'THE INITIAL GEOMETRY IS ALREADY CONVERGED,'/
     *       1X,'SO ORBITALS/PROPERTY OUTPUT IS ALREADY PRINTED ABOVE')
 9300 FORMAT(1X,'......END OF GEOMETRY SEARCH......')
      END
C*MODULE STATPT  *DECK SIGINI
      SUBROUTINE SIGINI(MODE,RUNTYP,NCVAL,NCOORD,METHOD,OUT,GOTEG,
     *                  NPRT,NPUN,ITBMAT,STPT,STSTEP,PROJCT,
     *                  SNZVAR,SOZVAR,MAX,NPRTHS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION METHOD,MSP
C
      CHARACTER*8 CXBASIS
C
      LOGICAL LINEAR,RESTAR,OUT,GOTEG,HSSEND,GOPARR,MASWRK,DSKWRK
      LOGICAL VTSCAL,VIROK,LVCLN,PURIFY,MOVIE,MOVIE2,TRUPD,STPT,PROJCT
      LOGICAL NUCOPT,CLSTEP,NEOTS,NEOCLR
C
      PARAMETER (MXATM=2000)
C
      DIMENSION SNZVAR(MAX),SOZVAR(MAX)
C
      COMMON /APPLE/  MOVIE,MOVIE2
      COMMON /CXTHRM/ CXTHERM(11),CXZPE,METHCX,ICXBAS,CXBASIS
      COMMON /DLCFRZ/ FVALUE(50),ITABLE(50),IFTYPE(50),NCONST
      COMMON /EFPOTD/ METH,INABIO,MOVE
      COMMON /ELGPMT/ NELONG,NATM,NASPIN,NCT,NBNDAB,NTMLB,IPRI,LDOS
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FROZNC/ IFREEZ(3*MXATM),NFRZ
      COMMON /FRZCRT/ IFCART(3*MXATM),NFCART
      COMMON /HSSCTL/ IHESSM,IHREP,HSSEND
      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 /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NEOOPT/ NUCOPT,CLSTEP,NEOTS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      PARAMETER (ZERO=0.0D+00)
C
      PARAMETER (NNAM=29)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA STATPT /8HSTATPT  /
      DATA QNAM /8HMETHOD  ,8HUPHESS  ,8HNSTEP   ,8HNNEG    ,
     *           8HIFOLOW  ,8HDXMAX   ,8HRMIN    ,8HRMAX    ,
     *           8HRLIM    ,8HRESTAR  ,8HHESS    ,8HOPTTOL  ,
     *           8HIHREP   ,8HHSSEND  ,8HIFREEZ  ,8HNPRT    ,
     *           8HNPUN    ,8HPURIFY  ,8HITBMAT  ,8HMOVIE   ,
     *           8HTRUPD   ,8HTRMAX   ,8HTRMIN   ,8HSTPT    ,
     *           8HSTSTEP  ,8HPROJCT  ,8HIFCART  ,8HNPRTHS  ,
     *           8HKDIAGH  /
      DATA KQNAM/5,5,1,1,1,3,3,3,3,0,5,3,1,0,1,1,1,0,1,0,0,3,3,0,3,0,
     *           1,1,1/
C
      DATA SADPT /8HSADPOINT/, OPT   /8HOPTIMIZE/
      DATA VSCF  /8HVSCF    /, G3MP2 /8HG3MP2   /
      DATA SCHLGL/8HSCHLEGEL/, SQA   /8HQA      /
      DATA SRFO  /8HRFO     /, SNR   /8HNR      /
      DATA SCNOPT/8HCONOPT  /
      DATA BFGS  /8HBFGS    /, POWELL/8HPOWELL  /, SKIP  /8HSKIP    /
      DATA MSP   /8HMSP     /
      DATA GUESS /8HGUESS   /, GUESS1/8HGUESS1  /, GUESS2/8HGUESS2  /
      DATA CARDS /8HREAD    /, CALC  /8HCALC    /, RDAB  /8HRDAB    /
      DATA RDALL /8HRDALL   /, BLANK /8H        /
C
C     ----- INITIALIZE THE GEOMETRY SEARCH -----
C     NCOORD IS THE FULL 3*NAT CARTESIAN SPACE, WHILE NCVAL IS
C     THE DIMENSIONALITY OF THE GEOMETRY SEARCH (MAYBE 3*NAT-6).
C
C     -MODE- ALLOWS US TO CALL THIS EARLY IN THE RUN, PRODUCING
C     NO OUTPUT IN ORDER TO FIND OUT IF THIS GRADIENT RUN IS GOING
C     TO BE COMPUTING 2ND DERIVATIVES AT SOME POINT...
C
      IF (MODE.NE.-27 .AND. MASWRK .AND. NPRTGO.NE.2)
     *      WRITE(IW,9000)
      KQNAM(15) = 3*10*MXATM + 1
      KQNAM(27) = 3*10*MXATM + 1
C
      NEOCLR = .TRUE.
      IF(NEORUN.EQ.1) THEN
         IF(NUCOPT) NEOCLR = .FALSE.
      END IF
C
C     ----- READ NAMELIST -$STATPT- -----
C
      METHOD = SQA
      UPHESS = BLANK
      NSTEP = 20
      NNEG = 0
      IF(RUNTYP.EQ.SADPT) NNEG=1
      IFOLOW=1
      DXMAXT = ZERO
      RMIN = 0.0015D+00
      RMAX = 0.1D+00
      RLIM = 0.07D+00
      RESTAR = .FALSE.
      HESS = GUESS
      IF(RUNTYP.EQ.SADPT) HESS=CARDS
      OPTTOL = 0.0001D+00
      IHREP = 0
      HSSEND = .FALSE.
      DO 100 I=1,NCOORD
         IFREEZ(I)=0
  100 CONTINUE
      IF(NEOCLR) CALL VICLR(IFCART,1,NCOORD)
      NPRT = 0
      NPUN = 0
      PURIFY = .FALSE.
      ITBMAT = 5
      MOVIE = .FALSE.
      TRUPD = .TRUE.
      TRMAX = 0.5D+00
      IF(RUNTYP.EQ.SADPT) TRMAX = 0.3D+00
      TRMIN = 0.05D+00
      STPT  = .FALSE.
      STSTEP = 0.01D+00
      PROJCT=.TRUE.
      IF (MOVE.EQ.0) PROJCT=.FALSE.
C     HESSIAN WILL BE PUNCHED AT EVERY NPRTHS OPTIMISATION STEPS.
C     (NEVER PRINTED IF NPRTHS = 0)
      NPRTHS=0
C     USE AN ALTERNATIVE DIAGONALISER FOR APPROXIMATE HESSIAN AS
C     OTHERWISE OPTIMISATION JOBS DIE EVERY FEW STEPS IN FMO.
      KDIAGH=-1
      IF(NFG.NE.0) KDIAGH=2
C
C     NOTE: THE 2ND NAMEIO CALL BELOW MUST BE KEPT IDENTICAL TO THIS.
C
      JRET = 0
      CALL NAMEIO(IR,JRET,STATPT,NNAM,QNAM,KQNAM,
     *            METHOD,UPHESS,NSTEP,NNEG,IFOLOW,DXMAXT,RMIN,
     *            RMAX,RLIM,RESTAR,HESS,OPTTOL,IHREP,HSSEND,
     *            IFREEZ,NPRT,NPUN,PURIFY,ITBMAT,MOVIE,
     *            TRUPD,TRMAX,TRMIN,STPT,STSTEP,PROJCT,IFCART,
     *            NPRTHS,KDIAGH,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)
C
      NERR=0
      IF(JRET .GE. 2) THEN
         IF(MASWRK) WRITE(IW,*) 'TROUBLE INTERPRETING $STATPT'
         NERR=NERR+1
      END IF
C
C     --- POSSIBLE NSTEP RESET FOR NEO ---
C
      IF(.NOT.NEOCLR) CALL NEOSTP
C
C     FOR G3(MP2), WE MUST DO HESSIAN AT END OF HF OPTIMIZATION,
C     BUT NOT AT THE END OF THE MP2 OPTIMIZATION.
C
      IF(RUNTYP.EQ.G3MP2) THEN
         IF(METHCX.EQ.1) HSSEND=.TRUE.
         IF(METHCX.NE.1) HSSEND=.FALSE.
      END IF
C
C        AT THIS POINT, WE ASSUME ANY POSSIBLE HESSIAN COMPUTATION
C        WILL BE PERFORMED ANALYTICALLY.  THIS MIGHT NOT BE TRUE
C        BY THE TIME WE ARE ACTUALLY COMPUTING IT, BUT $FORCE HAS
C        NOT BEEN READ YET TO KNOW FOR SURE.
C
      IF(HESS.EQ.CALC  .OR.  HSSEND) IHESSM=2
C
      IF(NELONG.GE.1) THEN
         CALL VCLR(IFREEZ,1,3*MXATM)
         CALL JKFRZ(IFREEZ,NFRZ,1,IR,3*MXATM)
      ELSE
         NFRZ=0
         DO I=1,NCVAL
            IF(IFREEZ(I) .NE. 0) NFRZ=NFRZ+1
         ENDDO
      ENDIF
C
C           THIS GROUP IS READ BY VSCF JOBS, PROBABLY JUST TO
C           LEARN OPTTOL.  IT SHOULD NOT PERMIT EXOTIC THINGS
C           LIKE HSSEND THAT ARE SIMPLY IRRELEVANT.  SHOULD
C           SOME OTHER THINGS LIKE PURIFY BE TURNED OFF TOO?
C
      IF(RUNTYP.EQ.VSCF) THEN
         HESS=CARDS
         HSSEND=.FALSE.
         IHESSM=0
      END IF
C
      IF(MODE.EQ.-27) RETURN
C
C     LET'S APPLY CONSTRAINTS TO THE INPUT GEOMETRY BEFORE GEOMETRY
C     OPTIMIZATION.
C
      IF (NCONST.GT.0) THEN
          IF (MASWRK) WRITE(IW,9400)
          CALL DCOPY(NCOORD,C,1,X,1)
          CALL CSTCOR(SNZVAR,SOZVAR,NZVAR)
          ICONV = 0
          CALL UPDISP(SNZVAR,NCVAL,NCOORD,DXMAXT,OUT,ITBMAT,
     *                ICONV,RUNTYP)
          CALL SYMDR(SNZVAR)
          CALL BANDBI
          CALL UPCOOR(SNZVAR,NCOORD,OUT)
      END IF
C
      IF(METHOD.NE.SQA .AND. METHOD.NE.SRFO .AND.
     *   METHOD.NE.SNR .AND. METHOD.NE.SCHLGL .AND.
     *   METHOD.NE.SCNOPT) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL CHOICE FOR METHOD'
         NERR=NERR+1
      END IF
      IF(HESS.NE.GUESS .AND. HESS.NE.GUESS1 .AND. HESS.NE.GUESS2 .AND.
     *   HESS.NE.CARDS .AND. HESS.NE.CALC   .AND. HESS.NE.RDAB   .AND.
     *   HESS.NE.RDALL ) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL CHOICE FOR HESS'
         NERR=NERR+1
      END IF
      IF(IFOLOW.EQ.0 .OR. (ABS(IFOLOW).GT.NCVAL .AND. ICOORD.NE.4)) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL CHOICE FOR IFOLOW'
         NERR=NERR+1
      END IF
      IF(NZVAR.EQ.0 .AND.ABS(IFOLOW).NE.1.AND.METHOD.EQ.SCHLGL) THEN
         IF(MASWRK) WRITE(IW,*)
     *        'SCHLEGEL MODE FOLLOWING REQUIRES INTERNALS'
         NERR=NERR+1
      END IF
C          A NEGATIVE VALUE OF IHREP IS NONSENSE
      IF (IHREP.LT.0) THEN
         IF(MASWRK) WRITE(IW,*) 'IHREP CANNOT BE NEGATIVE'
         NERR=NERR+1
      END IF
C          A NEGATIVE VALUE OF ITBMAT IS NONSENSE
      IF (ITBMAT.LT.1) THEN
         IF(MASWRK) WRITE(IW,*) 'ITBMAT MUST BE POSITIVE'
         NERR=NERR+1
      END IF
C
      ITRUPD = 0
      IF(TRUPD) ITRUPD=1
      IF(METHOD.EQ.SNR) ITRUPD=0
      IF(METHOD.EQ.SNR) NNEG=0
      IF(DXMAXT.EQ.ZERO) THEN
         IF(RUNTYP.EQ.G3MP2)  DXMAXT=0.3D+00
         IF(RUNTYP.EQ.OPT)    DXMAXT=0.3D+00
         IF(RUNTYP.EQ.SADPT)  DXMAXT=0.2D+00
         IF(METHOD.EQ.SCNOPT) DXMAXT=0.1D+00
      END IF
C
      IF(UPHESS.EQ.BLANK) THEN
         IF(RUNTYP.EQ.SADPT)  UPHESS=POWELL
         IF(RUNTYP.EQ.G3MP2)  UPHESS=BFGS
         IF(RUNTYP.EQ.OPT  )  UPHESS=BFGS
         IF(METHOD.EQ.SCHLGL) UPHESS=SCHLGL
         IF(METHOD.EQ.SNR   ) UPHESS=POWELL
         IF(METHOD.EQ.SCNOPT) UPHESS=POWELL
      END IF
C
C  THE DIFFERENCE BETWEEN THE IFCART AND IFREEZ IS THIS:
C  THE FIRST REFERS TO STRICTLY CARTESIANS AND THE SECOND
C  TO THE COORDINATES WHICH THE OPTIMIZATION IS PERFORMED IN.
C  IFCART, FOR EXAMPLE, ALLOWS TO FREEZE CARTESIANS IF
C  THE OPTIMIZATION IS PERFORMED USING DLC-S.
C  IN THE CASE OF CARTESIAN OPTIMIZATION THE BOTH KEYWORDS ARE
C  IDENTICAL.
C
C--JHJ---
C--      IF(NFRZ.GT.0 .AND. NZMAT.EQ.0) THEN
C--         IF (MASWRK) WRITE(IW,9080)
C--         NERR=NERR+1
C--      END IF
C--JHJ---
      NFCART=0
      CALL CNTNZ(IFCART,NFCART,NCOORD)
      IF(NFRZ.GT.0 .AND. NFCART.GT.0 .AND. NZMAT.EQ.0) THEN
         IF (MASWRK) WRITE(IW,9100)
         CALL ABRT
      END IF
      LVCLN=.FALSE.
      IF((NFRZ.GT.0 .OR. NFCART.GT.0) .AND. VTSCAL) THEN
         IF (MASWRK) WRITE(IW,9090)
         CALL ABRT
      END IF
C
      IF(NPRT.GT. 1) NPRT= 1
      IF(NPRT.LT.-2) NPRT=-3
      IF(NPUN.GT. 3) NPUN= 3
      IF(NPUN.LT.-2) NPUN=-2
C
      IFCM=4
      IF(MOVIE) CALL SEQOPN(IFCM,'IRCDATA','NEW',.FALSE.,'FORMATTED')
C
C     ----- SET SCHLEGEL METHOD OPTIMIZATION CONTROL PARAMETERS -----
C     GRDERR ... ESTIMATE OF ERROR IN VALUE OF GRADIENT
C
      NP = 0
      IF(METHOD.EQ.SCHLGL) NPMAX=20
      FMAXT  = 1.0D+01
      EIGMAX = 25.0D+00
      EIGMIN = 0.001D+00
      GRDERR = 1.0D-06
C
C              RESTORE /OPTGRD/ FROM DAF (OLD $STATPT VALUES)
C
      IF(RESTAR) THEN
         IF (MASWRK) WRITE(IW,9060)
         LENOPR = 3*MXATM + 34
         LENOPI = (31-1)/NWDVAR+1
         CALL DAREAD(IDAF,IODA,X ,LENOPR,37,0)
         CALL DAREAD(IDAF,IODA,IC,LENOPI,38,1)
         IEXIT = 0
C
C              RESTORE NEW $STATPT VALUES
C
         CALL NAMEIO(IR,JRET,STATPT,NNAM,QNAM,KQNAM,
     *               METHOD,UPHESS,NSTEP,NNEG,IFOLOW,DXMAXT,RMIN,
     *               RMAX,RLIM,RESTAR,HESS,OPTTOL,IHREP,HSSEND,
     *               IFREEZ,NPRT,NPUN,PURIFY,ITBMAT,MOVIE,
     *               TRUPD,TRMAX,TRMIN,STPT,STSTEP,PROJCT,IFCART,
     *               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 .GE. 2) THEN
            IF(MASWRK) WRITE(IW,*) 'ITBMAT MUST BE POSITIVE'
            NERR=NERR+1
         END IF
C
C           ----- OBTAIN INITIAL HESSIAN MATRIX -----
C
      ELSE
         IF(RUNTYP.EQ.SADPT .AND. HESS.EQ.GUESS) HESS=CARDS
         IF (MASWRK  .AND.  NPRTGO.NE.2) WRITE(IW,9005) HESS
         CALL HESSET(HESS,NCVAL,NCOORD,OUT,GOTEG,PURIFY)
C
C           ----- MOVE NUCLEAR COORDINATES INTO X -----
C
         CALL DCOPY(NCOORD,C,1,X,1)
      END IF
      CONVF = OPTTOL
C
C           ----- PRINT OPTIMIZATION INFO -----
C
      IF (MASWRK  .AND.  NPRTGO.NE.2) THEN
         WRITE(IW,9010) METHOD,UPHESS,NNEG,NFRZ,NSTEP,IFOLOW,HESS,
     *                  RESTAR,IHREP,HSSEND,NPRT,NPUN
         WRITE(IW,9020) OPTTOL,RMIN,RMAX,RLIM,DXMAXT,PURIFY,
     *                  MOVIE,TRUPD,TRMAX,TRMIN,ITBMAT,STPT,STSTEP,
     *                  PROJCT
         IF(NFRZ.GT.0) WRITE(IW,9050) (IFREEZ(I),I=1,NFRZ)
         IF(NFCART.GT.0) WRITE(IW,9051) (IFCART(I),I=1,NFCART)
      END IF
C
      IF((NFRZ.EQ.0 .AND. NFCART.GT.0) .AND. NZMAT.EQ.0) THEN
         NFRZ=NFCART
         CALL ICOPY(3*MXATM,IFCART,1,IFREEZ,1)
      END IF
C
      IUPHSS=0
      IF(UPHESS.EQ.POWELL) IUPHSS=1
      IF(UPHESS.EQ.BFGS)   IUPHSS=2
      IF(UPHESS.EQ.SCHLGL) IUPHSS=3
      IF(UPHESS.EQ.SKIP)   IUPHSS=4
      IF(UPHESS.EQ.MSP)    IUPHSS=5
      IF(IUPHSS.EQ.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ILLEGAL HESSIAN UPDATE CHOSEN'
         NERR=NERR+1
      END IF
      IF(NERR.EQ.0) RETURN
C
      IF (MASWRK) WRITE(IW,9055)
      CALL ABRT
      STOP
C
 9000 FORMAT(//10X,29(1H-)/
     *       10X,'STATIONARY POINT LOCATION RUN'/
     *       10X,29(1H-)/)
 9005 FORMAT(1X,'OBTAINING INITIAL HESSIAN, HESS=',A8)
 9010 FORMAT(/10X,'PARAMETERS CONTROLLING GEOMETRY SEARCH ARE'/
     *        10X,'METHOD =',A8,12X,'UPHESS =',A8/
     *        10X,'NNEG   =',I10,10X,'NFRZ   =',I10/
     *        10X,'NSTEP  =',I10,10X,'IFOLOW =',I10/
     *        10X,'HESS   =',A8,12X,'RESTAR =',L10/
     *        10X,'IHREP  =',I10,10X,'HSSEND =',L10/
     *        10X,'NPRT   =',I10,10X,'NPUN   =',I10)
 9020 FORMAT(10X,'OPTTOL =',1P,E10.3,10X,'RMIN   =',1P,E10.3/
     *       10X,'RMAX   =',1P,E10.3,10X,'RLIM   =',1P,E10.3/
     *       10X,'DXMAX  =',1P,E10.3,10X,'PURIFY =',L10/
     *       10X,'MOVIE  =',L10,10X,'TRUPD  =',L10/
     *       10X,'TRMAX  =',1P,E10.3,10X,'TRMIN  =',1P,E10.3/
     *       10X,'ITBMAT =',I10,10X,'STPT   =',L10/
     *       10X,'STSTEP =',1P,E10.3,10X,'PROJCT= ',L10)
 9050 FORMAT(10X,'FROZEN COORD(S)=',20I4/(26X,(20I4)))
 9051 FORMAT(10X,'FROZEN CARTESIANS=',20I4/(28X,(20I4)))
 9055 FORMAT(1X,'***** ERROR IN $STATPT INPUT *****')
 9060 FORMAT(1X,'***   RESTARTING OPTIMIZATION USING INFORMATION ',
     *       'FROM PREVIOUS RUN   ***')
 9090 FORMAT(1X,'SORRY, BUT VIRIAL SCALING DOES NOT WORK WITH FROZEN',
     *           ' COORDINATES')
 9100 FORMAT(1X,'ONLY ONE OF IFCART OR IFREEZ ARRAYS IS NEEDED IN THE',
     *           ' INPUT!')
 9400 FORMAT(/11X,'** GEOMETRY CONSTRAINTS ARE BEING APPLIED. **',/)
      END
C*MODULE STATPT  *DECK SIGVAL
      SUBROUTINE SIGVAL(EXETYP,NCOORD,METHOD,NPRT,NPRTHS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION METHOD,IMS
C
      LOGICAL LINEAR,HSSEND,REHESS,GOPARR,MASWRK,DSKWRK,
     *        VTSCAL,VIROK,LVCLN,MOVIE,MOVIE2,MMONLY,QMMM,
     *        NUCOPT,CLSTEP,NEOTS,NEOSAV
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXRT=100,
     *           MXFRG=1050,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /APPLE/  MOVIE,MOVIE2
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / XX(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      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 /HSSCTL/ IHESSM,IHREP,HSSEND
      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,NO,NBF,NOMIT,MOCPHF,MAXITC
      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 /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NEOOPT/ NUCOPT,CLSTEP,NEOTS
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      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 /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00, TOLGC=1.0D-08)
C
      DATA CHECK/8HCHECK   /, SCHLGL/8HSCHLEGEL/
      DATA UHF/8HUHF     /, GUGA/8HGUGA    /
      DATA IMS/8HIMS     /
C
C     ----- THIS ROUTINE CALLS THE NECESSARY ROUTINES
C           TO EVALUATE THE ENERGY AND GRADIENT -----
C
      IF(MASWRK  .AND.  NPRTGO.NE.2) THEN
         WRITE(IW,9000) NSERCH
         WRITE(IP,8000) NSERCH
         IF(NT.GT.1) CALL PRATM(IW,2)
         CALL PRATM(IW,1)
         CALL PRATM(IP,2)
         IF (QMMM.AND.MASWRK) CALL PRTXYZ(IP)
      END IF
      IFCM=4
      IF(MOVIE) CALL PRMOV(IFCM,1)
      DUMMY = ZERO
      IF(NZMAT.GT.0) CALL PZANDG(DUMMY,0)
      IF(NZMTRD.EQ.1.AND.NZMAT.GT.0) CALL PZANDG(DUMMY,2)
      IF(NZMTRD.EQ.1.AND.NZMAT.EQ.0) THEN
         NZVAR = NZVAR2
         NZMAT = NZMAT2
         NVAR = NVAR2
         CALL PZANDG(DUMMY,2)
         NZVAR = 0
         NZMAT = 0
         NVAR = 0
      END IF
C
      IF (NSERCH.GT.0 .AND. NPRT.GE.-1 .AND. ICOORD.NE.4 .AND. NFG.EQ.0)
     *   CALL INTR
C
C     ----- DECIDE WHETHER OR NOT TO RECALCULATE HESSIAN ----
C
      REHESS = (NSERCH.GT.0  .AND.  IHREP.GT.0)
      IHMOD = 0
      IF(IHREP.GT.0) IHMOD = MOD(NSERCH,IHREP)
      IF (REHESS  .AND.  IHMOD.EQ.0) THEN
         IF (MASWRK) WRITE(IW,9010)
         IF(NEORUN.EQ.1) THEN
            NEOSAV = NUCOPT
            NUCOPT = .FALSE.
         END IF
         CALL HESSX(.FALSE.,.FALSE.)
         IF(NEORUN.EQ.1) NUCOPT = NEOSAV
         IF(NVAR.GT.0) THEN
            NC1 = NCOORD + 6*NFRG
            NQ1 = NVAR   + 6*NFRG
            CALL VALFM(LOADFM)
            LFCM  = LOADFM + 1
            LFCMI = LFCM   + NC1*NC1
            LAST  = LFCMI  + NQ1*NQ1
            NEED = LAST - LOADFM -1
            CALL GETFM(NEED)
            CALL DAREAD(IDAF,IODA,XX(LFCM),NC1*NC1,4,0)
            CALL TFHF(XX(LFCM),XX(LFCMI),NVAR,NCOORD,NQ1,NC1,50)
            CALL DAWRIT(IDAF,IODA,XX(LFCMI),NQ1*NQ1,43,0)
            CALL RETFM(NEED)
         END IF
C
C        ----- IF NOT, CALCULATE THE ENERGY -----
C
      ELSE
         IF (ICOORD .EQ. 4) THEN
            CALL EFSP
            IF(IDPUNC.EQ.1) RETURN
         ELSE
            IF(NFG.NE.0) THEN
C              RUNTYP=GRDKWD
               CALL FMOX(1)
            ELSE
               CALL ENERGX
            END IF
         END IF
C                        OPTIONAL PRINTOUT OF ORBITALS
         IF(NSERCH.GT.0  .AND.  NPRT.EQ.1) THEN
            CALL VALFM(LOADFM)
            LVEC = LOADFM + 1
            LEIG = LVEC   + NUM*NUM
            LAST = LEIG   + NUM
            NEED = LAST - LOADFM -1
            CALL GETFM(NEED)
            IF(SCFTYP.EQ.UHF) THEN
               CALL DAREAD(IDAF,IODA,XX(LVEC),NUM*NUM,15,0)
               CALL DAREAD(IDAF,IODA,XX(LEIG),NUM    ,17,0)
               IF(MASWRK) WRITE(IW,*) ' '
               IF(MASWRK) WRITE(IW,*) 'ALPHA ORBITALS'
               IF(MASWRK) CALL PREV(XX(LVEC),XX(LEIG),NUM,NUM,NUM)
               CALL DAREAD(IDAF,IODA,XX(LVEC),NUM*NUM,19,0)
               CALL DAREAD(IDAF,IODA,XX(LEIG),NUM    ,21,0)
               IF(MASWRK) WRITE(IW,*) ' '
               IF(MASWRK) WRITE(IW,*) 'BETA ORBITALS'
               IF(MASWRK) CALL PREV(XX(LVEC),XX(LEIG),NUM,NUM,NUM)
            ELSE
               CALL DAREAD(IDAF,IODA,XX(LVEC),NUM*NUM,15,0)
               CALL DAREAD(IDAF,IODA,XX(LEIG),NUM    ,17,0)
               IF(MASWRK) WRITE(IW,*) ' '
               IF(MASWRK) WRITE(IW,*) 'MOLECULAR ORBITALS'
               IF(MASWRK) CALL PREV(XX(LVEC),XX(LEIG),NUM,NUM,NUM)
            END IF
            CALL RETFM(NEED)
         END IF
C
         IF(E .EQ. ZERO  .AND.  EXETYP .NE. CHECK) THEN
C                           SCF FAILED TO CONVERGE
            IF (MASWRK) THEN
               WRITE(IW,9020)
               WRITE(IW,9030)
            END IF
            IEXIT = 1
            RETURN
C
         END IF
C
C        ----- AND THEN CALCULATE THE GRADIENT -----
C
         IF(NFG.EQ.0.AND.CODEMP.NE.IMS) THEN
            CALL VCLR(EG,1,NCOORD)
            IF(CITYP.EQ.GUGA) THEN
               CALL CIGRAD
            ELSE
               IF (ICOORD .EQ. 4) THEN
                  CALL EFGRAD
               ELSE
                  CALL HFGRAD
               END IF
            END IF
         ENDIF
      END IF
C     PUNCH GRADIENT AND HESSIAN
C   --- LVS
      IF (NPRT.NE.-2) THEN
         CALL EGPUN(EG,NAT,' $GRAD  ')
      END IF
      IF(NPRTHS.NE.0) THEN
        IF(MOD(NSERCH,NPRTHS).EQ.0) THEN
          NC1 = NCOORD + 6*NFRG
          CALL VALFM(LOADFM)
          LFCM  = LOADFM + 1
          LAST  = LFCM  + NC1*NC1
          NEEDH = LAST - LOADFM - 1
          CALL GETFM(NEEDH)
          IF(NZVAR.EQ.0) THEN
            NQVAL3 = NC1**2
            CALL DAREAD(IDAF,IODA,X(LFCM),NQVAL3, 4,0)
            CALL FCMPUN(X(LFCM),NC1)
          ELSE
C           NOT READY YET
C           NQVAL3 = NCVAL**2
C           CALL DAREAD(IDAF,IODA,X(LHINT),NQVAL3,43,0)
C           CALL TFHB(X(LHINT),X(LHESS),NCVAL,NCOORD,NCVAL,NCOORD,49)
C           CALL FCMPUN(X(LHESS),NCOORD)
          END IF
          CALL RETFM(NEEDH)
        ENDIF
      ENDIF
C
      IF(VTSCAL) THEN
         GVIR  = DDOT(NCOORD,C,1,EG,1)
         BILBO = GVIR  + TWO*EKIN + EPOT
         IF(MASWRK) WRITE(IW,9040) BILBO
         VIROK = .FALSE.
         IF(ABS(BILBO).LT.VTCONV) THEN
            IF(MASWRK) WRITE(IW,9070) BILBO,VTCONV
            IF(MASWRK) WRITE(IW,9080) SCALTT
            VIROK=.TRUE.
         ELSE
            IF(ABS(GVIR).GT.(VTCONV/2.0D+00)) THEN
               CALL NORMAO(1)
               DO 200 I=1,MXGTOT
                  EX(I)=EX(I)*SCALTE
  200          CONTINUE
               CALL NORMAO(2)
               IF(MASWRK) WRITE(IW,9050) SCALTE,SCALTT
            ELSE
C              FMO RUNS SHOULD NEVER CALL ENERGX EXCEPT FROM FMOX.
C              I HAVE NOT DIGESTED WHAT IS TO BE DONE BELOW: DGF.
               IF(NFG.NE.0) CALL ABRT
               IF(MASWRK) WRITE(IW,9060)
               SCALTT=SCALTT/SCALTE
               LVCLN=.TRUE.
               CALL ENERGX
               VIROK=.TRUE.
             END IF
          END IF
      END IF
C
C     IF QMMM OPTIMIZATION, DO MM OPT AND FORM HYBRID GRADIENT
C
      IF(QMMM) THEN
         CALL TOYS
         CALL DAWRIT(IDAF,IODA,EG,3*NAT,3,0)
      END IF
C
C        THE SCHLEGEL METHOD WANTS FORCE, NOT GRADIENT VECTOR
C
      DO 140 I = 1,NCOORD
         IF(METHOD.EQ.SCHLGL) EG(I) = -EG(I)
         IF(ABS(EG(I)) .LT. TOLGC) EG(I) = ZERO
  140 CONTINUE
      RETURN
C
 8000 FORMAT('-------------------- DATA FROM NSERCH=',I4,
     *       ' --------------------')
C
 9000 FORMAT(/1X,'BEGINNING GEOMETRY SEARCH POINT NSERCH=',I4,' ...'/)
 9010 FORMAT(//10X,70(1H*)/
     *         20X,'THE HESSIAN WILL NOW BE RECOMPUTED FROM SCRATCH.'/
     *         10X,70(1H*))
 9020 FORMAT(/11X,'***** FAILURE TO LOCATE STATIONARY POINT,',
     *               ' SCF HAS NOT CONVERGED')
 9030 FORMAT(5X,'UPDATED HESSIAN, GEOMETRY, AND VECTORS ',
     *       'WILL BE PUNCHED FOR RESTART')
 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,'R DE/DR TERM SMALL, CLEANING UP VIRIAL')
 9070 FORMAT(1X,'VIRIAL ERROR',F12.8,' IS LESS THAN VTCONV',
     *          F12.8,' CONVERGED')
 9080 FORMAT(1X,'TOTAL SCALING SO FAR',F12.8)
      END
C*MODULE STATPT  *DECK CSTCOR
      SUBROUTINE CSTCOR(CSTCOD,TZMAT,NZVAR)
C     DLC : A NEW SUBROUTINE FOR THE CONSTRAINT GEO. OPT.
C     THIS ROUTINE APPLIES THE GEOMETRY CONSTRAINTS TO THE
C     INPUT GEOMETRY.
C     SINCE THERE MIGHT BE INCOMPLETE COORDINATE TRANSFORMATIONS BETWEEN
C     CARTESIAN AND DLC, IT IS A GOOD IDEA TO CALL THIS ROUTINE DURING
C     COORDINATE TRANSFORMATIONS.
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ONE=1.0D+00, PIDEG=180.0D+00, ANGSTR=0.52917724924D+00,
     *           ZERO=0.0D+00)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /DLCFRZ/ FVALUE(50),ITABLE(50),IFTYPE(50),NCONST
      DIMENSION CSTCOD(NZVAR),TZMAT(NZVAR)
C
      CALL DAREAD(IDAF,IODA,TZMAT,NZVAR,39,0)
      DEGRAD = ACOS(-ONE)/PIDEG
      DO 300 I=1,NZVAR
 300  CSTCOD(I)=ZERO
      DO 400 I=1,NCONST
         IF (IFTYPE(I).EQ.1 ) THEN
            CSTCOD(ITABLE(I))=FVALUE(I)/ANGSTR-TZMAT(ITABLE(I))
         ELSE
            CSTCOD(ITABLE(I))=FVALUE(I)*DEGRAD-TZMAT(ITABLE(I))
         ENDIF
 400  CONTINUE
      RETURN
      END
C*MODULE STATPT  *DECK CHKCST
      SUBROUTINE CHKCST(CSTCOD,TZMAT,CSTERR,NZVAR)
C     DLC : A NEW SUBROUTINE FOR THE CONSTRAINT GEO. OPT.
C     THIS ROUTINE CHECKS WHETHER GEOMETRY CONSTRAINTS ARE RETAINED.
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (ONE=1.0D+00, PIDEG=180.0D+00, ANGSTR=0.52917724924D+00,
     *           ZERO=0.0D+00)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /DLCFRZ/ FVALUE(50),ITABLE(50),IFTYPE(50),NCONST
      DIMENSION CSTCOD(NZVAR),TZMAT(NZVAR)
C
      DEGRAD = ACOS(-ONE)/PIDEG
      CALL DAREAD(IDAF,IODA,TZMAT,NZVAR,39,0)
      CSTERR = ZERO
      DO 400 I=1,NCONST
       IF (IFTYPE(I).EQ.1 ) THEN
         CSTERR = CSTERR + (FVALUE(I)/ANGSTR-TZMAT(I))**2
       ELSE
         CSTERR = CSTERR + (FVALUE(I)*DEGRAD-TZMAT(I))**2
       ENDIF
 400  CONTINUE
      IF(NCONST.GT.1) CSTERR = SQRT(CSTERR/(NCONST-1))
      CALL CSTCOR(CSTCOD,TZMAT,NZVAR)
      RETURN
      END
C*MODULE STATPT  *DECK SIGX
      SUBROUTINE SIGX(LNR)
C
C     LNR = .FALSE. INDICATE NORMAL USE OF SIGX
C     LNR = .TRUE.  INDICATE THAT A PURE NR SEARCH SHOULD
C                    BE PERFORMED WITH CONTROL PARAMETERS
C                    ASSIGNED EXTERNALLY. USED FOR FINAL
C                    REFINEMENT OF GEOMETRY IN CONNECTION
C                    WITH RUNTYP=GRADEXTR
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION METHOD
C
      LOGICAL CVGED,OUT,GOTEG,HSSEND,GOPARR,MASWRK,DSKWRK,
     *        VTSCAL,VIROK,LVCLN,LINEAR,DOSBEF,EFCONV,
     *        STPT,LNR,PROJCT,NUCOPT,CLSTEP,NEOTS,SERCH0,
     *        MMONLY,QMMM
C
      CHARACTER*6 CTMETH,CTMODE
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /DLCFRZ/ FVALUE(50),ITABLE(50),IFTYPE(50),NCONST
      COMMON /EFPOTD/ METHOF,ISCCHG,MOVE
      COMMON /FMCOM / XX(1)
      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 /FRZCRT/ IFZCRT(3*MXATM),NFZCRT
      COMMON /FUNCT / ENERGY,F(3*MXATM)
      COMMON /HSSCTL/ IHESSM,IHREP,HSSEND
      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 /NEOOPT/ NUCOPT,CLSTEP,NEOTS
      COMMON /NWTOPT/ GRDMIN,CTMODE,CTMETH
      COMMON /OPTEF / D(3*MXATM+6*MXFRG),OLDF(3*MXATM+6*MXFRG),
     *                VMODE(3*MXATM+6*MXFRG),RADIUS
      COMMON /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /TINOPT/ MMONLY,QMMM
      COMMON /TMVALS/ TI,TX,TIM
      COMMON /VIRIAL/ SCALTE,SCALTT,GVIR,VTCONV,MAXVT,VTSCAL,VIROK,LVCLN
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      PARAMETER (TOL=1.0D-08, ONEPT5=1.5D+00, NSUBM=4, ZERO=0.0D+00)
C
      DATA CHECK /8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HSTATPT  /
      DATA SCHLGL/8HSCHLEGEL/, SCNOPT/8HCONOPT  /, SNR   /8HNR      /
      DATA FIVE/5.0D+00/
C
C     ----- GEOMETRY OPTIMIZATION AND TRANSITION STATE LOCATOR -----
C
C     H. BERNHARD SCHLEGEL
C     'OPTIMIZATION OF EQUILIBRIUM GEOMETRIES AND TRANSITION STRUCTURES'
C     J.COMPUT.CHEM. 3,214-218(1982)
C
C     JON BAKER
C     'AN ALGORITHM FOR THE LOCATION OF TRANSITION STATES'
C     J.COMPUT.CHEM. 7, 385-395(1986)
C
C     P.CULOT, G.DIVE, V.H.NGUYEN, J.M.GHUYSEN
C     'A QUASI-NEWTON ALGORITHM FOR FIRST ORDER SADDLE POINT LOCATION'
C     THEORET.CHIM.ACTA  82, 189-205(1992)
C
C     J.M.BOFILL
C     'UPDATED HESSIAN MATRIX AND THE RESTRICTED STEP METHOD FOR
C      LOCATING TRANSITION STRUCTURES'
C      J.COMPUT.CHEM. 15, 1-11(1994)
C
C        SCHLEGEL'S ROUTINES WERE OBTAINED FROM GAUSSIAN 80,
C        AND INCORPORATED INTO GAMESS AT THE NRCC.  NOTE THAT
C        NONE OF SCHLEGEL'S LINEAR SEARCH SCHEMES ARE IMPLEMENTED.
C
C        THE BAKER METHOD IS BASED ON JACK SIMON'S P-RFO ALGORITHM,
C        AS IMPLEMENTED BY JON BAKER.  DETERMINATION OF THE BEST
C        STEP ON THE HYPERSPHERE IS TAKEN FROM CULOT, ET AL., WHICH
C        IS MATHEMATICALLY EQUIVALENT TO HELGAKER'S TRIM METHOD.  THE
C        TRUST RADIUS IS UPDATED DYNAMICALLY ACCORDING TO FLETCHER.
C
C        BAKER'S CODE WAS FIRST INCLUDED INTO GAMESS IN JULY 1988 BY
C        FRANK JENSEN, ODENSE UNIVERSITY, DENMARK.  THE CURRENT VERSION
C        STEMS FROM FRANK JENSEN'S CHANGES IN SEPT. 1995 TO INCLUDE
C        A COMBINATION OF THE NR, P-RFO, AND TRIM/QA ALGORITHMS.
C
C     ----- INITIALIZE THE STATIONARY POINT OPTIMIZATION -----
C
      MPRINT = NPRINT
      OUT = MASWRK .AND.
     *      (NPRINT.EQ.-6 .OR. EXETYP.EQ.DEBUG .OR. EXETYP.EQ.DBUGME)
C
C           TINKER SPECIAL CASE
      IF(MMONLY) THEN
         CALL TOPTIN
         IF(MASWRK) CALL TNEWTX(CTMODE,CTMETH,GRDMIN)
         RETURN
      ENDIF
C           FMO SPECIAL CASE
      IF(MOVE.EQ.0)THEN
        NFRGT=NFRG
        NFRG=0
      END IF
C           NEO SPECIAL CASE
      SERCH0 = .TRUE.
      IF(NEORUN.EQ.1) THEN
         IF(NUCOPT .OR. NEOTS) SERCH0 = .FALSE.
      END IF
C
      IF(SERCH0) NSERCH = 0
      NSUBC = 0
      IEXIT = 0
      CVGED = .FALSE.
      DOSBEF = .FALSE.
      EFCONV = .FALSE.
C
      NCOORD = 3*NAT
      NCVAL = NCOORD
      IF (NZMAT.GT.0) NCVAL = NVAR
      IF (LNR) THEN
          METHOD=SNR
          STPT=.FALSE.
          GOTEG=.TRUE.
      END IF
      MAX1 = MAX((NCOORD+6*NFRG),(NCVAL+6*NFRG))
C     DLC : IN ORDER TO RESERVE LARGEST POSSIBLE ARRAYS.
      MAX2 = MAX((NZVAR+6*NFRG),(NCVAL+6*NFRG))
C
      CALL VALFM(LOADFM)
      LXQUAD = LOADFM + 1
      LXNEW  = LXQUAD + MAX1
      LNZVAR = LXNEW  + MAX1
      LOZVAR = LNZVAR + MAX2
      LAST   = LOZVAR + MAX2
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C         THIS IS WHERE WE READ THE INPUT FOR REAL
C
      MODE = 0
      IF(.NOT.LNR) CALL SIGINI(MODE,RUNTYP,NCVAL,NCOORD,METHOD,OUT,
     *                         GOTEG,NPRT,NPUN,ITBMAT,STPT,STSTEP,
     *                         PROJCT,XX(LNZVAR),XX(LOZVAR),MAX2,NPRTHS)
C
      IF (METHOD.EQ.SCNOPT) GOTEG=.FALSE.
      JTRUPD=ITRUPD
      EFOPTT=CONVF*FIVE
      IF(GOTEG) THEN
         IF (MASWRK) WRITE(IW,9010)
         IF (IEFC+IEFD+IEFQ+IEFO+IEFP+IREP.NE.0) CALL EFCM
         GO TO 100
      END IF
C
C     ----- CALCULATE ENERGY AND GRADIENT AT INITIAL GEOMETRY ---
C
      IF(NPRT.LE.-1) NPRINT = -5
      IF(NPUN.EQ.-1) NPUNCH =  1
      IF(NPUN.EQ.-2) NPUNCH =  0
      IF(MOVE.EQ.0) NFRG=NFRGT
C     CONOPM ONLY WORKS IN CARTESIAN COORDINATES AT PRESENT
      IF (METHOD.EQ.SCNOPT) CALL CONOPM(NCOORD,NPUN,NPRT,NPRTHS,OUT)
      IF(.NOT.STPT) CALL SIGVAL(EXETYP,NCOORD,METHOD,NPRT,NPRTHS)
      IF(IDPUNC.EQ.1) THEN
         CALL RETFM(NEED)
         RETURN
      END IF
      IF(MOVE.EQ.0) THEN
        NFRGT=NFRG
        NFRG=0
      END IF
      IF(IEXIT.EQ.1) CALL ABRT
C
C           BEGIN STATIONARY POINT LOCATION CYCLES
C           --------------------------------------
C           REDUCE PRINTOUT TO MINIMAL AND PUNCHOUT TO OCCUPIED ORBS
C
  100 CONTINUE
      IF (DOSBEF) WRITE(IW,9320) NSERCH,NSUBC
      IF(NPRINT.EQ.6  .OR.  NPRINT.EQ.7) NPRINT = -5
                     NPUNCH=1
      IF(NPUN.GE. 2) NPUNCH=2
      IF(NPUN.EQ.-2) NPUNCH=0
C
C        ----- PREDICT DISPLACEMENTS TO NUCLEAR COORDINATES ------
C
      IF (LVCLN) THEN
         ITMP=IUPHSS
         IUPHSS=4
      END IF
      CALL DISPLC(CVGED,XX(LXQUAD),XX(LXNEW),NCVAL,NCOORD,
     *            NPUN,OUT,METHOD,ITBMAT,STPT,STSTEP,PROJCT,RUNTYP)
      IF (LVCLN) THEN
         IUPHSS=ITMP
         LVCLN=.FALSE.
      END IF
C   ---- LVS: PATCH FOR MC RUNS
      IF(IDPUNC.EQ.1) THEN
         CALL RETFM(NEED)
         RETURN
      END IF
      IF(EXETYP.EQ.CHECK) THEN
         CALL RETFM(NEED)
         RETURN
      END IF
C
      IF (DOSBEF.AND.NSUBC.LE.NSUBM) GO TO 150
      IF(CVGED .AND. .NOT.VTSCAL) GO TO 200
      IF(CVGED .AND. VIROK) GO TO 200
      IF(CVGED .AND. VTSCAL) THEN
         IF (MASWRK) WRITE(IW,9310)
         LVCLN = .TRUE.
         CALL DAREAD(IDAF,IODA,F,NCOORD,3,0)
         CALL ENERGX
         VIROK = .TRUE.
         CVGED = .FALSE.
         GO TO 100
      END IF
C
C     SAVE OLDF
C
  150 IF(METHOD.NE.SCHLGL) CALL EGMOVE(OLDF,F,DEFT,TORQ,NCVAL,NFRG)
C
C
      IF (NSUBC.LE.NSUBM.AND.DOSBEF) THEN
         NSUBC = NSUBC + 1
         CALL STVDER
         IREST = 0
         CALL GEFCOV(DEFT,TORQ,NFRG,EFGMAX,EFGRMS,EFCONV,EFOPTT)
         IF (EFCONV.OR.NSUBC.EQ.NSUBM+1) THEN
            DOSBEF=.FALSE.
            ITRUPD=0
            GO TO 160
         ELSE
            CALL VCLR(F,1,NCOORD)
            GO TO 100
         END IF
      END IF
C
C        ----- SYMMETRIZE THE DISPLACEMENT VECTOR -----
C
      CALL SYMDR(XX(LXNEW))
C
C        ----- IF CARTESIANS ARE FROZEN, FORCE DISPLACEMENTS TO BE ZERO
C
         IF (NFZCRT.GT.0) THEN
           DO 50 III=1,NFZCRT
              IIFR=IFZCRT(III)
              XX(LXNEW-1+IIFR)=ZERO
 50        CONTINUE
         END IF
C
C        ------ UPDATE THE NUCLEAR COORDINATES ------
C
      CALL UPCOOR(XX(LXNEW),NCOORD,OUT)
C
C     DLC : SOMETIMES, ESPECIALLY WHEN YOU WANT TO CONSTRAINT TORSIONAL
C           ANGLE(S), THE BACK TRANSFORMATION IS NOT COMPLETE.
C           SO IT WOULD BE A GOOD IDEA TO CHECK IT.
C
      IF (NCONST.GT.0)  THEN
       DO 170 I=1,ITBMAT
        CALL CHKCST(XX(LNZVAR),XX(LOZVAR),CSTERR,NZVAR)
        IF (CSTERR .GT. TOL) THEN
         IF (MASWRK) WRITE(IW,9410)
         ICONV = 0
         CALL UPDISP(XX(LNZVAR),NCVAL,NCOORD,DXMAXT,OUT,ITBMAT,
     *               ICONV,RUNTYP)
         CALL SYMDR(XX(LNZVAR))
         CALL BANDBI
         CALL UPCOOR(XX(LNZVAR),NCOORD,OUT)
        ELSE
         GO TO 155
        ENDIF
 170   CONTINUE
       IF (MASWRK) WRITE(IW,9450)
      ENDIF
 155  CONTINUE
C
      NSERCH = NSERCH+1
      ITRUPD=JTRUPD
      IF (MOVE.EQ.2.AND.NSUBC.EQ.0) THEN
         CALL EEFOPT(NCOORD,NFRG,F,EFCONV,DOSBEF,EFOPTT)
         IF (DOSBEF) THEN
            WRITE(IW,9000) NSERCH
            WRITE(IP,8000) NSERCH
            CALL PRATM(IW,2)
            CALL PRATM(IP,2)
            IF (QMMM.AND.MASWRK) CALL PRTXYZ(IP)
            ITRUPD=0
            GO TO 100
         END IF
      END IF
C
  160 NSUBC = 0
C
C        ----- TEST FOR TOO MANY STEPS, OR NOT ENOUGH TIME -----
C
      IF(NSERCH .GT. NSTEP) THEN
         IF(NEORUN.EQ.1 .AND. CLSTEP) THEN
            CALL RETFM(NEED)
            RETURN
         END IF
         IF (MASWRK) THEN
            WRITE(IW,9210)
            WRITE(IW,9230)
         END IF
         GO TO 200
      END IF
C
      TNEED = ONEPT5 * (TIM/NSERCH)
      IF((TIMLIM-TIM) .LT. TNEED) THEN
         IF (MASWRK) THEN
            WRITE(IW,9220) NSERCH,TIM,TIMLIM,TNEED
            WRITE(IW,9230)
         END IF
         GO TO 200
      END IF
C
C        ----- CALCULATE ENERGY AND GRADIENT AT NEW COORDINATES -----
C
      IF(MOVE.EQ.0) NFRG=NFRGT
      CALL SIGVAL(EXETYP,NCOORD,METHOD,NPRT,NPRTHS)
      IF(IDPUNC.EQ.1) THEN
         CALL RETFM(NEED)
         RETURN
      END IF
      IF(MOVE.EQ.0) THEN
        NFRGT=NFRG
        NFRG=0
      END IF
      IF(IEXIT.EQ.1) GO TO 200
      GO TO 100
C
C     ----- OPTIMIZATION AT END, PRINT/PUNCH FINAL RESULTS ----
C
  200 CONTINUE
      CALL RETFM(NEED)
      NPRINT = MPRINT
      CALL SIGEND(CVGED,NSERCH,NCVAL,NCOORD,NPRT,NPUN)
      IF(CVGED .AND. HSSEND) THEN
         IF (MASWRK) WRITE(IW,9300)
         CALL HESSX(.TRUE.,.TRUE.)
      END IF
      RETURN
C
 8000 FORMAT('-------------------- DATA FROM NSERCH=',I4,
     *       ' --------------------')
 9000 FORMAT(/1X,'BEGINNING GEOMETRY SEARCH POINT NSERCH=',I4,' ...'/)
 9010 FORMAT(/1X,'THE GRADIENT AT THE INITIAL GEOMETRY IS KNOWN.'/
     *       1X,'PROCEEDING DIRECTLY TO THE GEOMETRY SEARCH...')
 9210 FORMAT(/6X,'***** FAILURE TO LOCATE STATIONARY POINT,',
     *              ' TOO MANY STEPS TAKEN *****')
 9220 FORMAT(/6X,'***** FAILURE TO LOCATE STATIONARY POINT,',
     *           ' NSERCH=',I5,' *****'/
     *           1X,'TOO LITTLE TIME TO DO ANOTHER POINT,',
     *           1X,'TIME USED=',F15.1/' TIMLIM GIVEN=',F15.1,
     *              ' NEXT POINT NEEDS=',F15.1,' SECONDS')
 9230 FORMAT(5X,'UPDATED HESSIAN, GEOMETRY, AND VECTORS ',
     *       'WILL BE PUNCHED FOR RESTART')
 9300 FORMAT(//5X,57(1H*)/
     *         5X,'THE HESSIAN WILL NOW BE COMPUTED AT THE ',
     *             'STATIONARY POINT.'/
     *         5X,57(1H*))
 9310 FORMAT(/1X,'GEOMETRY CONVERGED, BUT VIRIAL ERROR IS STILL',
     *            ' TOO LARGE',/,
     *        1X,'CLEANING UP VIRIAL FOR FIXED GEOMETRY')
 9320 FORMAT(/1X,'RUNNING OPTIMIZATION WITHIN EFFECTIVE FRAGMENT',
     *            ' AB INITIO PART IS FROZEN.',/,
     *        1X,'TRUST RADIUS IS NOT UPDATED',/,
     *        1X,'NSERCH =',I4,7X,'NSUBC =',I4)
 9410 FORMAT(//11X,'CONSTRAINT TRANSFORMATION IS NOT COMPLETE.',/,
     X        11X,'ONE MORE ITERATION IS GOING TO BE PERFORMED.',/)
 9450 FORMAT(//5X,'** WARNING: GEOMETRY CONSTRAINTS ARE NOT SATISFIED.',
     *            ' **'//)
      END
C*MODULE STATPT  *DECK SYMDR
      SUBROUTINE SYMDR(DR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT,GOPARR,MASWRK,DSKWRK
C
      DIMENSION DR(3,*)
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      COMMON /FRAME / U1,U2,U3,V1,V2,V3,W1,W2,W3,X0,Y0,Z0
      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 /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TRANSF/ XSMAL,YSMAL,ZSMAL,XNEW,YNEW,ZNEW,XP,YP,ZP
C
      PARAMETER (ZERO = 0.0D+00, ONE=1.0D+00)
C
 9020 FORMAT(' IN SYMDR PTR ='/(1X,3F12.7))
C
      IF(NT.EQ.1) RETURN
      OUT = NPRINT.EQ.-6 .AND. MASWRK
C
C     ----- CALCULATE TRANFORMATION MATRICES OF COORDINATES. -----
C
      X = X0+ONE
      Y = Y0
      Z = Z0
      XS = X
      YS = Y
      ZS = Z
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 100 IT = 1,NT
         NN = 9*(IT-1)
         CALL TRANS(NN)
         CALL ROT
         N = 3*(IT-1)
         PTR(1,N+1) = XP-X0
         PTR(2,N+1) = YP-Y0
         PTR(3,N+1) = ZP-Z0
  100 CONTINUE
      X = X0
      Y = Y0+ONE
      Z = Z0
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 120 IT = 1,NT
         NN = 9*(IT-1)
         CALL TRANS(NN)
         CALL ROT
         N = 3*(IT-1)
         PTR(1,N+2) = XP-X0
         PTR(2,N+2) = YP-Y0
         PTR(3,N+2) = ZP-Z0
  120 CONTINUE
      X = X0
      Y = Y0
      Z = Z0+ONE
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 140 IT = 1,NT
         NN = 9*(IT-1)
         CALL TRANS(NN)
         CALL ROT
         N = 3*(IT-1)
         PTR(1,N+3) = XP-X0
         PTR(2,N+3) = YP-Y0
         PTR(3,N+3) = ZP-Z0
  140 CONTINUE
      IF(MASWRK .AND. OUT) WRITE(IW,9020)
     *   (PTR(1,IT),PTR(2,IT),PTR(3,IT),IT=1,3*NT)
C
C     ----- SYMMETRIZE DISPLACEMENT VECTOR -----
C
      DO 320 IC = 1,NAT
      DO 220 IT = 1,NT
      IF(MAPCTR(IC,IT) .GT. IC) GO TO 320
  220 CONTINUE
      DX = ZERO
      DY = ZERO
      DZ = ZERO
      DO 240 IT = 1,NT
      ICNU = MAPCTR(IC,IT)
      DXP = DR(1,ICNU)
      DYP = DR(2,ICNU)
      DZP = DR(3,ICNU)
      N = 3*(IT-1)
      DX = DX+DXP*PTR(1,N+1)+DYP*PTR(2,N+1)+DZP*PTR(3,N+1)
      DY = DY+DXP*PTR(1,N+2)+DYP*PTR(2,N+2)+DZP*PTR(3,N+2)
      DZ = DZ+DXP*PTR(1,N+3)+DYP*PTR(2,N+3)+DZP*PTR(3,N+3)
  240 CONTINUE
      DR(1,IC) = DX
      DR(2,IC) = DY
      DR(3,IC) = DZ
      DO 300 IT = 1,NT
      ICNU = MAPCTR(IC,IT)
      IF(ICNU .EQ. IC) GO TO 300
      IF(IT .EQ. NT) GO TO 280
      IT1 = IT+1
      DO 260 JT = IT1,NT
      IF(MAPCTR(IC,JT) .EQ. ICNU) GO TO 300
  260 CONTINUE
  280 CONTINUE
      JT = INVT(IT)
      N = 3*(JT-1)
      DXP = DX*PTR(1,N+1)+DY*PTR(2,N+1)+DZ*PTR(3,N+1)
      DYP = DX*PTR(1,N+2)+DY*PTR(2,N+2)+DZ*PTR(3,N+2)
      DZP = DX*PTR(1,N+3)+DY*PTR(2,N+3)+DZ*PTR(3,N+3)
      DR(1,ICNU) = DXP
      DR(2,ICNU) = DYP
      DR(3,ICNU) = DZP
  300 CONTINUE
  320 CONTINUE
      DUM = NT
      DO 340 N = 1,NAT
      DO 340 I = 1,3
  340 DR(I,N) = DR(I,N)/DUM
      RETURN
      END
C*MODULE STATPT  *DECK UPCOOR
      SUBROUTINE UPCOOR(XNEW,NCOORD,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL LINEAR,OUT,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000)
C
      DIMENSION XNEW(*)
C
      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 /OPTGRD/ X(3*MXATM),ES,FE(20),
     *                CONVF,FMAXT,DXMAXT,RMAX,RMIN,RLIM,
     *                EIGMAX,EIGMIN,GRDERR,FRMS,FMAX,TRMAX,TRMIN,
     *                IC(20),NSTEP,NSERCH,NPMAX,NP,IFOLOW,
     *                NNEG,IUPHSS,IEXIT,ITRUPD,IPAD,KDIAGH
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
C     ----- CHANGE COORDS BY TOTAL DISPLACEMENT -----
C
      IF(MASWRK .AND. OUT) WRITE(IW,9020)
      IF(MASWRK .AND. OUT) WRITE(IW,9030) (X(I),I=1,NCOORD)
      IF(MASWRK .AND. OUT) WRITE(IW,9030) (XNEW(I),I=1,NCOORD)
      DO 100 I = 1,NCOORD
         X(I) = X(I) + XNEW(I)
  100 CONTINUE
C
C     ----- MOVE NEW COORDINATES INTO C -----
C     ----- UPDATE COORDINATES IN DIRECT ACCESS FILE -----
C
      CALL DCOPY(NCOORD,X,1,C,1)
      CALL DAWRIT(IDAF,IODA,C,NCOORD,1,0)
C
C     ----- CALCULATE B AND B INVERSE FOR THE NEW COORDS -----
C
      IF(NZMAT.GT.0) CALL BANDBI
      IF(NZMAT.EQ.0  .AND.  NZMTRD.EQ.1) THEN
         NZVAR = NZVAR2
         NZMAT = NZMAT2
         NVAR = NVAR2
         CALL BANDBI
         NZVAR = 0
         NZMAT = 0
         NVAR = 0
      END IF
      RETURN
C
 9020 FORMAT(/1X,'X,XNEW IN ROUTINE UPCOOR')
 9030 FORMAT(1X,10F12.7)
      END
C*MODULE STATPT  *DECK TFDQ
      SUBROUTINE TFDQ(DELQ,DELR,S,NCVAL,NZVAR,NFLAG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.00D+00)
      DIMENSION DELQ(*),DELR(*),S(NZVAR,NZVAR)
C
C       ROUTINE TRANSFORMS DLC TO REDUNDANT INTERNAL COORDS.
C
      IF (NFLAG.EQ.1) THEN
         DO 100 I=1,NZVAR
           TEM= ZERO
           DO 150 J=1,NCVAL
             TEM = TEM+DELQ(J)*S(I,J)
 150       CONTINUE
           DELR(I)=TEM
 100     CONTINUE
      ELSE
         DO 200 I=1,NCVAL
           TEM= ZERO
           DO 250 J=1,NZVAR
             TEM = TEM+DELQ(J)*S(J,I)
 250       CONTINUE
           DELR(I)=TEM
 200     CONTINUE
      ENDIF
      RETURN
      END
C*MODULE STATPT  *DECK UPDISP
      SUBROUTINE UPDISP(DELCOR,NCVAL,NCOORD,DXMAXT,OUT,ITBMAT,ICONV,
     *                  RUNTYP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
      PARAMETER (ZERO=0.00D+00,ONE=1.00D+00,TWO=2.00D+00)
C     DLC : THE TOL IS CHANGED FROM 1.0D-04 TO 1.0D-08,
C           IN ORDER TO STRICTLY RETAIN GEOMETRY CONSTRAINTS DURING
C           COORDINATE TRANSFORMATIONS.
      PARAMETER (THREE=3.00D+00)
C
      LOGICAL OUT,CONVRG,GOPARR,DSKWRK,MASWRK,LINEAR
C
      DIMENSION DELCOR(*)
C
      COMMON /FMCOM / XX(1)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      DATA VSCF  /8HVSCF    /
C
C   THIS ROUTINE TRANSFORMS THE INTERNAL DISPLACEMENT INTO CARTESIANS.
C      NOTE THAT ICONV=0 IS A GOOD RETURN VALUE (CONVERGED),
C      WHEREAS   ICONV=1 IS A BAD, UNCONVERGED CASE.
C
      IF (MASWRK) WRITE(IW,9050)
      PI     = ACOS(-ONE)
      CONVRG = .FALSE.
      ICONV  = 0
      TOL    = 1.0D-08
      IF(RUNTYP.EQ.VSCF) TOL = 1.0D-04
C
C     DLC : !! NOTE I CHANGED MAJOR ALGORITHM OF THE FOLLOWING PART
C           PLEASE READ IT CAREFULLY.
C
      CALL VALFM(LOADFM)
      LXCOR  = LOADFM + 1
      LX0    = LXCOR  + NCOORD
      LRZMAT = LX0    + NCOORD
      LCOR   = LRZMAT + NZMAT
      LR0    = LCOR   + NZVAR
      LRNEW  = LR0    + NZVAR
      LRTMP  = LRNEW  + NZVAR
      LS     = LRTMP  + NZVAR
      LAST   = LS     + NZVAR*NZVAR
      NEED   = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     DLC
C     GET THE UPDATED INTERNAL COORDINATES
C     !!!!  NOTE  !!!!
C     THERE HAS BEEN A MAJOR MODIFICATION TO THIS ROUTINE.
C     NOW ALL BACK TRANSFORMATION TO CARTESIAN IS DONE WITHOUT USING
C     SYMMETRY COORDINATES IN ORDER TO REMOVE PUNTS.
C
      INZMAT = 39
      IIZMAT = 40
      CALL DAREAD(IDAF,IODA,XX(LS),NZVAR*NZVAR,46,0)
C     DLC : TRANSFORM THE DLC STEPS, DELTA(D) INTO REDUNADANT
C           INTERNAL COORDINATE STEPS, DELTA(Q).
      CALL TFDQ(DELCOR,XX(LCOR),XX(LS),NCVAL,NZVAR,1)
C
      CALL DCOPY(NCOORD,C,1,XX(LX0),1)
      CALL DCOPY(NCOORD,XX(LX0),1,XX(LXCOR),1)
      CALL DAREAD(IDAF,IODA,XX(LR0),NZVAR,INZMAT,0)
      CALL DAREAD(IDAF,IODA,XX(LRZMAT),NZMAT,IIZMAT,1)
      CALL GETQ0(XX(LR0),NZVAR,XX(LRZMAT),NZMAT,XX(LCOR),PI)
C
C    ITERATE AS IN PULAY AND COWORKERS, JACS, 101, 2550 (1979)
C    EXCEPT CHANGING THE B MATRIX AND ITS INVERSE IN EACH ITERATION
C
      DO 190 I = 1,ITBMAT
C       GET CARTESIAN STEPS.
        CALL TFDS(DELCOR,NCVAL,NCOORD)
C
        CALL VADD(XX(LXCOR),1,DELCOR,1,XX(LXCOR),1,NCOORD)
C       GET A NEW CARTESIAN COORDINATES.
        CALL DCOPY(NCOORD,XX(LXCOR),1,C,1)
        CALL BANDBI
        CALL DAREAD(IDAF,IODA,XX(LRNEW),NZVAR,INZMAT,0)
        CALL VSUB(XX(LRNEW),1,XX(LR0),1,XX(LCOR),1,NZVAR)
C
        DO 160 J = 1,NZVAR
           IF (ABS(XX(LCOR-1+J)).GT.(TWO*PI-ONE)) THEN
              IF (XX(LCOR-1+J).LT.ZERO) THEN
                 XX(LCOR-1+J) = XX(LCOR-1+J) + TWO*PI
              ELSE
                 XX(LCOR-1+J) = XX(LCOR-1+J) - TWO*PI
              END IF
           END IF
           IF (ABS(XX(LCOR-1+J)).GT.(PI-ONE)) THEN
              IF (XX(LCOR-1+J).LT.ZERO) THEN
                 XX(LCOR-1+J) = XX(LCOR-1+J) + PI
              ELSE
                 XX(LCOR-1+J) = XX(LCOR-1+J) - PI
              END IF
           END IF
  160   CONTINUE
C
C     DLC : TRANSFORM THE REDUNADANT INTERNAL COORDINATE STEPS, DELTA(Q)
C           INTO DELTA(D).
      CALL TFDQ(XX(LCOR),DELCOR,XX(LS),NCVAL,NZVAR,2)
C
        DELMAX = ABS(DELCOR(IDAMAX(NCVAL,DELCOR,1)))
        IF (MASWRK) WRITE(IW,9060) I,DELMAX
        DELRMS = DDOT(NCVAL,DELCOR,1,DELCOR,1)
        DELRMS = SQRT(DELRMS)
        CONVRG = (DELRMS.LE.(TOL/THREE)).AND.(DELMAX.LE.TOL)
C
        IF (DELMAX .GT. ONE) CONVRG=.TRUE.
        IF (CONVRG) GO TO 200
  190 CONTINUE
C
  200 CONTINUE
      IF (.NOT.CONVRG) THEN
         IF(MASWRK) WRITE (IW,9070) ITBMAT
         ICONV = 1
      END IF
C
C     IF THE STEP IS TOO BIG IN CARTESIANS, WRITE A MESSAGE.
C     THIS CAN HAPPEN WHEN THE B MATRIX CONVERTS A REASONABLE
C     JUMP IN INTERNALS INTO A BIG JUMP IN CARTESIANS, FOR
C     EXAMPLE WHEN THREE ANGLES AROUND AN ATOM SUM TO ALMOST 360
C     OR WHEN CONVERGENCE WAS NOT REACHED.
C
      CALL VSUB(XX(LX0),1,XX(LXCOR),1,DELCOR,1,NCOORD)
      CALL DCOPY(NCOORD,XX(LX0),1,C,1)
      CIRCLE = DDOT(NCOORD,DELCOR,1,DELCOR,1)
      CIRCLE = SQRT(CIRCLE)
      IF(CIRCLE.GT.THREE*DXMAXT) THEN
         IF(MASWRK) WRITE(IW,9090) CIRCLE
         ICONV = 1
      END IF
      IF(MASWRK .AND. OUT) WRITE(IW,9080) (DELCOR(I),I=1,NCOORD)
C
      CALL RETFM(NEED)
      RETURN
C
 9050 FORMAT(10X,'TRANSFORMING DISPLACEMENT FROM INTERNALS TO ',
     *           'CARTESIANS')
 9060 FORMAT(10X,'THE ROOT MEAN SQUARE ERROR IN ITERATION ',I3,' IS ',
     *           F12.8)
 9070 FORMAT(1X,'WARNING! THE CONVERSION FROM INTERNALS TO CARTESIANS'/
     *       1X ,' DID NOT CONVERGE IN ',I4,' ITERATIONS.')
 9080 FORMAT(1X,'IN DISPLC, XNEW='/(1X,10F12.7))
 9090 FORMAT(1X,'WARNING! THE RADIUS IN CARTESIANS IS ',F10.5)
      END
