C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 14 NOV 05 - DGF - PAD COMMON BLOCK ENRGYS
C 19 SEP 05 - MWS - ADD TRUE NUCLEAR CHARGE ARRAY TO INFOA COMMON
C  5 JUL 05 - MWS - TIGHT CI CONVERGENCE IF MRPT/STRAIGHT CI/GRADIENT
C 30 APR 05 - DGF - RAISE DAVIDSON ACURACY FOR FMO
C 23 JUL 04 - MWS - GUGADG: TIGHTEN CI CONVERGENCE IF DOING DERIVATIVES
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C 19 SEP 01 - MWS - CONVERT MXAOCI PARAMTER TO MXAO
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 11 JUN 00 - SK  - GUGADG: ONE MORE WORD NEEDED FOR PRCIVC
C 21 DEC 99 - DGF - REPLACE MEMMAX WITH MAXHAM/MAXDIA,
C                   ADD NOIRR TO COMMONS GUGWFN, DETWFN
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 27 FEB 98 - DGF - GUGADG: FIX SOME TOTAL MEMORY COMPUTATIONS
C  6 JAN 98 - DGF - GUGADG: END FINICKY TURN OUT OF SMALL NOCC RUNS,
C                   GET NSTATE FROM SPNTRN COMMON IF NECESSARY
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C  8 MAY 97 - MWS - GUGADG: NEXTRA TO 5, THEN IGNORE AFTER FIRST DIAG
C 14 FEB 97 - MWS - GUGADG: VLCR OF EIGENDATA DURING CHECK
C  8 JAN 97 - GMC - GUGADG: CHANGES FOR DROPPING MCSCF CORES
C 26 NOV 96 - VAG - INCREASE CI AO'S TO 768
C 17 OCT 96 - KRG - ADD ERROR MESSAGES BEFORE ABRT CALLS
C 13 JUN 96 - MWS - GUGADG: ADJUST ORBITAL CORE COUNT ONLY FOR MCSCF
C 18 APR 96 - GMC - GUGADG: CHANGES FOR FOCAS PRINTOUT
C 25 MAR 96 - MWS - INCLUDE ROUTINE TO ERASE PREVIOUS CI EIGENVECTORS
C 26 JUL 95 - FPR - EDGUES,EDIVCD: USE ITERMX INPUT INSTEAD OF 50
C  1 FEB 95 - MWS - GUGADG: ONLY DO DAVIDSON CORRECTION IF SCF DOMINANT
C 22 JAN 95 - SK  - MODIFY SPNTRN COMMON FOR MXRT ROOTS
C 12 NOV 94 - MWS - REMOVE SOME FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 21 APR 94 - MWS - EDGUES: FIX VERY OLD BUG FOR IN CORE H,INDIRECT SOLN
C 13 DEC 93 - TLW - PAR. CI DIAG, ALL NODES KEEP PRIVATE VECTOR FILES.
C 19 JUL 93 - MWS - USE SEPARATE STORAGE FOR I/O BUFFERS
C 26 JUN 93 - MWS - GUGADG: ALLOC DISTINCT IDLIST FOR 2ND EDGUES CALL
C  2 APR 92 - MWS,TLW - COMMON ENRGYS MADE PURE FLOATING POINT
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C  5 FEB 92 - MWS - GUGADG: RENORM. DAV. CORR. FOR CI-SD AND SOCI
C 11 JAN 92 - TLW - MAKE READ PARALLEL
C 10 JAN 92 - TLW - CHANGE REWINDS TO CALL SEQREW
C  6 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C  9 NOV 91 - MWS - EDGUES: WRITE HEADER RECORD ON CI VECTOR FILE,
C                   LARGE PROBLEMS SAVE A*B VECTORS WHEN RESTARTING.
C 12 SEP 90 - MWS - INTRODUCE MXATM
C 30 MAR 90 - MWS - BURST INTO GUGDGA AND GUGDGB
C 11 DEC 89 - MWS - IF 0'S FOUND IN CI VECTOR HEADER, MAKE A GUESS
C                   INSTEAD OF READING VECTORS (NEEDED FOR S-O RUNS).
C 30 SEP 89 - MWS - SHORTEN COMMENTS TO LESS THAN 72 CHARS.
C 27 SEP 89 - MWS - SUPPRESS PRINT IN EDICVD (PASS LUPRNT, NOT LUEMSG),
C                   EXPLANATION OF DAVIDSON'S QUADRUPLES OUTPUT
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C 15 JUL 89 - STE - EDGUES: FIX SOME EXISTING VECTOR CASES
C 19 MAY 89 - MWS - USE STFASE BEFORE PRINTING CI VECTOR
C 26 APR 88 - STE - USE OLD VECTORS FOR INITIAL GUESS
C 12 MAR 88 - STE - DECLARE AND TYPE INTEGER FOR CRAY
C 14 NOV 88 - MWS - USE PKREAD TO READ FILE NFT16
C  7 OCT 88 - MWS - INCREASE AO NUMBER FROM 128 TO 256
C 17 AUG 88 - MWS - FIX MEMORY ALLOCATION FOR FINAL CSF PRINTOUT
C 19 JUL 88 - MWS - CHANGE CALL TO PRCIVC TO PRINT CSF OCCUPANCIES
C  9 JUL 88 - MWS - ALLOW IROOTS TO OVERRIDE NSTATE IF LARGER
C  5 APR 88 - MWS - EXTEND MICHEL'S IDEA EVEN FURTHER
C 28 MAR 88 - MWS - USE MICHEL DUPUIS'S IDEA FOR H*V IN EDPAB3
C  8 MAR 88 - STE - FIX BUG WHEN NEXTRA .LT. NO. INITIAL GUESS VECTORS
C 26 FEB 88 - STE - EDNEWB: LET ORTHOG. LOOP RUN UP TO 5 TIMES
C  7 FEB 88 - STE - IMPROVE ORTHOG. EXP. VECTOR CHECK, PRT IN MEM. SOLN.
C  4 JAN 88 - STE - ALLOW MXXPAN=NWKS
C 15 NOV 87 - STE - USE EXETYP=CHECK
C 24 AUG 87 - STE - EDNEWB,FRARBR,FRTRBT: USE SQREAD
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C  4 MAY 87 - STE - GUGADG: REMOVE REFERENCES TO LIGSW
C 28 NOV 86 - STE - IMPROVE ERROR MESSAGES
C  3 NOV 86 - STE - CLARIFY VARIABLE USE, USE PARAMETER STATEMENTS
C 13 OCT 86 - MWS - FIX UNPACKING IN ROUTINE EDPAB3
C  5 AUG 86 - MWS - CORRECT WORK15/WORK16 COMPARISON IN GUGADG
C 30 JUL 86 - MWS - PAD COMMON ENRGYS, ALTER ITS READ
C 22 JUL 86 - MWS - REPLACE RZEROF WITH VCLR
C 11 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS,
C                   PACKING FOR CELERITY AND CRAY VERSIONS
C  4 APR 86 - MWS - ADD COMMA IN FORMAT 981 IN EDNEWB
C 31 OCT 85 - STE - /CIFILS/ IN GUGADG; USE GENERIC ABS,MAX,MIN,SQRT
C                   REMOVE DATA CONFLICTS: EDPAB1,EDPAB3,EDIVC1,ECIVC3
C 10 MAR 85 - MWS - ELIMINATE PARAMETER STATEMENTS, DSQRT USED,
C                   LOGAND FUNCTION INVOKED FOR LOGICAL ANDING
C 27 JUL 84 - STE - FIX ONE-TRIP LOOP BUG IN EDPAB1
C 22 JUL 84 - STE - SET ENERGY VALUES AT PROPER POINT IN GUGDG
C  7 MAY 84 - STE - PROVISION TO WORK WITH HAMILTONIAN IN MEMORY
C  3 MAY 84 - STE - SAVE ENERGY DATA IN DICTIONARY RECORD 2
C  9 APR 84 - STE - USE DP BLAS COPY AND SCAL INSTEAD OF SP VERSIONS
C 15 MAR 84 - STE - ABS CHANGED TO DABS
C  8 MAR 84 - STE - ALLOW MXXPAN.GE.NWKS TO SOLVE PROBLEM
C 26 FEB 84 - STE - ALLOW USE OF LIGENB SOMETIMES IN GUGADG
C 17 FEB 84 - STE - REPLACE DVDSON WITH EDAVID ET AL.
C
C*MODULE GUGDGA  *DECK EDGUES
      SUBROUTINE EDGUES(LUPRNT,NFT15,NFT16,LUVECS,NLARGE,IDLORT,
     *                  IDHIRT,MXGUES,MXMPRV,KPRINT,LENA,NEMEMX,LENBAB,
     *                  NSELCT,SELTHR,CVGETH,NEXTRA,NBASIS,IDSHFT,
     *                  ESHIFT,ADIAGS,EIGVAL,BVECT,AXB,BTAB,CVECT,WRK,
     *                  IWRK,NLIST,IDLIST,AMATRX,XX1,XX2,IXX,INDX,
     *                  ITERMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL PRINT,PRINT2,PRINT3,GOPARR,DSKWRK,MASWRK
C
C
      DIMENSION BVECT(NLARGE,MXMPRV),AXB(NLARGE,MXMPRV),IDLIST(NLARGE),
     *          CVECT(MXGUES,MXMPRV),BTAB(LENBAB),EIGVAL(MXGUES),
     *          WRK(MXGUES,8),IWRK(MXGUES),NLIST(MXGUES),ADIAGS(NLARGE),
     *          INDX(NLARGE),AMATRX(LENA),XX1(NEMEMX),XX2(NEMEMX),
     *          IXX(NEMEMX)
C
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DATA CHECK/8HCHECK   /
C
  001 FORMAT(/1X,'ITER. NO.JUST IMPROVED    ENERGY AND STATE')
  004 FORMAT(1X,I3,I4,'(MAX.TOL.STATE)',5(F17.9,I3)/(23X,5(F17.9,I3)))
C
C-----------------------------------------------------------------------
C*  7 FEB 88 - STE * 23 FEB 84 - STE
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE) DATE: NOV 1982
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE PROVIDED THE INITIAL GUESS VECTORS.
C*                                    ****
C*
C*    ON ENTRY -
C*       LUPRNT - INTEGER (LOGICAL UNIT NO.)
C*                PRINT FILE
C*                IF POSITIVE, PRINT INFORMATION REQUESTED BY KPRINT
C*                IF NEGATIVE, PRINT ONLY ERROR MESSAGES
C*                IF ZERO, SUPPRESS ALL PRINTING, INCLUDING ERROR MESS.
C*       NFT15  - INTEGER (LOGICAL UNIT NO.)
C*                GAMESS/GUGA DIAGONAL LOOPS
C*       NFT16  - INTEGER (LOGICAL UNIT NO.)
C*                GAMESS/GUGA OFF-DIAGONAL LOOPS
C*       LUVECS - INTEGER (LOGICAL UNIT NO.)
C*                IF NEGATIVE, SUFFICIENT MEMORY IS AVAILABLE TO HAVE
C*                         BVECT  AND  AXB  MEMORY RESIDENT.
C*                OTHERWISE  BVECT  WILL BE STORED ON UNIT LUVECS
C*                AND  AXB  WILL BE STORED ON UNIT LUVECS+3
C*       NLARGE - INTEGER
C*                DIMENSION OF REAL SYMMETRIC INPUT MATRIX  A.
C*       IDLORT - INTEGER
C*                NO. OF LOWEST ROOT TO BE OBTAINED (LOWEST IS 1)
C*       IDHIRT - INTEGER
C*                NO. OF HIGHEST ROOT TO BE OBTAINED (HIGHEST IS NLARGE)
C*       MXGUES - INTEGER
C*                MAXIMUM NUMBER OF INITIAL GUESS BASIS VECTORS.
C*                IF MXGUES >= NLARGE, THE INPUT MATRIX IS PLACED IN
C*                BTAB  AND SOLVED.
C*       MXMPRV - INTEGER
C*                MAXIMUM NO. OF VECTORS TO SIMULTANEOUSLY IMPROVE
C*       KPRINT - INTEGER
C*                PRINTED OUTPUT CONTROL MASK (NO PRINTING IF ZERO)
C*                BIT  0  FINAL EIGENVALUES
C*                BIT  2  EIGENVALUES AND TOLERANCES AT EACH TRUNCATION
C*                BIT  3  EIGENVALUES EVERY ITERATION
C*       LENA   - INTEGER
C*                LENGTH OF BUFFERS FOR PROCESSING MATRIX  A.
C*       LENBAB - INTEGER
C*                WORDS OF MEMORY AVAILABLE TO STORE TRANSFORMED  A.
C*                = MXGUES*(MXGUES+1)/2
C*       NSELCT - INTEGER
C*                DETERMINES WHICH OF UP TO MXGUES UNIT VECTORS WILL BE
C*                USED FOR THE INITIAL GUESS.
C*                = 0, IDHIRT LOWEST DIAGONAL ELEMENTS PLUS DIAGONAL
C*                     ELEMENTS WITHIN SELTHR OF IDHIRT ELEMENT.
C*                < 0, FIRST ABS(NSELCT) VECTORS.
C*                > 0, NSELCT LOWEST DIAGONAL ELEMENTS.
C*       SELTHR - W.P. REAL
C*                INITIAL GUESS SELECTION THRESHOLD WHEN NSELCT = 0
C*       CVGETH - W.P. REAL
C*                RELATIVE EIGENVALUE CONVERGENCE THRESHOLD
C*                (VECTOR ACCURACY IS SQUARE ROOT OF THIS VALUE)
C*       NEXTRA - INTEGER
C*                IF PROBLEM CAN BE SOLVED BY EDAVID HERE,
C*                THIS MANY EXTRA EXPANSION BASIS VECTORS WILL BE
C*                USED ON THE FIRST ITERATION.  THE NUMBER OF EXTRA
C*                VECTORS IS DECREASED BY ONE EACH ITERATION UNTIL
C*                NO EXTRA VECTORS ARE PRESENT.  THIS IS USEFUL IN
C*                "CAPTURING" VECTORS FOR HIGHER ROOTS.
C*       NBASIS - INTEGER
C*                SOLVE WITH GIVENS IF NO MORE THAN NBASIS INITIAL
C*                EXPANSION VECTORS, OTHERWISE USE DAVIDSON
C*
C*    ON EXIT -
C*       NBASIS - INTEGER
C*                NO. OF INITIAL BASIS VECTORS CREATED.
C*       IDSHFT - INTEGER
C*                NO. OF LOWEST DIAGONAL ELEMENT OF MATRIX  A.
C*       ESHIFT - W.P. REAL
C*                VALUE OF LOWEST DIAGONAL ELEMENT, BY WHICH ALL
C*                OTHER DIAGONAL ELEMENTS ARE REDUCED (SHIFTED).
C*       ADIAGS - W.P. REAL (NLARGE)
C*                SHIFTED DIAGONAL ELEMENTS OF MATRIX A
C*       EIGVAL - W.P. REAL (MXGUES)
C*                EIGENVALUES OF THE INITIAL BASIS VECTORS
C*                (IN THE EXPANSION BASIS SPACE)
C*       BVECT  - W.P. REAL (NLARGE,MXGUES)
C*                INITIAL EXPANSION BASIS VECTORS (B)
C*       AXB    - W.P. REAL (NLARGE,MXGUES)
C*                INITIAL A * B VECTORS
C*       BTAB   - W.P. REAL (LENBAB,2)
C*                EXPANSION BASIS REPRESENTATION OF  A
C*                (B(TRANSPOSE) * A * B)
C*       CVECT  - W.P. REAL (MXGUES,MXMPRV)
C*                CONTRACTION VECTORS (EIGENVECTORS OF BTAB)
C*                OR EIGENVECTORS IF  A  CAN BE HELD IN MEMORY.
C*                (IF BTAB WAS BIG ENOUGH TO HOLD ALL OF  A)
C*
C*    WORK AREAS -
C*       AMATRX - W.P. REAL (LENA)
C*                BUFFER FOR REAL SYMMETRIC MATRIX  A
C*       WRK    - W.P. REAL (MXGUES,8)
C*                WRK(*,*) BTAB DIAGONALIZATION WORK SPACE
C*                WRK(*,1) = EIGENVALUES + ESHIFT
C*       IWRK   - INTEGER (MXGUES)
C*                BTAB DIAGONALIZATON WORK SPACE
C*       NLIST  - INTEGER (MXGUES)
C*                LIST OF INITIAL UNIT VECTORS
C*       IDLIST - INTEGER (NLARGE)
C*                MAPS ORIGINAL SPACE ONTO BASIS SPACE
C*                (MAY BE EQUIVALENCED BY CALL TO BVECT)
C*       INDX   - INTEGER (NLARGE)
C*                INDEXING ARRAY FOR GAMESS/GUGA OFF-DIAGONAL ELEMENTS
C
C           SET UP PRINTING VARIABLES
C
      LUEMSG=ABS(LUPRNT)
      PRINT  = LUPRNT .GT. 0 .AND. MASWRK
      PRINT2 = PRINT .AND. LOGAND(KPRINT,2**2).NE.0
      PRINT3 = PRINT .AND. LOGAND(KPRINT,2**3).NE.0
C
C        PERFORM INTEGRITY CHECKS
C
      IF(IDLORT.LT.1)THEN
         IF(MASWRK) THEN
            WRITE(IW,*) ' IDLORT .LT. 1 IN EDGUES IN GUGDGA.SRC'
            WRITE(IW,*) ' IDLORT IS NO. OF LOWEST ROOT TO BE OBTAINED'
            WRITE(IW,*) ' IDLORT IS ',IDLORT
         END IF
         CALL ABRT
      END IF
      IF(IDLORT.GT.IDHIRT)THEN
         IF(MASWRK) THEN
            WRITE(IW,*) ' IDLORT .GT. IDHIRT IN EDGUES IN GUGDGA.SRC'
            WRITE(IW,*) ' IDLORT IS NO. OF LOWEST ROOT TO BE OBTAINED'
            WRITE(IW,*) ' IDHIRT IS NO. OF HIGHEST ROOT TO BE OBTAINED'
            WRITE(IW,*) ' IDLORT IS ',IDLORT
            WRITE(IW,*) ' IDHIRT IS ',IDHIRT
         END IF
         CALL ABRT
      END IF
      IF(LENBAB.LT.(MXGUES*MXGUES+MXGUES)/2)THEN
         IF(MASWRK) THEN
            WRITE(IW,*)
     *   ' LENBAB .LT. (MXGUES*MXGUES+MXGUES)/2 IN EDGUES IN GUGDGA.SRC'
            WRITE(IW,*)
     *   ' LENBAB IS MEMORY AVAILABLE TO STORE TRANSFORMED A'
            WRITE(IW,*)
     *   ' MXGUES IS THE MAXIMUM NUMBER OF INITIAL GUESS BASIS VECTORS'
            WRITE(IW,*) ' LENBAB IS ',LENBAB
            WRITE(IW,*) ' MXGUES IS ',MXGUES
         END IF
         CALL ABRT
      END IF
      IF(MXMPRV.LT.1) THEN
         IF(MASWRK) THEN
            WRITE(IW,*) ' MXMPRV .LT. 1 IN EDGUES IN GUGDGA.SRC'
            WRITE(IW,*)
     * ' MXMPRV IS THE MAXIMUM NO. OF VECTORS TO SIMULTANEOUSLY IMPROVE'
            WRITE(IW,*) ' MXMPRV IS ',MXMPRV
         END IF
         CALL ABRT
      END IF
      IF(MXMPRV.GT.MXGUES) THEN
         IF(MASWRK) THEN
            WRITE(IW,*) ' MXMPRV .GT. MXGUES IN EDGUES IN GUGDGA.SRC'
            WRITE(IW,*)
     * ' MXMPRV IS THE MAXIMUM NO. OF VECTORS TO SIMULTANEOUSLY IMPROVE'
            WRITE(IW,*)
     * ' MXGUES IS THE MAXIMUM NUMBER OF INITIAL GUESS BASIS VECTORS'
            WRITE(IW,*) ' MXMPRV IS ',MXMPRV
            WRITE(IW,*) ' MXGUES IS ',MXGUES
         END IF
         CALL ABRT
      END IF
      IBASIS=NBASIS
C
C           GET DIAGONAL ELEMENTS OF  A
C
      CALL EDIAG3(NFT15,NLARGE,ADIAGS,INDX,NEMEMX,XX1,XX2,IDSHFT,ESHIFT)
      IF(EXETYP.EQ.CHECK) GO TO 108
C
      LUOVEC = IABS(LUVECS)
      CALL SEQREW(LUOVEC)
      READ(LUOVEC,ERR=108,END=108) NSTATE,NCSFS
      IF(NSTATE+NCSFS .EQ. 0) GO TO 108
         IF(PRINT) WRITE(IW,9030)
C
C           USE OLD VECTORS AS INITIAL GUESS
C
         IF(NCSFS.NE.NLARGE  .OR.  NSTATE.NE.IDHIRT) THEN
            IF (MASWRK) THEN
               WRITE(LUEMSG,*) 'PROBLEM WITH PREVIOUS CI VECTOR FILE'
               WRITE(LUEMSG,*)
     *            'CURRENT AND PREVIOUS NUMBER OF CSFS=',NCSFS,NLARGE
               WRITE(LUEMSG,*)
     *            'CURRENT AND PREVIOUS NUMBER OF NSTATE=',
     *            NSTATE,IDHIRT
               WRITE(LUEMSG,*) 'THE FIX IS ERASING OLD -CIVECTR- FILE'
            END IF
            CALL ABRT
         END IF
         NBASIS=NSTATE
         DO 100 ISTATE = 1,NSTATE
            CALL SQREAD(LUOVEC,BVECT(1,ISTATE),NCSFS)
            IF(NCSFS.EQ.0) THEN
               IF (MASWRK) WRITE(LUEMSG,*)
     *            'UNEXPECTED END OF FILE ON UNIT',LUOVEC
               CALL ABRT
            END IF
  100    CONTINUE
C
C           MATRIX FITS IN MEMORY
C
         IF (NLARGE .EQ. MXGUES) THEN
            LNBTAB = (NCSFS*NCSFS+NCSFS)/2
            DO 101 I = 1,NLARGE
               NLIST(I) = I
  101       CONTINUE
C
C              PUT HAMILTONIAN IN MEMORY AT -BTAB-
C
            CALL EDITA3(NFT16,NLARGE,NEMEMX,LNBTAB,NLARGE,NLARGE,
     *                  NLIST,NLIST,ADIAGS,INDX,XX1,XX2,IXX,BTAB)
C
C                 SOLVE USING TRI-DIAGONALIZATION...
C
            IF (NLARGE .LE. IBASIS) THEN
               IERR = 0
               CALL GLDIAG(NLARGE,IDHIRT,NLARGE,BTAB,WRK,EIGVAL,CVECT
     *                       ,IERR,IWRK)
               IF(IERR.NE.0)THEN
                  IF(MASWRK) WRITE(IW,*)
     *             ' TRI-DIAGONALIZATION FAILED IN EDGUES'
                  CALL ABRT
               END IF
               DO 102 K = IDLORT,IDHIRT
                  EIGVAL(K) = EIGVAL(K) + ESHIFT
  102          CONTINUE
C
C                 ... OR SOLVE WITH DAVIDSON METHOD
C
            ELSE
               IF(PRINT2 .OR. PRINT3) WRITE(LUPRNT,001)
C
C                 FORM A * B
C
               CALL EDPAB1(NLARGE,NSTATE,LNBTAB,BTAB,ADIAGS,BVECT,AXB)
C
C                 FORM B(T) * A * B  IN  AMATRX
C
               IJ = 0
               CALL FRTRBT(0,NLARGE,1,NSTATE,LENBAB,BVECT,AXB,IJ,AMATRX)
C
C                 GET EIGENVECTORS OF B(T) * A * B
C
               CALL DCOPY(IJ,AMATRX,1,AMATRX(IJ+1),1)
               CALL GLDIAG(NBASIS,NBASIS,NBASIS,AMATRX(IJ+1),WRK,EIGVAL
     *                    ,BVECT(1,MXMPRV+1),IERR,IWRK)
               IF(IERR.NE.0)THEN
                 IF(MASWRK) THEN
                    WRITE(IW,*)' DAVIDSON DIAG FAILED IN EDGUES'
                    WRITE(IW,*)' TO GET EIGENVECTORS OF B(T) * A * B'
                 END IF
                 CALL ABRT
               END IF
               DO 103 K = IDLORT, IDHIRT
                  EIGVAL(K) = EIGVAL(K) + ESHIFT
  103          CONTINUE
               IF (PRINT3) THEN
                 WRITE(LUPRNT,004)0,NBASIS,(EIGVAL(K),K,K=IDLORT,IDHIRT)
               END IF
C
               MXITER=ITERMX
               CALL EDAVID(LUPRNT,0,0,NLARGE,IDLORT,IDHIRT,MXMPRV,
     *                     IDHIRT,NEXTRA,MXITER,KPRINT,LENBAB,LENA/2,
     *                     IDHIRT,NSTATE,CVGETH,1,ESHIFT,ADIAGS,
     *                     EIGVAL,CVECT,BVECT,AXB,BTAB,AMATRX,
     *                     BVECT(1,MXMPRV+1),WRK,IWRK,NLIST,IDLIST,
     *                     XX1,XX2,IXX,NEMEMX,INDX)
            END IF
         ELSE
C
C           MATRIX DOES NOT FIT IN MEMORY
C
C              FORM  A * B
C
            CALL EDPAB3(NFT16,NLARGE,NSTATE,ADIAGS,BVECT,AXB,
     *                  INDX,XX1,XX2,IXX,NEMEMX)
            IF(LUVECS.GT.0) THEN
               LUAXB= LUVECS + 3
               CALL SEQREW(LUAXB)
               DO 105 I=1,NSTATE
                  CALL SQWRIT(LUAXB,AXB(1,I),NLARGE)
  105          CONTINUE
            END IF
C
C              FORM B(T) * A * B
C
            IJ = 0
            CALL FRTRBT(0,NLARGE,1,NSTATE,LENBAB,BVECT,AXB,IJ,BTAB)
C
C              GET EIGENVECTORS OF B(T) * A * B
C
            CALL DCOPY((NBASIS*NBASIS+NBASIS)/2,BTAB,1,AMATRX,1)
            CALL GLDIAG(NBASIS,IDHIRT,NBASIS,AMATRX,WRK,EIGVAL,CVECT
     *                 ,IERR,IWRK)
            IF(IERR.NE.0)THEN
               IF(MASWRK)THEN
                  WRITE(IW,*)' DIAGONALIZATION FAILED IN EDGUES'
                  WRITE(IW,*)' USING OUT OF MEMORY METHOD'
               END IF
               CALL ABRT
            END IF
            DO 106 K = IDLORT, IDHIRT
               EIGVAL(K) = EIGVAL(K) + ESHIFT
  106       CONTINUE
            IF ((NBASIS .NE. NLARGE) .AND. (PRINT2 .OR. PRINT3))
     *          WRITE(LUPRNT,001)
            IF (PRINT3) THEN
               WRITE(LUPRNT,004) 0,NBASIS,(EIGVAL(K),K,K=IDLORT,IDHIRT)
            END IF
         END IF
         RETURN
C        ******
C
C           SELECT NBASIS INITIAL UNIT VECTORS
C
  108 CONTINUE
      MXIVEC=MAX(MXGUES,ABS(NSELCT))
      MXIVEC = MIN(MXIVEC,NLARGE) + 1
  110 CONTINUE
         MXIVEC=MXIVEC-1
         CALL EDIBVC(LUEMSG,NLARGE,MXIVEC,IDHIRT+NEXTRA,NSELCT,
     *               SELTHR,ADIAGS,NBASIS,WRK,NLIST,IDLIST)
         LNBTAB=(NBASIS*NBASIS+NBASIS)/2
      IF(LNBTAB.GT.LENBAB) GO TO 110
C
C           FORM INITIAL  BTAB  ARRAY
C
      MAXIVC=NLIST(NBASIS)
      IF(EXETYP.NE.CHECK)
     *   CALL EDITA3(NFT16,NLARGE,NEMEMX,LNBTAB,MAXIVC,NBASIS,NLIST,
     *               IDLIST,ADIAGS,INDX,XX1,XX2,IXX,BTAB)
C
C            GET  NCVECT  CONTRACTION VECTORS FROM EXPANSION BASIS SPACE
C
      NCVECT=MXMPRV
      IF(NLARGE.EQ.MXGUES) NCVECT = IDHIRT
      IF(NBASIS.LE.IBASIS) THEN
C
C                 SOLVE DIRECTLY
C
         IERR=0
         IF (EXETYP.NE.CHECK) THEN
            CALL GLDIAG(NBASIS,NCVECT,NBASIS,BTAB,WRK,EIGVAL,CVECT,
     *                  IERR,IWRK)
            IF(IERR.NE.0)THEN
               IF (MASWRK) THEN
                  WRITE(IW,*)' DIAGONALIZATION FAILED IN EDGUES'
                  WRITE(IW,*)' USING SOLVE DIRECTLY METHOD'
               END IF
               CALL ABRT
            END IF
            DO 130 K = IDLORT, IDHIRT
               EIGVAL(K) = EIGVAL(K) + ESHIFT
  130       CONTINUE
            IF ((NBASIS .NE. NLARGE) .AND. (PRINT2 .OR. PRINT3))
     *          WRITE(LUPRNT,001)
         ELSE
            CALL VCLR(CVECT,1,NBASIS*NCVECT)
            CALL VCLR(EIGVAL,1,NCVECT)
         END IF
C
      ELSE
C
C                 SOLVE INDIRECTLY
C
         IF(PRINT2 .OR. PRINT3) WRITE(LUPRNT,001)
         IF (NBASIS .EQ. NLARGE) THEN
            IPRINT = KPRINT
            IEXTRA = NEXTRA
            LUEMSG = LUPRNT
         ELSE
            IPRINT = 0
            IEXTRA = 0
         END IF
         CALL EDIVCD(LUPRNT,NCVECT,NBASIS,LNBTAB,IEXTRA,IPRINT,
     *               CVGETH,ESHIFT,BTAB,EIGVAL,CVECT,NEMEMX,
     *               ITERMX)
      END IF
C
      IF(EXETYP.EQ.CHECK) RETURN
C
C              QUIT IF EXPANSION BASIS SPANS INPUT MATRIX
C
      IF(NBASIS.EQ.NLARGE) THEN
         IF (PRINT) THEN
            IF (NBASIS .LE. IBASIS) THEN
               WRITE(LUPRNT,*) 'SOLUTION FOUND WITH DIRECT METHOD'
            ELSE
               WRITE(LUPRNT,*) 'SOLUTION FOUND WITH INDIRECT METHOD'
            END IF
         END IF
         RETURN
      END IF
C
      IF (PRINT3) THEN
         ITER=0
         WRITE(LUPRNT,004) ITER,NBASIS,(EIGVAL(K),K,K=IDLORT,IDHIRT)
      END IF
C
C           FORM NCVECT INITIAL  B  AND  A * B  VECTORS
C
      CALL EDIVC3(NFT16,NLARGE,NEMEMX,NCVECT,NBASIS,NLIST,IDLIST,
     *            ADIAGS,CVECT,INDX,XX1,XX2,IXX,AXB,BVECT)
      IF(LUVECS.GT.0) THEN
         LUAXB= LUVECS + 3
         CALL SEQREW(LUVECS)
         WRITE(LUVECS) IDHIRT,NLARGE
         CALL SEQREW(LUAXB)
         DO 140 I=1,NCVECT
            CALL SQWRIT(LUVECS,BVECT(1,I),NLARGE)
            CALL SQWRIT(LUAXB,   AXB(1,I),NLARGE)
  140    CONTINUE
      END IF
      NBASIS=NCVECT
C
C           TRANSFORM  A  TO INITIAL EXPANSION BASIS SPACE
C
      IJBTAB=0
      CALL FRTRBT(LUVECS,NLARGE,1,NBASIS,LENBAB,BVECT,AXB,IJBTAB,BTAB)
C
C           RESET CONTRACTION VECTORS TO UNIT VECTORS
C
      CALL RUNITV(NBASIS,NBASIS,CVECT)
      RETURN
 9030 FORMAT(1X,'RESTARTING WITH PREVIOUS CI EIGENVECTORS...')
      END
C*MODULE GUGDGA  *DECK EDIAG3
      SUBROUTINE EDIAG3(NFT,NWKS,H,INDX,NEMEMX,XX1,IX,IDMIN,HMIN)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION H(NWKS),INDX(NWKS),XX1(NEMEMX),IX(*)
C
      PARAMETER (MXRT=100)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE INITIALIZES THE DIAGONAL ELEMENT VECTOR FOR CASE 3
C*               *                 **                             *
C*       (GAMESS/GUGA FILE)
C*
C*    ON ENTRY -
C*       NFT    - INTEGER (LOGICAL UNIT NO.)
C*                GAMESS/GUGA ENERGY MATRIX FILE
C*       NWKS   - INTEGER
C*                NO. OF CONFIGURATIONS (LENGTH OF VECTOR H)
C*       NEMEMX - INTEGER
C*                W.P. WORDS FOR EACH BUFFER
C*
C*    ON EXIT -
C*       H      - W.P. REAL (NWKS)
C*                DIAGONAL ENERGY TERMS SHIFTED BY HMIN
C*       IDMIN  - INTEGER
C*                NO. OF LOWEST DIAGONAL ELEMENT USED FOR SHIFT
C*       HMIN   - W.P. REAL
C*                VALUE OF LOWEST DIAGONAL ELEMENT, USED FOR SHIFT
C*
C*    WORK AREAS -
C*       INDX   - INTEGER (NWKS)
C*                INDEX BUFFER
C
      ENC = ECORE + ENUCR
      IF (GOPARR) ENC = ENC/NPROC
      DO 100 I = 1,NWKS
         H(I) = ENC
  100 CONTINUE
      IF (EXETYP .EQ. CHECK) RETURN
      READ (NFT) INDX
      NUWK = 0
      MX = 0
*I64  MASK32 = 2**32 - 1
C
  120 CONTINUE
      CALL PXREAD(NFT,XX1,IX,MX,NEMEMX)
      NX = ABS(MX)
      IF (NX .EQ. 0) GO TO 220
C
      DO 200 N = 1,NX
      VAL = XX1(N)
C
      NPACK = N
*I32  IPACK = IX( 2*NPACK - 1 )
*I32  JPACK = IX( 2*NPACK     )
*I64  LABEL = IX(NPACK)
*I64  IPACK = ISHFT( LABEL, -32 )
*I64  JPACK = IAND( LABEL, MASK32 )
      IUWK = IPACK
      NLWK = JPACK
C
      IF (IUWK.EQ.0) THEN
         NUWK = INT(VAL)
         GO TO 200
      END IF
C
      DO 180 I = 1,NLWK
         II = INDX(IUWK)
         DO 160 J = 1,NUWK
            H(II) = H(II)+VAL
            II = II+1
  160    CONTINUE
         IUWK = IUWK+1
  180 CONTINUE
  200 CONTINUE
      IF (MX .GT. 0) GO TO 120
C
  220 CONTINUE
C
      IF (GOPARR) CALL DDI_GSUMF(1850,H,NWKS)
C
      HMIN = 0.0D+00
      IDMIN=0
      DO 240 I=1,NWKS
         IF(H(I).GE.HMIN) GO TO 240
            HMIN=H(I)
            IDMIN=I
  240 CONTINUE
C
C              SHIFT DIAGONAL ELEMENTS TO IMPROVE PRECISION
C
      DO 260 I=1,NWKS
         H(I) = H(I)-HMIN
  260 CONTINUE
      RETURN
      END
C*MODULE GUGDGA  *DECK EDIBVC
C* 20 APR 1983 - STE
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE)  DATE: 1 APR 1983
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE CHOSES THE INITIAL UNIT BASIS VECTORS
C*                          *            *     * *
C*
C*    ON ENTRY -
C*       LUEMSG - INTEGER (LOGICAL UNIT NUMBER)
C*                PRINT FILE FOR ERROR MESSAGES (IF ZERO, NO PRINT)
C*       NLARGE - INTEGER
C*                DIMENSION OF THE INPUT MATRIX A.
C*       MAXBAS - INTEGER
C*                MAXIMUM NO. OF BASIS VECTORS THAT CAN BE USED.
C*       IDHIRT - INTEGER
C*                NO. OF THE HIGHEST EIGENVALUE SOUGHT.
C*       NSELCT - INTEGER
C*                DETERMINES METHOD OF CHOOSING UNIT BASIS VECTORS.
C*                = 0, IDHIRT LOWEST DIAGONAL ELEMENTS PLUS DIAGONAL
C*                     ELEMENTS WITHIN SELTHR OF IDHIRT ELEMENT.
C*                > 0, NSELCT LOWEST DIAGONAL ELEMENTS.
C*                < 0, FIRST ABS(NSELCT) UNIT VECTORS.
C*       SELTHR - W.P. REAL
C*                INITIAL VECTOR SELECTION THRESHOLD FOR NSELCT = 0
C*       ADIAG  - W.P. REAL (NLARGE)
C*                VECTOR OF DIAGONAL ELEMENTS OF MATRIX A.
C*
C*    ON EXIT -
C*       NBASIS - INTEGER
C*                NUMBER OF BASIS VECTORS CHOSEN.
C*       DLOW   - W.P. REAL (MAXBAS)
C*                MAXBAS LOWEST DIAGONAL VALUES IN ASCENDING ORDER.
C*       NLIST  - INTEGER (MAXBAS)
C*                LIST OF MAXBAS LOWEST DIAGONAL ELEMENTS
C*       IDLIST - INTEGER (NLARGE)
C*                LIST INDICATING WHICH UNIT BASIS VECTOR AN ELEMENT OF
C*                MATRIX  A  IS MAPPED ONTO (NBASIS NON-ZERO VALUES)
C*
      SUBROUTINE EDIBVC(LUEMSG,NLARGE,MAXBAS,IDHIRT,NSELCT,SELTHR,ADIAG
     *                 ,NBASIS,DLOW,NLIST,IDLIST)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION ADIAG(NLARGE),NLIST(MAXBAS),IDLIST(NLARGE),DLOW(MAXBAS)
C
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA CHECK/8HCHECK   /
C
  001 FORMAT(/1X,'THE MAXIMUM NO. OF BASIS VECTORS NEEDS TO BE RAISED',
     *        ' FROM',I4,' TO',I4/
     *      ' TO INCLUDE ALL VECTORS THAT HAVE DIAGONAL ELEMENTS WITHIN'
     *      ,1P,E10.2,' OF THE',I3,' LOWEST DIAGONAL ELEMENTS'/
     *       ' THE CALCULATION WILL PROCEED WITH THIS POTENTIALLY POOR'
     *      ,' INITIAL EXPANSION BASIS SPACE')
C>999 FORMAT(' THE FOLLOWING UNIT VECTORS WERE USED FOR THE FIRST GUESS'
C>   *      /(1X,30I4))
C
      NBASIS=MAXBAS
      IF(NBASIS.EQ.NLARGE) GO TO 240
C
C           FILL ARRAY DLOW(*) WITH THE MAXBAS LOWEST ELEMENTS OF ADIAG
C           FILL ARRAY NLIST(*) WITH THEIR INDICES.
C           MAXBAS - 1 IS THE MAXIMUM NUMBER OF ROOTS ALLOWED.
C
         MXBSM1=MAXBAS-1
         NC=1
         NLIST(1)=1
         DLOW(1) =ADIAG(1)
         DO 190 I=2,NLARGE
            AII=ADIAG(I)
            IF(AII.GE.DLOW(NC)) GO TO 150
C
C                 FIND INSERTION POINT
C
               DO 110 KLO=1,NC
                  IF(AII.LT.DLOW(KLO)) GO TO 120
  110          CONTINUE
  120          CONTINUE
C
C                 INSERT VALUE IN LIST
C
               KHI=MIN(NC,MXBSM1)
               IF(KLO.GT.KHI) GO TO 140
                  DO 130 KF=KLO,KHI
                     K=KHI+KLO-KF
                     DLOW(K+1)=DLOW(K)
                     NLIST(K+1)=NLIST(K)
  130             CONTINUE
  140          CONTINUE
               IF(NC.LT.MAXBAS)NC=NC+1
               DLOW(KLO)=AII
               NLIST(KLO)=I
               GO TO 190
C
C              APPEND VALUE TO LIST
C
  150       CONTINUE
            IF(NC.EQ.MAXBAS) GO TO 190
               NC=NC+1
               DLOW(NC)=AII
               NLIST(NC)=I
  190    CONTINUE
C
C         DETERMINE WHICH UNIT VECTORS TO INCLUDE IN THE INITIAL GUESS
C
         IF(NSELCT.NE.0) GO TO 230
C
C         ---BASED ON NEARNESS TO IDHIRT LOWEST DIAG. ELEMENT (NSELCT=0)
C
         AIITHR=DLOW(IDHIRT)+SELTHR
         DO 210 NBASIS=IDHIRT,MXBSM1
            IF(DLOW(NBASIS+1).GT.AIITHR) GO TO 260
  210    CONTINUE
         NEEDBS=0
         DO 220 I=1,NLARGE
            IF(ADIAG(I).LE.AIITHR) NEEDBS=NEEDBS+1
  220    CONTINUE
         IF(LUEMSG.GT.0  .AND.  EXETYP.NE.CHECK .AND. MASWRK)
     *           WRITE(LUEMSG,001) MAXBAS,NEEDBS,SELTHR,IDHIRT
         GO TO 260
C
  230    CONTINUE
C
C         --- BASED ON NSELCT LOWEST DIAGONAL ELEMENTS (NSELCT>0)
C
         NBASIS=MIN(MAXBAS, ABS(NSELCT))
         NBASIS = MAX(NBASIS,IDHIRT)
         IF(NSELCT.GT.0) GO TO 260
  240 CONTINUE
C
C         --- BASED ON FIRST ABS(NSELCT) DIAGONAL ELEMENTS (NSELCT<0)
C
         DO 250 I=1,NBASIS
            NLIST(I)=I
  250    CONTINUE
         GO TO 270
C
  260 CONTINUE
      CALL SORTIN(NLIST,NBASIS)
  270 CONTINUE
C>    IF (MASWRK) WRITE(6,999) (NLIST(I),I=1,NBASIS)
C
C         SET UP IDLIST TO TELL WHERE MATRIX ELEMENTS SHOULD GO
C
      DO 280 NI=1,NLARGE
         IDLIST(NI)=0
  280 CONTINUE
      DO 290 I=1,NBASIS
         IDLIST(NLIST(I))=I
  290 CONTINUE
      RETURN
      END
C*MODULE GUGDGA  *DECK EDITA3
      SUBROUTINE EDITA3(NFT16,NLARGE,NEMEMX,LNBTAB,MAXIVC,NBASIS,
     *                  NLIST,IDLIST,ADIAGS,INDX,XX1,IX,IXX,BTAB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION NLIST(NBASIS),IDLIST(NLARGE),ADIAGS(NLARGE),
     *          INDX(NLARGE),XX1(NEMEMX),IX(*),IXX(*),BTAB(LNBTAB)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ONE=1.0D+00)
C
C*  7 FEB 1984 - STE
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE)  DATE: APRIL 1983
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE GENERATES THE INITIAL TRANSFORMATION OF  A  TO
C*                             *       *                  *
C*       A SUBSPACE OF UNIT BASIS VECTORS FOR CASE 3 (GAMESS/GUGA FILE)
C*                                                 *
C*
C*    ON ENTRY -
C*       LUMATA - INTEGER (LOGICAL UNIT NO.)
C*                GAMESS/GUGA ENERGY MATRIX FILE
C*       MXROWS - INTEGER
C*                MAXIMUM NO. OF ROWS OF  A  THE BUFFER WILL HOLD.
C*       NLARGE - INTEGER
C*                DIMENSION OF THE INPUT MATRIX A.
C*       NEMEMX   - INTEGER
C*                W.P. WORDS IN BUFFER TO HOLD MATRIX  A
C*       LNBTAB - INTEGER
C*                WORDS NEEDED TO STORE MATRIX BTAB =NBASIS*(NBASIS+1)/2
C*       MAXIVC - INTEGER
C*                HIGHEST UNIT BASIS VECTOR
C*       NBASIS - INTEGER
C*                NUMBER OF UNIT BASIS VECTORS
C*       NLIST  - INTEGER (NBASIS)
C*                LIST OF UNIT BASIS VECTORS IN ASCENDING ORDER
C*       IDLIST - INTEGER (NLARGE)
C*                NON-ZERO VALUE GIVES CORRESPONDING BASIS VECTOR.
C*       ADIAGS - W.P. REAL (NLARGE)
C*                SHIFTED DIAGONAL ELEMENTS OF MATRIX A.
C*
C*    WORK AREAS (BUFFERS) -
C*       INDX - W.P. REAL (NEMEMX)
C*                BUFFER FOR INPUT MATRIX  A
C*
C*    ON EXIT -
C*       BTAB   - W.P. REAL (LNBTAB)
C*                SIMULARITY TRANSFORM OF A BY UNIT BASIS VECTORS.
C*
      CALL VCLR(BTAB,1,LNBTAB)
      IF (GOPARR) CALL DSCAL(NLARGE,ONE/NPROC,ADIAGS,1)
C
C        MOVE REQUIRED ELEMENTS OF ADIAGS TO BTAB
C
      II = 0
      DO 110 I=1,NBASIS
         II = II + I
         BTAB(II) = ADIAGS(NLIST(I))
  110 CONTINUE
      DPROC = NPROC
      IF (GOPARR) CALL DSCAL(NLARGE,DPROC,ADIAGS,1)
C
C           NOW GET OFF-DIAGONAL ELEMENTS
C
*I64  MASK32 = 2**32 - 1
      CALL SEQREW(NFT16)
      READ(NFT16)
C
  120 CONTINUE
         CALL PKREAD(NFT16,XX1,IX,IXX,MX,NEMEMX)
         NX = ABS(MX)
         IF(NX.EQ.0) GO TO 190
C
         DO 180 N=1,NX
            VAL = XX1(N)
C
            NPACK = N
*I32        IPACK = IX( 2*NPACK - 1 )
*I32        JPACK = IX( 2*NPACK     )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -32 )
*I64        JPACK = IAND( LABEL, MASK32 )
            IUWK = IPACK
            JUWK = JPACK
C
            IF(IUWK.EQ.0) THEN
               NUWK = INT(VAL)
               GO TO 180
            END IF
C
*I32        NLWK = IXX(N)
*I64        IF (MOD(N,2) .EQ. 0) THEN
*I64          LABEL = IXX( N/2 )
*I64          NLWK  = ISHFT( LABEL, -32 )
*I64        ELSE
*I64          LABEL = IXX( N/2+1 )
*I64          NLWK  = IAND( LABEL, MASK32 )
*I64        END IF
C
            DO 160 I = 1,NLWK
               II = INDX(IUWK)
               JJ = INDX(JUWK)
               DO 150 J = 1,NUWK
                  IF(II.GT.MAXIVC) GO TO 155
                  IF(JJ.GT.MAXIVC) GO TO 155
                     NI = IDLIST(II)
                     NJ = IDLIST(JJ)
                     IF(NI.EQ.0) GO TO 140
                     IF(NJ.EQ.0) GO TO 140
                        IF(II.GE.JJ) GO TO 135
                           NI = NJ
                           NJ = IDLIST(II)
  135                   CONTINUE
                        NIJ = (NI*NI-NI)/2 + NJ
                        BTAB(NIJ) = BTAB(NIJ) + VAL
  140                CONTINUE
                     II = II+1
                     JJ = JJ+1
  150          CONTINUE
  155          CONTINUE
               IUWK = IUWK+1
               JUWK = JUWK+1
  160       CONTINUE
  180    CONTINUE
      IF(MX.GT.0) GO TO 120
C
  190 CONTINUE
      IF (GOPARR) CALL DDI_GSUMF(1855,BTAB,LNBTAB)
      RETURN
      END
C*MODULE GUGDGA  *DECK EDIVC1
      SUBROUTINE EDIVC1(NLARGE,NBASIS,IDHIRT,LENA,NLIST,IDLIST,ADIAGS,
     *                  CVECT,AMATRX,AXB,BVECT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION AMATRX(LENA),AXB(NLARGE,IDHIRT),BVECT(NLARGE,IDHIRT),
     *          CVECT(NBASIS,IDHIRT),ADIAGS(NLARGE),NLIST(NBASIS),
     *          IDLIST(NLARGE)
C
C* 20 APR 1983 - STE
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE)  DATE: 19 APR 1983
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE GENERATES THE INITAL VECTORS  BVECT  AND  AXB  FROM
C*                             *      * *
C*       THE UNIT BASIS VECTORS FOR CASE 1 (A IS MEMORY RESIDENT)
C*                                       *
C*
C*    ON ENTRY -
C*       NLARGE - INTEGER
C*                DIMENSION OF THE INPUT MATRIX A.
C*       NBASIS - INTEGER
C*                NUMBER OF UNIT BASIS VECTORS.
C*       IDHIRT - INTEGER
C*                NO. OF HIGHEST ROOT BEING SOUGHT.
C*       LENA   - INTEGER
C*                WORDS NEEDED TO STORE MATRIX A = NLARGE*(NLARGE+1)/2
C*       NLIST  - INTEGER (NBASIS)
C*                LIST OF UNIT BASIS VECTORS IN ASCENDING ORDER.
C*       IDLIST - INTEGER (NLARGE)
C*                MAPS MATRIX  A  VECTORS ONTO UNIT EXPANSION VECTORS
C*       ADIAGS - W.P. REAL (NLARGE)
C*                SHIFTED DIAGONAL ELEMENTS OF MATRIX  A
C*       CVECT  - W.P. REAL (NBASIS,IDHIRT)
C*                CONTRACTION VECTORS (EIGENVECTORS OF B(TRANSPOSE)*A*B)
C*       AMATRX - W.P. REAL (LENA)
C*                INPUT MATRIX A
C*
C*    ON EXIT -
C*       AXB    - W.P. REAL (NLARGE,NBASIS)
C*                PRODUCT OF MATRIX A AND THE UNIT BASIS VECTORS.
C*       BVECT  - W.P. REAL (NLARGE,IDHIRT)
C*                INITIAL EXPANSION BASIS VECTORS
C*                (APPROXIMATE EIGENVECTORS OF  A)
C*
C
      CALL VCLR(AXB,1,NLARGE*IDHIRT)
C
C        MOVE REQUIRED ELEMENTS OF A TO AXB (A(I,I) FROM ADIAGS)
C
      NII=0
      DO 190 NI=1,NLARGE
         NIM1=NI-1
         NIJ=NII
         NII=NII+NI
         I=IDLIST(NI)
         IF(I.NE.0) GO TO 130
C
C        --- I NOT OK ---
C
         DO 120 NJ=1,NIM1
            NIJ=NIJ+1
            J=IDLIST(NJ)
            IF(J.EQ.0) GO TO 120
C
C              --- ONLY J IS ON LIST ---
C
               AXBNIJ=AMATRX(NIJ)
               DO 110 IROOT=1,IDHIRT
                  AXB(NI,IROOT)=AXB(NI,IROOT) + AXBNIJ*CVECT(J,IROOT)
  110          CONTINUE
C
  120    CONTINUE
         GO TO 190
C
C           --- I IS ON LIST ---
C
  130    CONTINUE
         DO 170 NJ=1,NIM1
            NIJ=NIJ+1
            J=IDLIST(NJ)
            IF(J.NE.0) GO TO 150
C
C              --- ONLY I IS ON LIST
C
               AXBNJI=AMATRX(NIJ)
               DO 140 IROOT=1,IDHIRT
                  AXB(NJ,IROOT)=AXB(NJ,IROOT) + AXBNJI*CVECT(I,IROOT)
  140          CONTINUE
               GO TO 170
C
  150       CONTINUE
C
C           --- I AND J BOTH ON LIST
C
            AXBIJ=AMATRX(NIJ)
            DO 160 IROOT=1,IDHIRT
               AXB(NI,IROOT)=AXB(NI,IROOT) + AXBIJ*CVECT(J,IROOT)
  160       CONTINUE
            DO 165 IROOT=1,IDHIRT
               AXB(NJ,IROOT)=AXB(NJ,IROOT) + AXBIJ*CVECT(I,IROOT)
  165       CONTINUE
  170    CONTINUE
C
C           NI = NJ (A DIAGONAL ELEMENT)
C
         AXBNII=ADIAGS(NI)
         DO 180 IROOT=1,IDHIRT
            AXB(NI,IROOT)=AXB(NI,IROOT) + AXBNII*CVECT(I,IROOT)
  180    CONTINUE
  190 CONTINUE
C
C        CREATE INITIAL EXPANSION VECTOR(S)
C
      CALL VCLR(BVECT,1,NLARGE*IDHIRT)
      DO 220 J=1,IDHIRT
         DO 210 K=1,NBASIS
            BVECT(NLIST(K),J)=CVECT(K,J)
  210    CONTINUE
  220 CONTINUE
      RETURN
      END
C*MODULE GUGDGA  *DECK EDIVC3
      SUBROUTINE EDIVC3(NFT16,NLARGE,NEMEMX,NCVECT,NBASIS,NLIST,IDLIST,
     *                  ADIAGS,CVECT,INDX,XX1,IX,IXX,AXB,BVECT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION NLIST(NBASIS),IDLIST(NLARGE),ADIAGS(NLARGE),
     *          CVECT(NBASIS,NCVECT),INDX(NLARGE),
     *          XX1(NEMEMX),IX(NEMEMX),IXX(*),
     *          AXB(NLARGE,NCVECT),BVECT(NLARGE,NCVECT)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ONE=1.0D+00)
C
C*  7 FEB 1984 - STE
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE)  DATE: APRIL 1983
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE GENERATES THE INITAL VECTORS  BVECT  AND  AXB  FROM
C*                             *      * *
C*       THE UNIT BASIS VECTORS FOR CASE 3 (GAMESS/GUGA FILE)
C*                                       *
C*
C*    ON ENTRY -
C*       NFT16  - INTEGER (LOGICAL UNIT NO.)
C*                GAMESS/GUGA ENERGY MATRIX FILE
C*       MXROWS - INTEGER
C*                MAXIMUM NO. OF ROWS OF  A  THE BUFFER WILL HOLD.
C*       NLARGE - INTEGER
C*                DIMENSION OF THE INPUT MATRIX A.
C*       NCVECT - INTEGER
C*       MAXIVC - INTEGER
C*                HIGHEST UNIT BASIS VECTOR
C*       NBASIS - INTEGER
C*                NUMBER OF UNIT BASIS VECTORS
C*       NLIST  - INTEGER (NBASIS)
C*                LIST OF UNIT BASIS VECTORS IN ASCENDING ORDER
C*       IDLIST - INTEGER (NLARGE)
C*                NON-ZERO VALUE GIVES CORRESPONDING BASIS VECTOR.
C*       ADIAGS - W.P. REAL (NLARGE)
C*                SHIFTED DIAGONAL ELEMENTS OF MATRIX A.
C*
C*    ON EXIT -
C*       AXB   - W.P. REAL (NLARGE,NCVECT)
C*                SIMULARITY TRANSFORM OF A BY UNIT BASIS VECTORS.
C*
      CALL VCLR(AXB,1,NLARGE*NCVECT)
      IF (GOPARR) CALL DSCAL(NLARGE,ONE/NPROC,ADIAGS,1)
C
C        MOVE REQUIRED ELEMENTS OF ADIAGS TO AXB
C
      DO 115 I=1,NBASIS
         NI=NLIST(I)
         AII=ADIAGS(NI)
         DO 110 J=1,NCVECT
            AXB(NI,J) = AII*CVECT(I,J)
  110    CONTINUE
  115 CONTINUE
      DPROC = NPROC
      IF (GOPARR) CALL DSCAL(NLARGE,DPROC,ADIAGS,1)
C
C           NOW GET OFF-DIAGONAL ELEMENTS
C
      NUWK = 0
      MX = 0
*I64  MASK32 = 2**32 - 1
      CALL SEQREW(NFT16)
      READ(NFT16)
  120 CONTINUE
C
C              PROCESS ONE BLOCK OF THE HAMILTONIAN
C
         CALL PKREAD(NFT16,XX1,IX,IXX,MX,NEMEMX)
         NX = ABS(MX)
         IF(NX.EQ.0) GO TO 190
C
         DO 180 N=1,NX
             VAL = XX1(N)
C
            NPACK = N
*I32        IPACK = IX( 2*NPACK - 1 )
*I32        JPACK = IX( 2*NPACK     )
*I64        LABEL = IX(NPACK)
*I64        IPACK = ISHFT( LABEL, -32 )
*I64        JPACK = IAND( LABEL, MASK32 )
            IUWK = IPACK
            JUWK = JPACK
C
            IF(IUWK.EQ.0) THEN
               NUWK = INT(VAL)
               GO TO 180
            END IF
C
*I32        NLWK = IXX(N)
*I64        IF (MOD(N,2) .EQ. 0) THEN
*I64          LABEL = IXX( N/2 )
*I64          NLWK  = ISHFT( LABEL, -32 )
*I64        ELSE
*I64          LABEL = IXX( N/2+1 )
*I64          NLWK  = IAND( LABEL, MASK32 )
*I64        END IF
C
            DO 160 I = 1,NLWK
               II = INDX(IUWK)
               JJ = INDX(JUWK)
               DO 150 J = 1,NUWK
                  NI = IDLIST(II)
                  NJ = IDLIST(JJ)
                  IF(NI.NE.0) GO TO 140
                     IF(NJ.EQ.0) GO TO 149
C
C                       --- ONLY J IS ON LIST ---
C
                        DO 136 IROOT=1,NCVECT
                     AXB(II,IROOT) = AXB(II,IROOT) + VAL*CVECT(NJ,IROOT)
  136                   CONTINUE
                        GO TO 149
C
  140             CONTINUE
                  IF(NJ.NE.0) GO TO 146
C
C                       --- ONLY I IS ON LIST ---
C
                     DO 142 IROOT=1,NCVECT
                     AXB(JJ,IROOT) = AXB(JJ,IROOT) + VAL*CVECT(NI,IROOT)
  142                CONTINUE
                     GO TO 149
C
  146             CONTINUE
C
C                       --- BOTH I AND J ARE ON LIST ---
C
                  DO 147 IROOT=1,NCVECT
                     AXB(II,IROOT) = AXB(II,IROOT) + VAL*CVECT(NJ,IROOT)
  147             CONTINUE
                  DO 148 IROOT=1,NCVECT
                     AXB(JJ,IROOT) = AXB(JJ,IROOT) + VAL*CVECT(NI,IROOT)
  148             CONTINUE
C
  149             CONTINUE
                  II = II+1
                  JJ = JJ+1
  150          CONTINUE
               IUWK = IUWK+1
               JUWK = JUWK+1
  160       CONTINUE
  180    CONTINUE
      IF (MX .GT. 0) GO TO 120
  190 CONTINUE
C
      IF (GOPARR) CALL DDI_GSUMF(1860,AXB,NLARGE*NCVECT)
C
C              CREATE INITIAL EXPANSION BASIS VECTOR(S)
C
      CALL VCLR(BVECT,1,NLARGE*NCVECT)
      DO 220 J=1,NCVECT
         DO 210 K=1,NBASIS
            BVECT(NLIST(K),J)=CVECT(K,J)
  210    CONTINUE
  220 CONTINUE
      RETURN
      END
C*MODULE GUGDGA  *DECK EDIVCD
      SUBROUTINE EDIVCD(LUPRNT,IDHIRT,NLARGE,LENA,NEXTRA,KPRINT,
     *                  CVGETH,ESHIFT,AMATRX,EIGVAL,EIGVEC,NEMEMX,
     *                  ITERMX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION AMATRX(LENA),EIGVAL(NLARGE),EIGVEC(NLARGE,IDHIRT)
      DIMENSION IX(1)
C
      LOGICAL PRINT3,GOPARR,DSKWRK,MASWRK
C
      COMMON /FMCOM / X(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      EQUIVALENCE (X(1),IX(1))
C
      DATA CHECK/8HCHECK   /
C
  004 FORMAT(1X,I3,I4,'(MAX.TOL.STATE)',5(F17.9,I3)/(23X,5(F17.9,I3)))
C
C*  7 FEB 88 - STE *
C*
C*    AUTHOR: S. T. ELBERT (AMES LABORATORY - USDOE)  DATE:  7 MAY 1984
C*
C*    PURPOSE -
C*       WHEN FINDING EIGENVECTOR(S) USING THE DAVIDSON METHOD, THIS
C*                    *                        *
C*       ROUTINE GENERATES THE INITAL CONTRACTION VECTORS  EIGVEC
C*                             *                  * *
C*       USING THE DAVIDSON METHOD
C*                 *
C*
C*    ON ENTRY -
C*       LUEMSG - INTEGER (LOGICAL UNIT NO.)
C*                LOGICAL UNIT FOR ERROR MESSAGES (SUPRESS IF ZERO)
C*       IDHIRT - INTEGER
C*                NO. OF HIGHEST ROOT TO BE OBTAINED (HIGHEST IS NLARGE)
C*       NLARGE - INTEGER
C*                DIMENSION OF REAL SYMMETRIC INPUT MATRIX  A.
C*       LENA   - INTEGER
C*                LINEAR DIMENSION OF ARRAY AMATRX
C*       NEXTRA - INTEGER
C*                THIS MANY EXTRA EXPANSION BASIS VECTORS WILL BE
C*                USED ON THE FIRST ITERATION.  THE NUMBER OF EXTRA
C*                VECTORS IS DECREASED BY ONE EACH ITERATION UNTIL
C*                NO EXTRA VECTORS ARE PRESENT.  THIS IS USEFUL IN
C*                "CAPTURING" VECTORS FOR HIGHER ROOTS.
C*       KPRINT - INTEGER
C*                PRINTED OUTPUT CONTROL MASK (NO PRINTING IF ZERO)
C*                BIT  0  FINAL EIGENVALUES
C*                BIT  1  FINAL TOLERANCES
C*                BIT  2  EIGENVALUES AND TOLERANCES AT EACH TRUNCATION
C*                BIT  3  EIGENVALUES EVERY ITERATION
C*                BIT  4  TOLERANCES EVERY ITERATION
C*                E.G., KPRINT=10 PRINTS EIGENVALUES EVERY ITERATION
C*                AND FINAL TOLERANCES.
C*       CVGETH - W.P. REAL
C*                RELATIVE EIGENVALUE CONVERGENCE THRESHOLD
C*                (VECTOR ACCURACY IS SQUARE ROOT OF THIS VALUE)
C*       ESHIFT - W.P. REAL
C*                AMOUNT DIAGONAL ELEMENTS HAVE BEEN SHIFTED BY.
C*                (MUST BE ADDED TO EIGVAL TO OBTAIN TRUE EIGENVALUES)
C*       AMATRX - W.P. REAL (LENA)
C*                MEMORY RESIDENT MATRIX WHOSE EIGENVECTORS ARE SOUGHT
C*                (STORED IN SYMMETRIC STORAGE MODE)
C*
C*    ON EXIT -
C*       EIGVAL - W.P. REAL (NLARGE)
C*                THE IDHIRT LOWEST EIGENVALUES OF  AMATRX
C*       EIGVEC - W.P. REAL (NLARGE,IDHIRT)
C*                THE VECTORS CORRESPONDING TO THE IDHIRT LOWEST
C*                EIGENVALUES OF  AMATRX
C*
C*    WORK AREAS - (EXTRACTED FROM DYNAMIC MEMORY)
C*       BTAB   - W.P. REAL (LNGUES,2)
C*       WRK    - W.P. REAL (MXGUES,8)
C*       IWRK   - INTEGER   (MAX(NLARGE,MXGUES))
C*       CVECT  - W.P. REAL (MXGUES,IDHIRT,2)
C*       ADIAG  - W.P. REAL (NLARGE)
C*       AXB    - W.P. REAL (NLARGE,MXGUES)
C*       BVECT  - W.P. REAL (NLARGE,MXGUES)
C*       MCONV  - INTEGER   (IDHIRT)
C*       MPRV   - INTEGER   (IDHIRT)
C*
      LUEMSG = IABS(LUPRNT)
      PRINT3 = LUPRNT.GT.0 .AND. LOGAND(KPRINT,2**3).NE.0
     *          .AND. MASWRK
      MXITER=ITERMX
      IGUESS = IDHIRT + NEXTRA
      MXGUES = MIN(50,NLARGE)
      MXGUES = MAX(MXGUES,IGUESS)
      LNGUES = (MXGUES*MXGUES+MXGUES)/2
C
      CALL VALFM(LOADFM)
      LBTAB = LOADFM + 1
      LXX1  = LBTAB  + LNGUES*2
      LXX2  = LXX1   + NEMEMX
      LIXX  = LXX2   + NEMEMX
      LWRK  = LIXX   + (NEMEMX-1)/NWDVAR + 1
      LIWRK = LWRK   + MXGUES*8
      LCVECT= LIWRK  + (NLARGE-1)/NWDVAR+1
      LADIAG= LCVECT + MXGUES*IGUESS*2
      LAXB  = LADIAG + NLARGE
      LBVECT= LAXB   + NLARGE*MXGUES
      LMCONV= LBVECT + NLARGE*MXGUES
      LMPRV = LMCONV + (IGUESS-1)/NWDVAR+1
      LAST  = LMPRV  + (IGUESS-1)/NWDVAR+1
      NEED  = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF (EXETYP .EQ. CHECK) GO TO 200
C
C           GET DIAGONAL ELEMENTS OF A
C
      LDIAG0=LADIAG-1
      II=0
      DO 110 I=1,NLARGE
         II=II+I
         X(LDIAG0+I) = AMATRX(II)
  110 CONTINUE
C
C           FORM INITIAL BTAB ARRAY
C
      CALL DCOPY(LNGUES,AMATRX,1,X(LBTAB),1)
C
C           GET IGUESS CONTRACTION VECTORS FROM EXPANSION BASIS SPACE
C
      IERR = 0
      CALL GLDIAG(MXGUES,IGUESS,MXGUES,X(LBTAB),X(LWRK),EIGVAL,X(LCVECT)
     *           ,IERR,X(LIWRK))
      IF(IERR.NE.0)THEN
         IF (MASWRK) WRITE(IW,*)' DIAGONALIZATION FAILED IN EDIVCD'
         CALL ABRT
      END IF
      IF (PRINT3) THEN
         ITER = 0
         WRITE(LUEMSG,004) ITER,MXGUES,(EIGVAL(K)+ESHIFT,K,K=1,IDHIRT)
      END IF
C
C           FORM  IGUESS  INITIAL  B  AND  A * B  VECTORS
C
      IIWRK = (LIWRK-1)*NWDVAR+1
      IWRK=IIWRK-1
      DO 120 I=1,NLARGE
         IX(IWRK+I)=0
         IF(I.LE.MXGUES) IX(IWRK+I)=I
  120 CONTINUE
      CALL EDIVC1(NLARGE,MXGUES,IGUESS,LENA,X(LIWRK),X(LIWRK),X(LADIAG),
     *            X(LCVECT),AMATRX,X(LAXB),X(LBVECT))
C
C           TRANSFORM  A  TO INITIAL EXPANSION BASIS SPACE
C
      IJBTAB=0
      CALL FRTRBT(0,NLARGE,1,IGUESS,LNGUES,X(LBVECT),X(LAXB),
     *            IJBTAB,X(LBTAB))
C
C           RESET CONTRACTION VECTORS TO UNIT VECTORS
C
      CALL RUNITV(IGUESS,IGUESS,X(LCVECT))
C
C           NOW USE DAVIDSON METHOD
C
      CALL EDAVID(LUPRNT,0,0,NLARGE,1,IDHIRT,MXGUES,IDHIRT,
     *            NEXTRA,MXITER,KPRINT,LENA,LNGUES,
     *            IGUESS,IGUESS,CVGETH,1,ESHIFT,X(LADIAG),
     *            EIGVAL,EIGVEC,X(LBVECT),X(LAXB),AMATRX,X(LBTAB),
     *            X(LCVECT),X(LWRK),X(LIWRK),X(LMCONV),X(LMPRV),
     *            X(LXX1),X(LXX2),X(LIXX),NEMEMX,X(LWRK))
  200 CONTINUE
      CALL RETFM(NEED)
      IF(MXITER.LT.0)THEN
         IF(MASWRK) WRITE(IW,*)' MXITER.LT.0 AT END OF EDIVCD'
         CALL ABRT
      END IF
      RETURN
      END
C*MODULE GUGDGA  *DECK ERASCI
      SUBROUTINE ERASCI
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK,DSKSAV
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C        OVERWRITE CI EIGENVECTOR FILE 12, TO FORCE A FRESH
C        START AT THE SECULAR PROBLEM.  THIS FILE IS DUPLICATED
C        ACROSS ALL NODES, SO ERASE IT EVERYWHERE.
C
      DSKSAV = DSKWRK
      DSKWRK = .TRUE.
      CALL SEQREW(NFT12)
      WRITE(NFT12) 0,0
      CALL SEQREW(NFT12)
      DSKWRK=DSKSAV
      RETURN
      END
C*MODULE GUGDGA  *DECK GUGADG
      SUBROUTINE GUGADG(NPRINT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL SOME,OUT,GOPARR,DSKWRK,MASWRK,CLOBBR,FOCAS,SOSCF,DROPC,
     *        FIRST
C
      PARAMETER (MXATM=2000, MXRT=100, MXAO=8192)
      PARAMETER (NNAM=17)
      PARAMETER (TWO=2.0D+00)
C
      DIMENSION TTL15A(10),TTL15B(10),TTL16A(10),TTL16B(10)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / X(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /GUGWFN/ NFZC,NMCC,NDOC,NAOS,NBOS,NALP,NVAL,NEXT,NFZV,
     *                IFORS,IEXCIT,ICICI,NOIRR
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NNA,NNB,NNC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),JCODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),
     *                IOUT(MXAO),
     *                NREFS,IEXCT,NFOCI,INTACT
      COMMON /TRNMOM/ OPERR,SYMTOL,NOCC,NUMCI,MFZC,NUMVEC,ICI,MXRR,MSTAT
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (TENPM5=1.0D-05, TENPM2=1.0D-02,
     *           ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00)
C
      DATA CHECK/8HCHECK   /, DEBUG/8HDEBUG   /, DBUGME/8HGUGADG  /
      DATA TRANST/8HTRANSITN/
C
C     ----- SET UP NAMELIST SIMULATION -----
C
      DATA GUGDIA/8HGUGDIA  /
      DATA QNAM/8HNWORD   ,8HNSTATE  ,8HMXXPAN  ,8HITERMX  ,
     *          8HCVGTOL  ,8HPRTTOL  ,8HKPRINT  ,8HNSELCT  ,
     *          8HSELTHR  ,8HNEXTRA  ,8HNIMPRV  ,8HMEMMAX  ,
     *          8HNREF    ,8HEREF    ,8HCLOBBR  ,8HMAXHAM  ,
     *          8HMAXDIA  /
      DATA KQNAM/1,1,1,1,3,3,1,1,3,1,1,1,1,3,0,1,1/
C
      DATA RNONE/8HNONE    /
      DATA FIRST/.TRUE./
      SAVE FIRST
C
      SOME = NPRINT .NE. -5 .AND. MASWRK
      OUT = NPRINT .GT. 0 .AND. MASWRK
      IF (EXETYP .EQ. DEBUG  .OR. EXETYP .EQ. DBUGME) THEN
         SOME = .TRUE. .AND. MASWRK
         OUT  = .TRUE. .AND. MASWRK
      END IF
      IF (SOME) WRITE (IW,9008)
      ISET1 = 0
      ISET2 = 0
      NWKS = 0
      NSTAT  = INT(STATN)
C
C     ----- READ NAMELIST - $GUGDIA - -----
C
      NWORD  = 0
      NSTATE = 1
      MXXPAN = 30
      ITERMX = 50
      CVGTOL = TENPM5
      CALL DERCHK(NDER)
      IF(NDER.GT.0)      CVGTOL=1.0D-06
      IF(MPLEVL.GT.0)    CVGTOL=1.0D-06
      IF(CITYP.NE.RNONE) CVGTOL=1.0D-06
      IF(NFG.NE.0)       CVGTOL=1.0D-06
      PRTTOL = 0.05D+00
      KPRINT = 8
      NSELCT = 0
      SELTHR = TENPM2
      NEXTRA = 5
      NIMPRV = 0
C        MEMMAX IS A COMPOSITE VALUE MODULO 1000
C     MEMMAX = 50100
C     MEMMAX = 400800
C     MEMMAX IS RECOGNISED BUT IGNORED
      MAXDIA = 100
C     MAXHAM = 0
C     NBIT=64/NWDVAR-2
C     MMM=(2**NBIT-1)*2+1
      CALL GOTFM(MMM)
      MAXHAM=INT(SQRT(TWO*MMM))
      NREF = 1
      EREF = ZERO
      CLOBBR=.FALSE.
C
      JRET = 0
      CALL NAMEIO(IR,JRET,GUGDIA,NNAM,QNAM,KQNAM,
     *            NWORD,NSTATE,MXXPAN,ITERMX,CVGTOL,PRTTOL,KPRINT,
     *            NSELCT,SELTHR,NEXTRA,NIMPRV,MEMMAX,NREF,EREF,
     *            CLOBBR,MAXHAM,MAXDIA,
     *            0,0,   0,0,0,0,0,
     *   0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *   0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0)
      IF (JRET.GT.1) THEN
         IF(MASWRK) WRITE (IW,0028)
         CALL ABRT
      END IF
C
      IF(.NOT.FIRST) NEXTRA=0
      FIRST=.FALSE.
      IF(RUNTYP.EQ.TRANST) THEN
C        NSTATE=MAX(NSTATE,MSTAT)
         NSTATE=MSTAT
         IF(NFZC+NMCC+NDOC+NAOS+NBOS+NALP.GT.NOCC) THEN
            WRITE(IW,9300)
            CALL ABRT
         ENDIF
      ENDIF
C
      IF (NIMPRV .EQ. 0) NIMPRV = NSTATE
      IF (MXXPAN .LE. 2*NSTATE) MXXPAN = 2*NSTATE+1
      NBASIS=MAXDIA
C     MEMMAX=MAXHAM
      IF (SOME) WRITE (IW,9208) NSTATE,MXXPAN,NIMPRV,ITERMX,CVGTOL
      NSTAT = NSTATE
      STATN = NSTATE
C
      CALL SEQREW(NFT15)
      CALL SEQREW(NFT16)
      READ (NFT15) ISET1,NWKS,NEMEMX,CUTOFF,TTL15A,TTL15B
      READ (NFT16) ISET2,NWKS,NEMEMX,CUTOFF,TTL16A,TTL16B
C
      IF (ISET1 .NE. 1 .OR. ISET2 .NE. 2) GO TO 200
      DO 140 I = 1,10
         IF (TTL15A(I) .NE. TTL16A(I)) GO TO 200
         IF (TTL15B(I) .NE. TTL16B(I)) GO TO 200
  140 CONTINUE
      IF (OUT) WRITE (IW,0048) TTL16A,TTL16B,NWKS,CUTOFF
C
C        UNDOCUMENTED OPTION TO ALWAYS START FRESH CI CALCULATION
C        BY OVERWRITING THE PREVIOUS ITERATION'S RESULTS
C
      IF(CLOBBR) CALL ERASCI
C
C     ----- FIND ROOTS OF CI-MATRIX -----
C
      IF (OUT) WRITE (IW,9128)
      LENBAB = (MXXPAN*MXXPAN+MXXPAN)/2
      LUVECS = -NFT12
      IWX = IW
      IF(.NOT.SOME) IWX = -IWX
      MXMPRV = MAX(NSTATE,NIMPRV+NEXTRA)
      MXGUES = MAX(MXXPAN,ABS(NSELCT))
      LNGUES = (MXGUES*MXGUES+MXGUES)/2
      ECVGTL=CVGTOL*CVGTOL
C
C     ----- GET FAST MEMORY -----
C
      LENA = 2*LNGUES
C
      CALL GOTFM(NGOTMX)
      NGOT = NGOTMX
      IF(NWORD.GT.0) NGOT=MIN(NWORD,NGOTMX)
C
      CALL VALFM(LOADFM)
      LAMAT  = LOADFM + 1
      LXX1   = LAMAT  + LENA
      LXX2   = LXX1   + NEMEMX
      LIXX   = LXX2   + NEMEMX
      INDX   = LIXX   + NEMEMX
      LADIAG = INDX   + (NWKS-1)/NWDVAR + 1
      LAST   = LADIAG + NWKS
      IMIN = 0
C
C              OBTAIN SOME GUGA PARAMS FOR MEMORY ALLOCATION
C
      CALL SEQREW(NFT11)
      CALL RDDRT(NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,
     *           NREFS,IEXCT,NFOCI,INTACT,NCORBS)
      CALL SEQREW(NFT11)
C
C              SOLVE PROBLEM USING A MEMORY RESIDENT MATRIX METHOD
C
      IF (MAXHAM.NE.0.AND.NWKS.GT.MAXHAM) GO TO 150
C     FIRST, ATTEMPT TO PUT THE MATRIX INTO MEMORY
         LATEST = LAST
         LENWOM = LENBAB
         MAX6666= MXXPAN
         LENBAB = (NWKS*NWKS+NWKS)/2
         LEVAL  = LAST
         LEVEC  = LEVAL  + NWKS
         LBTAB  = LEVEC  + NWKS*NSTATE
         LWRK   = LBTAB  + LENBAB
         IWRK   = LWRK   + NWKS*8
         NLIST  = IWRK   + (NWKS-1)/NWDVAR + 1
         IDLIST = NLIST  + (NWKS-1)/NWDVAR + 1
         LASTD  = IDLIST + (NWKS-1)/NWDVAR + 1
C                        OVERLAP THE MEMORY FOR FINAL PRINTOUT
         LLEVIR = LBTAB
         LICASE = LLEVIR + NORBMX + 1
         LIECON = LICASE + NORBMX
         LIARC  = LIECON + NORBMX
         LASTP  = LIARC + 4*NROWS
C
         IF (NWKS.LE.NBASIS) MXXPAN = 0
C
         LAXB = MAX(LASTD,LASTP)
         LBVECT = LAXB   + NWKS*MXXPAN
         LAST   = LBVECT + NWKS*MXXPAN + MXXPAN*NSTATE*2
C
         NEED = LAST - LOADFM - 1
         IF(SOME) WRITE(IW,9184) NGOT,NEED,NEMEMX
         IF(NGOT.LT.NEED) THEN
            LAST=LATEST
            LENBAB=LENWOM
            MXXPAN=MAX6666
            GOTO 150
         ENDIF
         CALL GETFM(NEED)
C
         SELTHR = ZERO
         IF(EXETYP.EQ.CHECK) THEN
            CALL VCLR(X(LEVEC),1,NSTATE*NWKS)
            CALL VCLR(X(LEVAL),1,NSTATE)
         ELSE
            CALL EDGUES(IWX,NFT15,NFT16,LUVECS,NWKS,1,NSTATE,NWKS,
     *               MAX(NSTATE,MXXPAN),KPRINT,LENA,NEMEMX,LENBAB,NWKS,
     *               SELTHR,ECVGTL,NEXTRA,NBASIS,IMIN,ESCF,X(LADIAG),
     *               X(LEVAL),X(LBVECT),X(LAXB),X(LBTAB),X(LEVEC),
     *               X(LWRK),X(IWRK),X(NLIST),X(IDLIST),X(LAMAT),
     *               X(LXX1),X(LXX2),X(LIXX),X(INDX),ITERMX)
         END IF
         GO TO 170
C
C              SOLVE PROBLEM USING DAVIDSON'S METHOD
C                 MATRIX IS NOT IN MEMORY
C
  150 CONTINUE
      LEVAL  = LAST
      LBTAB  = LEVAL  + MXGUES
      LCVECT = LBTAB  + 2*LENBAB
      LWRK   = LCVECT + MXMPRV*(2*MXXPAN-1)
      IWRK   = LWRK   + MXXPAN*8
      MPRVME = IWRK   + (MXXPAN-1)/NWDVAR + 1
      IMCONV = MPRVME + (NIMPRV+NEXTRA-1)/NWDVAR + 1
      LASTE  = IMCONV + (MXMPRV-1)/NWDVAR
C
      KCVECT = LBTAB  + LNGUES
      KWRK   = KCVECT + MXGUES*MXMPRV
      KIWRK  = KWRK   + MXGUES*8
      NLIST  = KIWRK  + (MXGUES-1)/NWDVAR + 1
      IDLIST = NLIST  + (MXGUES-1)/NWDVAR + 1
      LASTI  = IDLIST + (NWKS-1)/NWDVAR + 1
C                        OVERLAP THE MEMORY FOR FINAL PRINTOUT
      LLEVIR = LBTAB
      LICASE = LLEVIR + NORBMX + 1
      LIECON = LICASE + NORBMX
      LIARC  = LIECON + NORBMX
      LASTP  = LIARC + 4*NROWS
C
      LAXB   = MAX(LASTI,LASTE,LASTP) + 1
      LBVECT = LAXB   + NWKS*MXXPAN
      LEVEC  = LBVECT + NWKS*MXXPAN
      LAST   = LEVEC  + NWKS*MXMPRV
      NEED = LAST - LOADFM - 1
C
C         ALLOCATE LESS STORAGE IF ALL VECTORS DO NOT FIT IN MEMORY
C
      IF(NEED.GT.NGOT) THEN
         NEEDI = NEED
         LUVECS = NFT12
         LBVECT = LAXB
         LEVEC  = LBVECT + NWKS*MXMPRV
         LAST   = LEVEC  + NWKS*MXMPRV
         NEED = LAST - LOADFM - 1
         LUAXB= LUVECS + 3
         IF(SOME) WRITE(IW,9186) NEEDI,LUVECS,LUAXB
      ELSE
         IF(SOME) WRITE(IW,9185)
      END IF
C
C              GENERATE GUESS VECTORS
C
      IF (SOME) WRITE (IW,9188) NGOT,NEED,NEMEMX
      CALL GETFM(NEED)
      CALL EDGUES(IWX,NFT15,NFT16,LUVECS,NWKS,1,NSTATE,MXGUES,MXMPRV,
     *            KPRINT,LENA,NEMEMX,LNGUES,NSELCT,SELTHR,ECVGTL,
     *            NEXTRA,NBASIS,IMIN,ESCF,X(LADIAG),X(LEVAL),X(LEVEC),
     *            X(LAXB),X(LBTAB),X(KCVECT),X(KWRK),X(KIWRK),X(NLIST),
     *            X(IDLIST),X(LAMAT),X(LXX1),X(LXX2),X(LIXX),X(INDX),
     *            ITERMX)
C
      IF (NWKS .EQ. NBASIS) THEN
         LEVEC = KCVECT
         GO TO 170
      END IF
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LEVEC),1,NWKS*NSTATE)
         CALL VCLR(X(LEVAL),1,NSTATE)
         GO TO 170
      END IF
      CALL DCOPY(NBASIS**2,X(KCVECT),1,X(LCVECT),1)
      IF(LUVECS.LT.0) CALL DCOPY(NWKS*NBASIS,X(LEVEC),1,X(LBVECT),1)
C
C           ITERATE WITH DAVIDSON'S METHOD
C
      CALL EDAVID(IWX,NFT16,LUVECS,NWKS,1,NSTATE,MXXPAN,NIMPRV,NEXTRA,
     *            ITERMX,KPRINT,NEMEMX,LENBAB,MXMPRV,NBASIS,
     *            ECVGTL,3,ESCF,X(LADIAG),X(LEVAL),X(LEVEC),
     *            X(LBVECT),X(LAXB),X(LAMAT),X(LBTAB),
     *            X(LCVECT),X(LWRK),X(IWRK),X(IMCONV),X(MPRVME),
     *            X(LXX1),X(LXX2),X(LIXX),NEMEMX,X(INDX))
C
C     ----- VECTORS FOUND, PRINT MAJOR CSF-S -----
C
  170 CONTINUE
      CALL STFASE(X(LEVEC),NWKS,NWKS,NSTATE)
      IF((NPRINT.NE.-5.OR.RUNTYP.EQ.TRANST) .AND. EXETYP.NE.CHECK) THEN
         CALL SEQREW(NFT11)
         CALL RDDRT(NORBMX,NORBS,NSYM,NROWS,NWKS,LEVFRM,NEMEMX,
     *              NREFS,IEXCT,NFOCI,INTACT,NCORBS)
         IF(ICICI.EQ.0  .AND.  DROPC) NORBS = NORBS+NCORBS
         CALL PRCIVC(NFT11,NSTATE,NWKS,X(LEVAL),X(LEVEC),PRTTOL,
     *               X(LLEVIR),X(LICASE),X(LIECON),X(LIARC),
     *               NORBMX,4*NROWS,NROWS)
         IF(ICICI.EQ.0  .AND.  DROPC) NORBS = NORBS-NCORBS
      END IF
C
C     ----- SAVE -CI- VECTORS ON -NFT12- -----
C
      LOCWKS = LEVEC
      CALL SEQREW(NFT12)
      WRITE (NFT12) NSTATE,NWKS,TTL16A,TTL16B
      DO 190 ISTAT = 1,NSTAT
         CALL SQWRIT(NFT12,X(LOCWKS),NWKS)
         LOCWKS = LOCWKS + NWKS
         ESTATE(ISTAT) = X(ISTAT+LEVAL-1)
  190 CONTINUE
C
C     ----- SAVE ENERGY DATA ON RECORD -2- OF -IDAF- -----
C
      SZ = (MUL-1)*HALF
      SZZ= SZ*(SZ+ONE)
      ETOT = ESTATE(1)
      EELCT = ETOT - ENUCR
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
C
C     -- CALCULATE DAVIDSON'S CORRECTION FOR QUADRUPLE EXCITATIONS --
C     THIS IS ACTUALLY A "RENORMALIZED DAVIDSON CORRECTION" FROM
C     PER SIEGBAHN CHEM.PHYS.LETT 55, 386-394(1978)
C     FOR SINGLE REFERENCE, AND FOR MULTIREFERENCE FROM
C     M.R.A.BLOMBERG, P.E.M.SIEGBAHN J.CHEM.PHYS. 78, 5682-5692(1983)
C
C     SOME OTHER INTERESTING PAPERS IN THIS AREA ARE
C     LANGHOFF AND DAVIDSON, IJQC 8,61(1974)
C     DAVIDSON AND SILVER, CPL, 52, 403(1977)
C     POPLE ET AL, IJQC 11,165(1977) AND IJQC 12,543(1978)
C     J.SIMONS  J.PHYS.CHEM. 93, 626-627(1989)
C
      IF(.NOT.SOME  .OR.  EXETYP.EQ.CHECK) GO TO 400
C
C                   CLOSED SHELL FORMULA
C         CI-SD INCLUDES MORE THAN 1+2 EXCITATIONS WITH THE
C         PRESENT GAMESS DRT CODE, WHEN THERE ARE UNPAIRED
C         ELECTRONS IN THE REFERENCE CONFIGURATION.
C
      IF(IEXCIT.EQ.2  .AND.  NFOCI.EQ.0
     *                .AND.  NAOS+NBOS+NALP.EQ.0) THEN
         NREF = 1
         EREF = ESCF
         C0   = X(IMIN+LEVEC-1)
         C0SQ = C0*C0
         IF(C0SQ.GT.0.8D+00) THEN
            ELOWER = EREF-ETOT
            EQ   = ELOWER*(ONE-C0SQ)/C0SQ
            ESDQ = ETOT-EQ
            WRITE (IW,9250) NREF,C0SQ,EREF,ELOWER,EQ,ESDQ
         END IF
      END IF
C
C                   MULTIREFERENCE (SOCI) CORRECTION
C          THE USER MUST READ IN THE DIMENSION AND ENERGY
C          OF THE REFERENCE IN ORDER TO DO THE CORRECTION.
C
      IF(NFOCI.EQ.2  .AND.  NREF.GT.0  .AND.  EREF.NE.ZERO) THEN
         C0SQ = DDOT(NREF,X(LEVEC),1,X(LEVEC),1)
         ELOWER = EREF-ETOT
         EQ   = ELOWER*(ONE-C0SQ)/C0SQ
         ESDQ = ETOT-EQ
         WRITE (IW,9250) NREF,C0SQ,EREF,ELOWER,EQ,ESDQ
      END IF
C
C     ----- RESET FAST MEMORY -----
C
  400 CONTINUE
      CALL RETFM(NEED)
      IF(SOME) THEN
         WRITE (IW,9088)
         CALL TEXIT(2,2)
      END IF
      IF(ITERMX.LT.0) THEN
         ITER = IABS(ITERMX)
         IF (MASWRK) WRITE(IW,9110) ITER
         CALL ABRT
         STOP
      END IF
      RETURN
C
  200 CONTINUE
      IF (MASWRK) WRITE (IW,9108) ISET1,TTL15A,TTL15B,
     *                            ISET2,TTL16A,TTL16B
      CALL ABRT
      STOP
C
 9008 FORMAT(/10X,41(1H-)/
     *        10X,'DAVIDSON METHOD CI-MATRIX DIAGONALIZATION'/
     *        19X,'WRITTEN BY STEVE ELBERT'/10X,41(1H-))
 0028 FORMAT(34H NO NAMELIST $GUGDIA FOUND. STOP. )
 0048 FORMAT(/31H NAME OF THE ENERGY MATRIX ... ,10A8/
     *        31H NAME OF THE -DRT- TABLE   ... ,10A8/
     *        31H NUMBER OF CONFIGURATIONS  ... ,I10/
     *        1X,'INTEGRAL CUTOFF=',F20.10)
 9088 FORMAT(47H ...... END OF CI-MATRIX DIAGONALIZATION ......)
 9108 FORMAT(35H -NFT15- AND -NFT16- DO NOT MATCH. /
     *       31H NFT15 HEADER RECORD - ISET1 = ,I10,2X,10A8/43X,10A8/
     *       31H NFT16 HEADER RECORD - ISET2 = ,I10,2X,10A8/43X,10A8)
 9110 FORMAT(1X,'DAVIDSON DIAGONALIZATION DID NOT CONVERGE IN',I5,
     *          ' ITERATIONS.  BYEBYE.')
 9128 FORMAT(29H FIND ROOTS OF ENERGY MATRIX )
 9184 FORMAT(/1X,'CHOOSING TO SOLVE SECULAR EQUATION IN MEMORY'/
     *       29H NUMBER OF WORDS AVAILABLE = ,I10/
     *       29H NUMBER OF WORDS USED      = ,I10/
     *       29H ENERGY MATRIX BUFFER SIZE = ,I10)
 9185 FORMAT(/1X,'CHOOSING OUT OF MEMORY STORAGE OF HAMILTONIAN,'/
     *       1X,'AND IN MEMORY STORAGE OF TRIAL VECTORS.')
 9186 FORMAT(/1X,'CHOOSING OUT OF MEMORY STORAGE OF HAMILTONIAN,'/
     *    1X,'AND OUT OF MEMORY STORAGE OF TRIAL VECTORS.'/
     *    1X,'TO HOLD VECTORS IN MEMORY WOULD REQUIRE',I10,' WORDS,'/
     *    1X,'SO FILES',I3,' AND',I3,' WILL BE USED TO STORE VECTORS.')
 9188 FORMAT(/29H NUMBER OF WORDS AVAILABLE = ,I10/
     *        29H NUMBER OF WORDS USED      = ,I10/
     *        29H ENERGY MATRIX BUFFER SIZE = ,I10)
 9208 FORMAT(30H NUMBER OF STATES REQUESTED = ,I5/
     +       30H MAX. NUMB. OF EXPAN. VEC   = ,I5/
     *       30H MAX. NUMB. IMPROVED STATES = ,I5/
     +       30H MAX. NUMB. OF ITERATIONS   = ,I5/
     +       30H CONVERGENCE CRITERION      = ,1P,E10.1)
 9250 FORMAT(/1X,'RENORMALIZED DAVIDSON CORRECTION FOR',I6,
     *          '-REFERENCE CI.'/
     *       1X,'C0SQ=',F9.6,' EREF=',F16.6,' E-E(REF)=',F11.6,
     *          ' E(Q)=',F11.6/
     *       1X,'GIVES A E(SD+Q) ESTIMATE OF',F20.10)
 9300 FORMAT(/'YOU HAVE SPECIFIED FEWER ORBITALS IN NOCC ($TRNSTN) ',/,
     *        'THAN THERE ARE IN THE ACTIVE SPACE. THIS DOES NOT MAKE ',
     *        'SENSE.'/)
      END
