C 21 APR 08 - BN  - SELECT CERTAIN INPUT DEFAULTS
C  4 MAR 08 - BN  - INTERNAL COORD CHANGES, GRID POINT RANGES, ADD EFP,
C                   GROUP DDI, SOME SOLVER AND OVERTONE CHANGES FROM LIAT
C 24 MAR 07 - BN  - PATCHES: PRINTING; STORAGE FOR CONVRT; IZ(2,1) BUG
C 22 DEC 06 - BN  - ALLOW INTERNAL COORDS, GROUP DDI PARALLELIZATION
C 22 DEC 06 - GMS - INCLUDE COMBINATION BANDS
C 22 DEC 06 - LP  - MPPTLIAT,STATEIND: ADDED FOR SOLVER SPEEDUP
C 13 MAR 06 - NM  - ADJUST ARGS TO EGIN CALL
C 19 NOV 05 - DGF - PAD COMMON BLOCK SCFOPT
C 19 SEP 05 - BN  - DO THERMOCHEM W/ANHARM FREQ, MODES USER SELECTABLE
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - KY  - MKQFF: ANOTHER RESTART OUTPUT FIX
C  1 JUN 05 - BN  - MKQFF: RE-FIX PARALLEL RESTART
C 30 APR 05 - TT,RK,GMC - FIX PARALLEL QFF RESTART AND PARALLEL PRINTING
C 14 MAR 05 - HL  - CHANGE FMASS IN FRGMSS COMMON
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 13 FEB 05 - MWS - PAD COMMON BLOCK FRGINF
C  5 FEB 05 - ATK - MKQFF: FIX RESTART INFO GENERATION
C 23 JUL 04 - KY  - ADD QUARTIC FORCE FIELD OPTION
C 23 JUL 04 - NM  - ENABLE VCI SOLVER
C  3 JUN 04 - MWS - VGRID: ELIMINATE MESSAGE 9200
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - CMA - SYNCH UP MP2PAR COMMON
C 12 DEC 02 - CMA - SYNCH UP MP2PAR COMMON
C  7 AUG 02 - JHJ - VARIOUS ROUTINES: IMPLEMENTED IMODE OPTION
C 17 APR 02 - MWS - SYNCH UP FRGINF COMMON
C 24 JAN 02 - CMA - PAD COMMON BLOCK MP2PAR
C  8 OCT 01 - NM  - SOLVER REWORKED, ADDING VCI AND DPT2 FOR V=0 STATE
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 25 JUN 01 - MWS - ALTER COMMON BLOCK SCFOPT AND WFNOPT
C 19 NOV 00 - GMC - PRINT ATOMIC COORDINATES AT EVERY STEP
C 15 AUG 00 - NM  - CORRECT INPUT OF VCFCT VALUE
C 28 JUL 00 - MWS - ADD VSCFTM TO CHECK FOR TIME LIMIT
C  1 MAY 00 - MWS - MODIFY ARGUMENT LIST FOR FGMTRX
C 16 FEB 00 - GMC - NEW MODULE FOR VSCF/VMP2 VIBRATIONAL ANHARMONICITY
C
C*MODULE VSCF    *DECK VSCFX
      SUBROUTINE VSCFX
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL READV,DMDR,MPDIP,GOTDDM,VDPT,CASMIN,VCI,BLANK,PROJCT,
     *        INTCRD,PESALL
      PARAMETER (MXATM=2000, MXFRG=1050)
      DIMENSION IMODE(3*MXATM+6*MXFRG),AMPX(3*MXATM+6*MXFRG),
     *          STPSZX(3*MXATM+6*MXFRG)
      CHARACTER*6 PETYP
C
      CALL VSCFIN(NGRID,IMODE,READV,DMDR,MPDIP,NCOUP,VCFCT,
     *            IEXC,IEXC2,GOTDDM,BLANK,VDPT,VCI,
     *            ICAS1,ICAS2,ICASX,CASMIN,NDET,NDET2,SFACT,PROJCT,
     *            PETYP,STPSZ,INTCRD,SOLVER,INTTYP,AMP,AMPX,STPSZX,
     *            PESALL,CUTOFF)
C
      CALL VSCFM(NGRID,IMODE,READV,DMDR,MPDIP,NCOUP,VCFCT,
     *           IEXC,IEXC2,GOTDDM,BLANK,VDPT,VCI,
     *           ICAS1,ICAS2,ICASX,CASMIN,NDET,NDET2,SFACT,PROJCT,
     *           PETYP,STPSZ,INTCRD,SOLVER,INTTYP,AMP,AMPX,STPSZX,
     *           PESALL,CUTOFF)
C
      RETURN
      END
C*MODULE VSCF    *DECK VSCFIN
      SUBROUTINE VSCFIN(NGRID,IMODE,READV,DMDR,MPDIP,NCOUP,VCFCT,IEXC,
     *                  IEXC2,GOTDDM,BLANK,VDPT,VCI,ICAS1,ICAS2,ICASX,
     *                  CASMIN,NDET,NDET2,SFACT,PROJCT,PETYP,STPSZ,
     *                  INTCRD,SOLVER,INTTYP,AMP,AMPX,STPSZX,
     *                  PESALL,CUTOFF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXFRG=1050,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      LOGICAL READV,DMDR,GOTDDM,MPDIP,GOTEG,GOTFCM,GOPARR,DSKWRK,
     *        MASWRK,BLANK,PROJCT,VDPT,CASMIN,VCI,LINEAR,INTCRD,
     *        PESALL
      DIMENSION IMODE(3*MXATM+6*MXFRG),AMPX(3*MXATM+6*MXFRG),
     *          STPSZX(3*MXATM+6*MXFRG)
      CHARACTER*6 PETYP
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)
      COMMON /FROZNC/ IFREEZ(3*MXATM),NFRZ
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      PARAMETER (NNAM=26)
      DIMENSION QNAM(NNAM), KQNAM(NNAM)
      DATA VSCF/8HVSCF    /
      DATA QNAM/8HPETYP   ,8HIMODE   ,8HNCOUP   ,8HNGRID   ,
     *          8HINTCRD  ,8HINTTYP  ,8HAMP     ,8HAMPX    ,
     *          8HSTPSZX  ,
     *          8HSTPSZ   ,8HDMDR    ,8HMPDIP   ,8HPROJCT  ,
     *          8HBLANK   ,8HREADV   ,8HVCFCT   ,
     *          8HSOLVER  ,8HVDPT    ,8HVCI     ,8HSFACT   ,
     *          8HIEXC    ,8HIEXC2   ,8HICAS1   ,8HICAS2   ,
     *          8HPESALL  ,8HCUTOFF  /
      DATA KQNAM/ 5,-1, 1, 1,   0, 1, 3,-3,  -3,
     *            3, 0, 0, 0,
     *            0, 0, 3,      5, 0, 0, 3,   1, 1, 1, 1,
     *            0, 3/
      DATA RDIRCT/8HDIRECT  /, RQFF/8HQFF     /
      DATA ORIG/8HORIG    /
      PARAMETER (ZERO=0.0D+00)
C
C        READ $VSCF INPUT AND $HESS AND MAYBE $DIPDR
C
      RPETYP  = RDIRCT
      NCOUP   = 2
      NGRID   = 16
      INTCRD  = .FALSE.
C
C     INTTYP STANDS FOR THE TYPE OF INTERNALS THAT WILL BE USED IF
C     INTCRD=.T., MEANING INTTYP =
C     1 - SIMPLE INTERNALS: BOND, ANGLE AND TORSION
C     2 - ALL THE OPTIONS THAT ARE AVAILABLE IN $ZMAT, SUCH AS
C         ATOM-OUT-OF-PLANE AND SO ON
C
      INTTYP  = 0
      AMP     = 7.0D+00
      STPSZ   = 0.5D+00
      DMDR    = .FALSE.
      MPDIP   = .FALSE.
      IF(MPLEVL.EQ.2) MPDIP = .TRUE.
      PROJCT = .TRUE.
      IF(IFREEZ(1).NE.0) PROJCT = .TRUE.
C
C        UNDOCUMENTED OPTION TO FORCE TEMPLATE $VIBSCF RESTART PUNCHING
C
      BLANK   = .FALSE.
      READV   = .FALSE.
      VCFCT   = 1.0D+00
      SOLVER  = ORIG
      VDPT    = .FALSE.
      VCI     = .FALSE.
      SFACT   = 1.0D-04
C
C     IEXC=1 FOR FUNDAMENTALS; IEXC SHOULD NOT BE LARGER THAN NMAX
C     IEXC > 1 FOR OVERTONES; IEXC2 > 0 FOR COMBINATIONS
C     IEXC/IEXC2 SHOULD NOT BE LARGER THAN NMAX
C
      IEXC    = 1
      IEXC2   = 0
      ICAS1   = 1
      ICAS2   = 3*NAT + 6*NFRG - 6
      IF(LINEAR) ICAS2 = 3*NAT + 6*NFRG - 5
      PESALL  = .TRUE.
      CUTOFF  = ZERO
C
      KQNAM(2) = 10*(3*NAT + 6*NFRG) + 1
      KQNAM(8) = 10*(3*NAT + 6*NFRG) + 3
      KQNAM(9) = 10*(3*NAT + 6*NFRG) + 3
      MODE = 3*NAT + 6*NFRG
      DO I = 1, MODE
         IMODE(I)  = 0
         AMPX(I)   = ZERO
         STPSZX(I) = ZERO
      END DO
C
C        READ $VSCF INPUT GROUP
C
      JRET=0
      CALL NAMEIO(IR,JRET,VSCF,NNAM,QNAM,KQNAM,
     *            RPETYP,IMODE,NCOUP,NGRID,INTCRD,INTTYP,
     *            AMP,AMPX,STPSZX,STPSZ,DMDR,MPDIP,PROJCT,
     *            BLANK,READV,VCFCT,SOLVER,VDPT,VCI,SFACT,
     *            IEXC,IEXC2,ICAS1,ICAS2,PESALL,CUTOFF,
     *     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.EQ.2) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR IN $VSCF GROUP, CHECK INPUT'
         CALL ABRT
      END IF
C
C     ---- FORCE A FEW THINGS FOR THE CHOICE OF SOLVER ----
C       NOTE THAT ONE CANNOT USE VDPT AND VCI IN THE SAME RUN.
C     VALUES -CASMIN- AND -ICASX- ARE NO LONGER INPUT PARAMETERS,
C     BUT RATHER ARE FORCED BY THE CHOICE OF THE SOLVER.
C
      IF(.NOT.VCI  .AND.  .NOT.VDPT) VDPT=.TRUE.
C
      IF(INTCRD .AND. INTTYP.EQ.0) INTTYP=2
      CASMIN = .TRUE.
      ICASX=1
C
      IF(VCI) THEN
         VDPT = .FALSE.
         ICASX=2
         CASMIN=.FALSE.
      END IF
C
      IF(VDPT) THEN
         ICASX=1
         CASMIN=.TRUE.
      END IF
C
      ICAS   = ICAS2 - ICAS1 + 1
      NCCC   = (ICAS*ICAS-ICAS)/2
      IF(CASMIN) NCCC = 0
      NDET   = ICASX*ICASX*NCCC + ICAS*ICASX + 1  !#DETERMINANTS IN VCI
      NDET2  = (NDET*NDET+NDET)/2                 ! FOR VCI HAMILTONIAN
C
      IF(MPLEVL.EQ.0) MPDIP=.FALSE.
      IF(DMDR) MPDIP=.FALSE.
C
                           PETYP='      '
      IF(RPETYP.EQ.RDIRCT) PETYP='DIRECT'
      IF(RPETYP.EQ.RQFF  ) PETYP='QFF   '
      IF(PETYP.EQ.'      ') THEN
          IF(MASWRK) WRITE(IW,*) 'PETYP MUST BE -DIRECT- OR -QFF-'
          CALL ABRT
      END IF
C
      IF(MASWRK) WRITE(IW,9000) PETYP,NCOUP,NGRID,PESALL,CUTOFF,
     *                          INTCRD,STPSZ,DMDR,MPDIP,PROJCT,
     *                          READV,VCFCT,VDPT,VCI,SFACT,
     *                          ICAS1,ICAS2,IEXC,IEXC2
      IF(MASWRK .AND. INTCRD) WRITE(IW,9010) INTTYP
      IF(MASWRK .AND. INTCRD .AND. NZVAR.EQ.0) THEN
         WRITE(IW,*) 'IF INTCRD=.TRUE. THEN NZVAR=3N-6(5 FOR LINEAR)'
         CALL ABRT
      END IF
C
C        READ GRADIENT, HESSIAN, DIPOLE DERIVATIVE TENSOR
C
      NCOORD = 3*NAT + 6*NFRG
      CALL VALFM(LOADFM)
      LEG  = LOADFM + 1
      LFCM = LEG    + NCOORD
      LDDM = LFCM   + NCOORD*NCOORD
      LAST = LDDM   + 3*NCOORD
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL EGIN(X(LEG),NCOORD,GOTEG,' $GRAD  ')
      IF(.NOT.GOTEG) CALL VCLR(X(LEG),1,NCOORD)
      CALL DAWRIT(IDAF,IODA,X(LEG),NCOORD,3,0)
C
      CALL FCMIN(X(LFCM),NCOORD,GOTFCM)
      IF(GOTFCM) THEN
         CALL DAWRIT(IDAF,IODA,X(LFCM),NCOORD*NCOORD,4,0)
      ELSE
         IF(MASWRK) WRITE(IW,9020)
         CALL ABRT
      END IF
C
      CALL DDMIN(X(LDDM),NCOORD,GOTDDM)
      IF(GOTDDM) CALL DAWRIT(IDAF,IODA,X(LDDM),3*NCOORD,34,0)
C
      CALL RETFM(NEED)
      RETURN
C
 9000 FORMAT(/15X,21(1H-)/15X,'VSCF INPUT PARAMETERS'/15X,21(1H-)/
     *   5X,'  PETYP=   ',A6,'     NCOUP=',I8,'     NGRID=',I8/
     *   5X,' PESALL= ',L8,'    CUTOFF=',1P,E8.1,0P/
     *   5X,' INTCRD= ',L8,'     STPSZ=',1P,E8.1,0P/
     *   5X,'   DMDR= ',L8,'     MPDIP=',L8,'    PROJCT=',L8/
     *   5X,'  READV= ',L8,'     VCFCT=',F8.2/
     *   5X,'   VDPT= ',L8,'       VCI=',L8,'     SFACT=',1P,E8.1,0P/
     *   5X,'  ICAS1= ',I8,'     ICAS2=',I8/
     *   5X,'   IEXC= ',I8,'     IEXC2=',I8/)
 9010 FORMAT(//1X,'PES NEEDED FOR VSCF CALCULATION IS GOING TO BE'/
     *   1X,'GENERATED USING NORMAL MODE DISPLACEMENTS'/
     *   1X,'IN INTERNAL COORDINATES OF INTTYP=',I5/)
 9020 FORMAT(//1X,'***** ERROR *****'/
     *   1X,'RUNTYP=VSCF REQUIRES THE INPUT OF A $HESS MATRIX.'/
     *   1X,'PLEASE OBTAIN THIS FROM RUNTYP=HESSIAN AND INPUT IT.'/
     *   1X,'IF POSSIBLE, PLEASE SUPPLY OPTIONAL $DIPDR AND $GRAD'/)
      END
C*MODULE VSCF    *DECK VSCFM
      SUBROUTINE VSCFM(NGRID,IMODE,READV,DMDR,MPDIP,NCOUP,VCFCT,IEXC,
     *                 IEXC2,GOTDDM,BLANK,VDPT,VCI,ICAS1,ICAS2,ICASX,
     *                 CASMIN,NDET,NDET2,SFACT,PROJCT,PETYP,STPSZ,
     *                 INTCRD,SOLVER,INTTYP,AMP,AMPX,STPSZX,
     *                 PESALL,CUTOFF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER DM_LIST
C
      LOGICAL READV,DMDR,MPDIP,GOTDDM,BLANK,VDPT,VCI,CASMIN,
     *        GOPARR,DSKWRK,MASWRK,LINEAR,DECOMP,PRTSCN,GOTFRQ,
     *        PROJCT,STATPT,SCFOK,ISGDDI,PAROUT,INITGDDI,INTCRD,
     *        PESALL
C
      CHARACTER*6 PETYP
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXPT=2000, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12, ZERO=0.0D+00)
C
      DIMENSION IMODE(3*MXATM+6*MXFRG),AMPX(3*MXATM+6*MXFRG),
     *          STPSZX(3*MXATM+6*MXFRG)
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)
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /GDDI  / ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /THERMD/ FREQ(3*MXATM),TEMP(10),SCLFAC,NTEMP,PRTSCN,GOTFRQ
      COMMON /VBDCMP/ DECOMP,NROW,NDEG
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
C        ----- ALLOCATE MEMORY AND CARRY OUT VSCF -----
C
C                  THIS PROGRAM WAS WRITTEN BY
C           GALINA CHABAN, JOON JUNG, AND BENNY GERBER
C            U.CAL.-IRVINE AND HEBREW U. OF JERUSALEM
C           IT WAS INCLUDED INTO GAMESS IN EARLY 2000.
C
C      IF(NFRG.GT.0) THEN
C         IF(MASWRK) WRITE(IW,*) 'VSCF NOT IMPLEMENTED FOR EFP MODEL'
C         CALL ABRT
C      END IF
C
      NC1 = 3*NAT + 6*NFRG
      NC2 = (NC1*NC1+NC1)/2
      NC3 = NC1*NC1
      NNM = 3*NAT + 6*NFRG - 6
      IF(LINEAR) NNM = 3*NAT + 6*NFRG - 5
C
C     COUNT THE FREQUENCIES FOR ANHARMONIC VIBRATIONAL ANALYSIS
C     ISVIB IS THE NUMBER OF FREQUENCIES SELECTED FOR ANHARMONIC
C     VIBRATIONAL ANALYSIS
C     IF ALL FREQUENCIES ARE CHOOSEN FOR ANHARMONIC VIBRATIONAL ANALYSIS
C     THEN ISVIB=NM, OTHERWISE ISVIB IS MANUALLY CHOOSEN BY THE USER
C
C     RENUMBER FREQUENCIES FROM 1 TO ISVIB, INSTEAD FROM NC1 TO NC1-6
C     (OR 5 FOR LINEAR MOLECULE), SO FREQ(NC1) WILL BECOME FREQ(1)
C
      ISVIB = 0
      IF(IMODE(1).NE.0) THEN
        DO I = 1, NC1
          IF(IMODE(I).NE.0) THEN
            IMODE(I) = NC1 - IMODE(I) + 1
            ISVIB = ISVIB + 1
          END IF
        END DO
        DO I=1,ISVIB-1
           DO J=I+1,ISVIB
              IF (IMODE(I).GT.IMODE(J)) THEN
                 MODE=IMODE(I)
                 IMODE(I)=IMODE(J)
                 IMODE(J)=MODE
              END IF
           END DO
        END DO
      ELSE
        DO I = 1, NNM
            IMODE(I) = I
        END DO
        ISVIB=NNM
      END IF
C
        IF(VCI.AND.ICAS2.GT.ISVIB) THEN
      IF(MASWRK) WRITE(IW,*) 'ICAS2 EXCIDES THE NUMBER OF SELECTED FREQ'
           CALL ABRT
        END IF
C
C        NNM2 IS NO. OF PAIRS OF DIFFERENT MODES (NOT TRIANG. STORAGE)
C
        NNM2 = (NNM*NNM-NNM)/2
        NNM3 = NNM*NNM
        NNM4 = (NNM*NNM+NNM)/2
        ISVIB2 = (ISVIB*ISVIB-ISVIB)/2
        ISVIB4 = (ISVIB*ISVIB+ISVIB)/2
C
      NGRID2 = (NGRID*NGRID+NGRID)/2
      NGRID3 = NGRID*NGRID
C
C        NUMBER OF VIBR. STATES FOR WHICH WAVEFUNCTIONS ARE STORED
C
      NST=NGRID/2
      IF(NST.LT.4) NST=4
C
C        MAXIMUM EXCITATION LEVEL USED IN VIBRATIONAL MP2
C
      NMAX=NST-1
C
C        NUMBER OF VIRTUAL STATES IN MP2
C
      NVIRST=NMAX*NMAX*ISVIB2 + NMAX*ISVIB + 1
C
C              NUMBER OF TRIPLES OF DIFFERENT NORMAL MODES
C              NO. OF VIRTUAL STATES IN MP2 INCLUDES TRIPLE EXCITATIONS
C
      IF (NCOUP.GT.2) THEN
         NTR=ISVIB*(ISVIB-1)*(ISVIB-2)/6
         NVIRST=NVIRST+NMAX*NMAX*NMAX*NTR
      END IF
C
      NROW_DM = 10
      NPOINT = ISVIB*NGRID
      IF (NCOUP.GT.1) NPOINT = NPOINT +
     *                         NGRID*NGRID*ISVIB*(ISVIB-1)/2
      IF (NCOUP.GT.2) NPOINT = NPOINT +
     *         NGRID*NGRID*NGRID*ISVIB*(ISVIB-1)*(ISVIB-2)/6
      IF(PETYP.EQ.'DIRECT') THEN
        NCOL = NPOINT
      ELSE IF(PETYP.EQ.'QFF   ') THEN
        NCOL = ISVIB*6
        IF (NCOUP.EQ.2) NCOL = NCOL + 12*ISVIB*(ISVIB-1)/2
      END IF
C
C     CREATE DISTRIBUTED MEMORY LIST, DM_LIST, CONTAINING:
C     I,J,K,IL,JL,KL - CORRESPOND TO THE POINT ON THE PES
C     DIAGV,COUPV AND TRIPV
C     DMX,DMY AND DMZ - DIPOLE MOMENTS
C
      IF(ISGDDI) THEN
        CALL DDI_CREATE(NROW_DM,NCOL,DM_LIST)
      END IF
C
      CALL VALFM(LOADFM)
C
C         MEMORY FOR VSCF
C
C     THE FIRST TWO OF THESE HOLD HARMONIC NORMAL MODES AND FREQUENCIES
C
C     QFF_COM(I) = 0 QFF POINT NEEDS TO BE COMPUTED
C                = 1 COMPUTED
C     PES_COM(I) = 0 DIRECT POINT NEEDS TO BE COMPUTED
C                = 1 ALREADY COMPUTED
C
      LVEC     = LOADFM   + 1
      LE       = LVEC     + NC3
      LDX      = LE       + NC1
      LFR      = LDX      + NC1
      LFRSCF   = LFR      + NNM4
      LFRMP2   = LFRSCF   + NNM4
      LDEMP2   = LFRMP2   + NNM4
      LC0      = LDEMP2   + NNM4
      LDIAGV   = LC0      + NC1
      LCOUPV   = LDIAGV   + NNM*NGRID
      LDQ      = LCOUPV   + NNM3*NGRID3
      LRQ      = LDQ      + NNM
      LSTATE   = LRQ      + NNM*NGRID
      LTV      = LSTATE   + NNM*(NNM4+1)
      LVSCF    = LTV      + NGRID
      LVHF     = LVSCF    + NNM*NGRID
      LENRGY   = LVHF     + NGRID
      LEDIAG   = LENRGY   + NNM
      LESCF    = LEDIAG   + NNM4 + 1
      LEMPPT   = LESCF    + NNM4 + 1
      LWAVE    = LEMPPT   + NNM4 + 1
      LAWAVE   = LWAVE    + NNM*NGRID
      LVWAVE   = LAWAVE   + NNM*(NNM4+1)*NGRID
      LVIRTE   = LVWAVE   + NNM*NGRID*NST
      LVST     = LVIRTE   + NNM*NST
      LPVT     = LVST     + NVIRST*NNM
      LXX      = LPVT     + NGRID
      LA       = LXX      + NGRID
      LPHI     = LA       + NGRID
      LR       = LPHI     + NGRID3
      LRR      = LR       + NGRID3
      LG       = LRR      + NGRID3
      LV       = LG       + NGRID3
      LH       = LV       + NGRID3
      LEC      = LH       + NGRID2
      LVECC    = LEC      + NGRID
      LSCR1    = LVECC    + NGRID3
      LIA1     = LSCR1    + NGRID*8
      LGR      = LIA1     + NGRID
      LTMP     = LGR      + NGRID3
      LTWAVE   = LTMP     + NGRID
      LEMP0    = LTWAVE   + NGRID
      LVMP     = LEMP0    + NVIRST
      LOVRLP   = LVMP     + NVIRST*NDET          ! EXPANDED TO ACC DPT
      LVIRT    = LOVRLP   + NNM
      LREF     = LVIRT    + NVIRST*NNM
      LINT     = LREF     + NNM
      LDMX     = LINT     + NNM4
      LDMY     = LDMX     + NNM*NGRID
      LDMZ     = LDMY     + NNM*NGRID
      LDM2X    = LDMZ     + NNM*NGRID
      LDM2Y    = LDM2X    + NNM3*NGRID3
      LDM2Z    = LDM2Y    + NNM3*NGRID3
      LDDM     = LDM2Z    + NNM3*NGRID3
      LDDER    = LDDM     + 3*NC1
      LHCI     = LDDER    + NNM                  ! VCI STARTS HERE
      LECI     = LHCI     + NDET2
      LVECI    = LECI     + NDET
      LSCRCI   = LVECI    + NDET*NDET
      LIACI    = LSCRCI   + NDET*8
      LKREF    = LIACI    + NDET
      LICAST   = LKREF    + NNM
      LIMAP    = LICAST   + NDET*NNM
      LECAS    = LIMAP    + NNM
      LEQDPT2  = LECAS    + NNM4 + 1
      LMASTID  = LEQDPT2  + NNM4 + 1
      LPES_COM = LMASTID  + NPROC
      LMAP_LIST= LPES_COM + NPOINT
      LJMODE   = LMAP_LIST+ NC1
      LAST     = LJMODE   + NC1
      LTRIPV = LAST
      IF(NCOUP.GT.2) LAST = LTRIPV + NNM3*NNM*NGRID3*NGRID
C
      IF(PETYP.EQ.'QFF   ') THEN
         LQFF_COM = LAST
         LQ    = LQFF_COM + NCOL
         LDE1   = LQ      + NNM
         LDE2   = LDE1    + 6*NNM
         LSTP1  = LDE2    + 12*NNM2
         LDDPL1 = LSTP1   + NC1
         LDDPL2 = LDDPL1  + 18*NNM
         LHII   = LDDPL2  + 36*NNM2
         LTIII  = LHII    + NNM
         LUIIII = LTIII   + NNM
         LTIIJ  = LUIIII  + NNM
         LUIIIJ = LTIIJ   + NNM2*2
         LUIIJJ = LUIIIJ  + NNM2*2
         LDGI   = LUIIJJ  + NNM2
         LDHII  = LDGI    + 3*NNM
         LDTIII = LDHII   + 3*NNM
         LDUIIII= LDTIII  + 3*NNM
         LAST   = LDUIIII + 3*NNM
      ELSE
         LQFF_COM= LAST
         LQ      = LAST
         LDE1    = LAST
         LDE2    = LAST
         LSTP1   = LAST
         LDDPL1  = LAST
         LDDPL2  = LAST
         LHII    = LAST
         LTIII   = LAST
         LUIIII  = LAST
         LTIIJ   = LAST
         LUIIIJ  = LAST
         LUIIJJ  = LAST
         LDGI    = LAST
         LDHII   = LAST
         LDTIII  = LAST
         LDUIIII = LAST
      END IF
      IF(ISGDDI) THEN
C
C     ALLOCATE MEMORY FOR DMPACK(NROW) - PACKET THAT IS GOING TO BE
C     STORED IN DM_LIST TROUGH DDI_PUT AS WELL AS FOR CUR_IRC AND
C     DATA_IRC  ALL POINTS ON THE PES (I,J,K,L,IL,JL,KL FOR DIRECT
C     AND I,J,P FOR QFF) ARE MAPPED INTO SINGLE POINT ID_DM
C     (FROM 1 TO NCOL) IN DM_LIST:
C
         LFIN_IRC  = LAST
         LDMPACK   = LFIN_IRC + NCOL
         LCUR_IRC  = LDMPACK  + NROW_DM
         LDATA_IRC = LCUR_IRC + NCOL
         LAST = LDATA_IRC + NROW_DM
      ELSE
         LFIN_IRC  = LAST
         LDMPACK   = LAST
         LCUR_IRC  = LAST
         LDATA_IRC = LAST
      END IF
C
C     ALLOCATE MEMORY FOR NORMAL MODE DISPLACEMENTS IN INTERNALS
C     DVEC(NZVAR*NC1)  - NORMAL MODE DISPLACEMENTS IN INTERNAL COORD
C     BMTRX(NZVAR*NC1) - MATRIX FOR CONVERSION FROM CARTESIAN TO
C                        INTERNAL COORDINATES
C
      IF(INTCRD) THEN
         LDVEC      = LAST
         LBMTRX     = LDVEC      + NZVAR*NC1
         LCOORD_ALL = LBMTRX     + NZVAR*NC1
         LDELCOR    = LCOORD_ALL + 3*NAT*NCOL
         LZMAT_CUR  = LDELCOR    + NC1
         LZMAT_OLD  = LZMAT_CUR  + NZVAR
         LIZMAT     = LZMAT_OLD  + NZVAR
         LITYP      = LIZMAT     + NZMAT
         LICONNCT   = LITYP      + NZVAR
         LNCOUNT1   = LICONNCT   + NZVAR*4
         LAST       = LNCOUNT1   + ISVIB
         LNCOUNT2   = LAST
         IF(NCOUP.EQ.2) LAST = LNCOUNT2 + ISVIB*ISVIB
      ELSE
         LDVEC      = LAST
         LBMTRX     = LAST
         LCOORD_ALL = LAST
         LDELCOR    = LAST
         LZMAT_CUR  = LAST
         LZMAT_OLD  = LAST
         LIZMAT     = LAST
         LITYP      = LAST
         LICONNCT   = LAST
         LNCOUNT1   = LAST
         LNCOUNT2   = LAST
      END IF
C
      IF(.NOT.PESALL) THEN
         LCHOOSEN   = LAST
         LGRADES    = LCHOOSEN + ISVIB*ISVIB
         LAST       = LGRADES  + ISVIB*ISVIB
      ELSE
         LCHOOSEN   = LAST
         LGRADES    = LAST
      END IF
C
      NEED1 = LAST - LOADFM - 1
      IF(MASWRK) WRITE(IW,9000) NEED1
      CALL GETFM(NEED1)
C
C     CLEAR DIAG AND COUP V AND DIPOLE
C
      CALL VICLR(X(LJMODE),1,NC1)
      CALL VCLR(X(LDIAGV),1,NNM*NGRID)
      IF(NCOUP.GT.1) CALL VCLR(X(LCOUPV),1,NNM3*NGRID3)
      IF(NCOUP.GT.2) CALL VCLR(X(LTRIPV),1,NNM3*NNM*NGRID3*NGRID)
      CALL VCLR(X(LDMX),1,NNM*NGRID)
      CALL VCLR(X(LDMY),1,NNM*NGRID)
      CALL VCLR(X(LDMZ),1,NNM*NGRID)
      IF(NCOUP.GT.1) CALL VCLR(X(LDM2X),1,NNM3*NGRID3)
      IF(NCOUP.GT.1) CALL VCLR(X(LDM2Y),1,NNM3*NGRID3)
      IF(NCOUP.GT.1) CALL VCLR(X(LDM2Z),1,NNM3*NGRID3)
      CALL VICLR(X(LMASTID),1,NPROC)
      CALL VCLR(X(LRQ),1,NNM*NGRID)
      CALL VCLR(X(LDQ),1,NNM)
      CALL VICLR(X(LPES_COM),1,NPOINT)
      CALL VICLR(X(LMAP_LIST),1,NC1)
      IF(PETYP.EQ.'QFF   ') THEN
         CALL VCLR(X(LQFF_COM),1,NCOL)
         CALL VCLR(X(LSTP1),1,NC1)
         CALL VCLR(X(LDE1),1,6*NNM)
         CALL VCLR(X(LDDPL1),1,18*NNM)
         CALL VCLR(X(LHII),1,NNM)
         CALL VCLR(X(LTIII),1,NNM)
         CALL VCLR(X(LUIIII),1,NNM)
         CALL VCLR(X(LTIIJ),1,NNM2*2)
         CALL VCLR(X(LUIIIJ),1,NNM2*2)
         CALL VCLR(X(LUIIJJ),1,NNM2)
         CALL VCLR(X(LDGI),1,3*NNM)
         CALL VCLR(X(LDHII),1,3*NNM)
         CALL VCLR(X(LDTIII),1,3*NNM)
         CALL VCLR(X(LDUIIII),1,3*NNM)
         IF(NCOUP.GT.1) CALL VCLR(X(LDE2),1,12*NNM2)
         IF(NCOUP.GT.1) CALL VCLR(X(LDDPL2),1,36*NNM2)
      END IF
      IF(ISGDDI) THEN
         CALL VICLR(X(LFIN_IRC),1,NCOL)
         CALL VCLR(X(LDMPACK),1,NROW_DM)
         CALL VCLR(X(LCUR_IRC),1,NCOL)
         CALL VCLR(X(LDATA_IRC),1,NROW_DM)
      END IF
      IF(INTCRD) THEN
         CALL VICLR(X(LNCOUNT1),1,ISVIB)
         IF(NCOUP.EQ.2) CALL VICLR(X(LNCOUNT2),1,ISVIB*ISVIB)
      END IF
      CALL VCLR(X(LINT),1,NNM4)
C
      NPART = NAT
      KMASS = 0
      DO IFRG=1,NFRG
         DO III=1,NMPTS(IFRG)
            IF(FMASS(III+KMASS).GT.ZERO) NPART=NPART+1
         END DO
         KMASS = KMASS + NMPTS(IFRG)
      END DO
C
C         MEMORY FOR NORMAL MODE ANALYSIS
C
      CALL VALFM(LOADFM)
      LFCM   = LOADFM + 1
      LSCR   = LFCM   + NC2
      LIA    = LSCR   + NC1*8
      LRM    = LIA    + NC1
      LSVT   = LRM    + 3*NAT + 21*NFRG
      LSVR   = LSVT   + NC1*3
      LSVTT  = LSVR   + NC1*3
      LSVRT  = LSVTT  + NC1
      LCC    = LSVRT  + NC1
      LCOM   = LCC    + NPART*3
      LZMS   = LCOM   + NPART*3
      LBUF1  = LZMS   + NPART
      LBUF2  = LBUF1  + NC3
      LAST   = LBUF2  + NC3
      NEED2 = LAST - LOADFM - 1
      CALL GETFM(NEED2)
      IF(MASWRK) WRITE(IW,9010)
C
C        GENERATE NORMAL COORDINATES FROM INPUT HARMONIC FORCE FIELD
C        ENFORCE A CONSISTENT PHASE CHOICE UPON THE MODES
C
      DECOMP=.FALSE.
      STATPT=.TRUE.
      SCFOK =.TRUE.
      NTEMP=1
      TEMP(1)=298.15D+00
      SCLFAC=1.0D+00
      PRTSCN=.FALSE.
      GOTFRQ=.FALSE.
      CALL FGMTRX(X(LVEC),X(LFCM),X(LE),X(LSCR),X(LIA),X(LRM),
     *            X(LSVT),X(LSVR),X(LSVTT),X(LSVRT),
     *            X(LCC),X(LCOM),X(LZMS),X(LBUF1),X(LBUF2),
     *            NC1,NC2,NPART,X(LDDM),GOTDDM,DUMMY,.FALSE.,
     *            PROJCT,STATPT,SCFOK)
      CALL RETFM(NEED2)
      IF(MASWRK) WRITE(IW,9020)
      CALL TIMIT(1)
C
      IF(INTCRD) CALL INTVEC(X(LVEC),X(LBMTRX),X(LDVEC),NC1,
     *                       NZVAR)
C
      IF(IEXC2.GT.0 .OR. IEXC.GT.1) DMDR=.FALSE.
      IF (DMDR.AND.GOTDDM) THEN
         NDIPMO=0
      ELSE
         NDIPMO=1
      END IF
C
      IF (ISVIB.EQ.1) NCOUP=1
C
C        CALCULATE DIAGONAL AND COUPLING POTENTIALS ON GRIDS
C
      CALL VGRID(X(LVEC),X(LE),X(LFR),X(LRQ),X(LDQ),X(LDX),X(LC0),
     *           X(LDIAGV),X(LCOUPV),X(LTRIPV),X(LDMX),X(LDMY),X(LDMZ),
     *           X(LDM2X),X(LDM2Y),X(LDM2Z),READV,MPDIP,DMDR,NC1,NAT,
     *           NNM,NNM2,NGRID,NCOUP,BLANK,IMODE,PETYP,STPSZ,X(LQ),
     *           X(LDE1),X(LDE2),X(LSTP1),X(LDDPL1),X(LDDPL2),X(LHII),
     *           X(LTIII),X(LUIIII),X(LTIIJ),X(LUIIIJ),X(LUIIJJ),
     *           X(LDGI),X(LDHII),X(LDTIII),X(LDUIIII),ISVIB,X(LMASTID),
     *           NNM3,NGRID3,DM_LIST,X(LMAP_LIST),X(LQFF_COM),
     *           X(LDMPACK),X(LCUR_IRC),X(LDATA_IRC),X(LPES_COM),
     *           X(LFIN_IRC),NPOINT,NROW_DM,NCOL,X(LJMODE),INTCRD,
     *           X(LDVEC),INTTYP,X(LDELCOR),X(LCOORD_ALL),AMP,AMPX,
     *           STPSZX,PESALL,X(LCHOOSEN),X(LGRADES),CUTOFF,
     *           X(LZMAT_CUR),X(LZMAT_OLD),X(LIZMAT),X(LITYP),
     *           X(LICONNCT),X(LNCOUNT1),X(LNCOUNT2))
C
C     DESTROY DISTRIBUTED MEMORY ARRAY DM_LIST
C
      IF(ISGDDI) CALL DDI_DESTROY(DM_LIST)
C
      IF (MASWRK) WRITE(IW,9060)
      CALL TIMIT(1)
      IF(BLANK) GO TO 800
C
C        PERFORM VSCF AND MP2-VSCF
C
      IF (MASWRK) THEN
         CALL VSCFMP(X(LFR),X(LRQ),X(LDQ),X(LDIAGV),X(LCOUPV),
     *               X(LSTATE),X(LTV),X(LVSCF),X(LVHF),X(LENRGY),
     *               X(LEDIAG),X(LESCF),X(LEMPPT),X(LWAVE),X(LAWAVE),
     *               X(LVWAVE),X(LVIRTE),X(LVST),X(LPVT),X(LXX),
     *               X(LA),X(LPHI),X(LR),X(LRR),X(LG),X(LV),X(LH),
     *               X(LEC),X(LVECC),X(LSCR1),X(LIA1),X(LGR),X(LTMP),
     *               X(LTWAVE),X(LEMP0),X(LVMP),X(LOVRLP),X(LVIRT),
     *               X(LREF),X(LFRSCF),X(LFRMP2),X(LDEMP2),X(LTRIPV),
     *               VCFCT,NC1,NNM,NGRID,NGRID2,NST,NVIRST,NCOUP,NMAX,
     *               IEXC,X(LHCI),X(LECI),X(LVECI),X(LSCRCI),X(LIACI),
     *               NDET,ICAS1,ICAS2,VDPT,NDET2,X(LKREF),ICASX,
     *               X(LICAST),X(LIMAP),CASMIN,X(LECAS),
     *               X(LEQDPT2),SFACT,VCI,X(LCC),X(LCOM),X(LZMS),
     *               NPART,IMODE,X(LJMODE),ISVIB,IEXC2,NNM4,ISVIB4,
     *               SOLVER)
      END IF
C
C        CALCULATE IR INTENSITIES
C
      IF(NDIPMO.EQ.0) THEN
         CALL DAREAD(IDAF,IODA,X(LDDM),3*NC1,34,0)
         CALL DINTENS(X(LINT),X(LDDM),X(LDDER),X(LFRSCF),
     *                X(LFRMP2),X(LVEC),X(LRQ),X(LDQ),X(LAWAVE),
     *                NNM,NNM4,NGRID,NC1,IMODE,ISVIB)
      ELSE
         CALL INTENS(X(LINT),X(LDMX),X(LDMY),X(LDMZ),X(LDM2X),X(LDM2Y),
     *               X(LDM2Z),X(LFRSCF),X(LFRMP2),X(LDQ),X(LAWAVE),
     *               X(LSTATE),NNM,NGRID,ISVIB,NNM4,ISVIB4,IEXC2,
     *               IMODE,NC1)
      END IF
C
  800 CONTINUE
      CALL RETFM(NEED1)
      IF (MASWRK) WRITE(IW,9070)
      CALL TIMIT(1)
      RETURN
C
 9000 FORMAT(1X,I12,' WORDS OF MEMORY ARE NEEDED FOR VSCF STORAGE')
 9010 FORMAT(/1X,'HARMONIC VIBRATIONAL ANALYSIS FOR THE INPUT HESSIAN')
 9020 FORMAT(1X,'......DONE WITH HARMONIC NORMAL MODES.....')
 9060 FORMAT(1X,'......DONE WITH POTENTIALS ON GRIDS......')
 9070 FORMAT(1X,'......FINISHED VIBRATIONAL SCF......')
      END
C*MODULE VSCF    *DECK VGRID
      SUBROUTINE VGRID(VEC,EIG,FREQ,RQ,DQ,DX,C0,DIAGV,COUPV,TRIPV,
     *                 DM1X,DM1Y,DM1Z,DM2X,DM2Y,DM2Z,READV,MPDIP,DMDR,
     *                 NC1,NAT1,NNM,NNM2,NGRID,NCOUP,BLANK,IMODE,
     *                 PETYP,STPSZ,Q,DE1,DE2,STP1,DDPL1,DDPL2,
     *                 HII,TIII,UIIII,TIIJ,UIIIJ,UIIJJ,
     *                 DGI,DHII,DTIII,DUIIII,ISVIB,MASTID,NNM3,NGRID3,
     *                 DM_LIST,MAP_LIST,QFF_COM,DMPACK,CUR_IRC,
     *                 DATA_IRC,PES_COM,FIN_IRC,NPOINT,NROW_DM,NCOL,
     *                 JMODE,INTCRD,DVEC,INTTYP,DELCOR,
     *                 COORD_ALL,AMP,AMPX,STPSZX,PESALL,CHOOSEN,
     *                 GRADES,CUTOFF,ZMAT_CUR,ZMAT_OLD,
     *                 IZMAT,ITYP,ICONNCT,NCOUNT1,NCOUNT2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER DDI_WORLD,DDI_GROUP,DDI_MASTER,DM_LIST,QFF_COM,PES_COM,
     *        FIN_IRC
C
      LOGICAL GOPARR,DSKWRK,MASWRK,READV,MPDIP,DMDR,BLANK,LINEAR,
     *        INTCRD,ISTEMP,ISGDDI,PAROUT,INITGDDI,MYJOB,
     *        PESALL,CHOOSEN
C
      CHARACTER*5 WORD
      CHARACTER*25 JOBTYP
      CHARACTER*6 PETYP
      CHARACTER*6 FRGNAM
      CHARACTER*8 FRGNME
      CHARACTER*8 PTNAM
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXPT=2000,
     *           MXFGPT=12000, MXDFG=5, MXDPPT=MXFRG*MXDFG*12,
     *           DDI_WORLD=0,DDI_GROUP=1,DDI_MASTER=2,
     *           ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00,HALF=0.5D+00,
     *           AMU=1.8229D+03,
     *           PLANC=1.51982984D-16,UNITCONV=6.57968392D+15)
C
C     PLANC: PLANC CONSTANT (HARTREE*SEC)
C     UNITCONV: CONVERTS FROM HARTREES TO HZ
C
      DIMENSION EIG(NC1),VEC(NC1,NC1),DX(NC1),DIAGV(NNM,NGRID),
     *          FREQ(NC1),C0(3,NAT1),
     *          DQ(NNM),RQ(NNM,NGRID),
     *          COUPV(NNM,NNM,NGRID,NGRID),
     *          TRIPV(NNM,NNM,NNM,NGRID,NGRID,NGRID),
     *          DM1X(NNM,NGRID),DM1Y(NNM,NGRID),DM1Z(NNM,NGRID),
     *          DM2X(NNM,NNM,NGRID,NGRID),DM2Y(NNM,NNM,NGRID,NGRID),
     *          DM2Z(NNM,NNM,NGRID,NGRID),Q(NNM),DE1(6,NNM),
     *          DE2(12,NNM2),STP1(NC1),DDPL1(18,NNM),DDPL2(36,NNM2),
     *          HII(NNM),TIII(NNM),UIIII(NNM),
     *          TIIJ(NNM2*2),UIIIJ(NNM2*2),UIIJJ(NNM2),
     *          DGI(3,NNM),DHII(3,NNM),DTIII(3,NNM),DUIIII(3,NNM),
     *          IMODE(NC1),MASTID(*),JMODE(NC1),
     *          PES_COM(NPOINT),QFF_COM(NCOL),MAP_LIST(NC1),
     *          DMPACK(NROW_DM),CUR_IRC(NCOL),DATA_IRC(NROW_DM),
     *          FIN_IRC(NCOL),DVEC(NZVAR,NC1),DELCOR(NC1),
     *          COORD_ALL(NCOL,3*NAT1),AMPX(3*MXATM+6*MXFRG),
     *          STPSZX(3*MXATM+6*MXFRG),CHOOSEN(ISVIB,ISVIB),
     *          GRADES(ISVIB,ISVIB),
     *          ZMAT_CUR(NZVAR),ZMAT_OLD(NZVAR),IZMAT(NZMAT),
     *          ITYP(NZVAR),ICONNCT(NZVAR,4),
     *          NCOUNT1(ISVIB),NCOUNT2(ISVIB,ISVIB)
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 /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(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 /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /FROZNC/ IFREEZ(3*MXATM),NFRZ
      COMMON /FUNCT / E,EG(3*MXATM)
      COMMON /GDDI  / ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      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,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /XYZPRP/ XP,YP,ZP,
     *                DMX,DMY,DMZ,
     *                QXX,QYY,QZZ,QXY,QXZ,QYZ,
     *                QMXX,QMYY,QMZZ,QMXY,QMXZ,QMYZ,
     *                OXXX,OXXY,OXXZ,OXYY,OYYY,OYYZ,
     *                OXZZ,OYZZ,OZZZ,OXYZ,
     *                OMXXX,OMXXY,OMXXZ,OMXYY,OMYYY,
     *                OMYYZ,OMXZZ,OMYZZ,OMZZZ,OMXYZ
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
C
      DATA CHECK/8HCHECK   /
      INITGDDI = .TRUE.
C
C     IF GDDI RUN THEN FIND COMMUNCATOR ID IN THE WORLD"S SCOPE
C
      IF(ISGDDI) CALL DDI_COMMID(DDI_WORLD,IDWORLD)
C
C     ---- DRIVER TO OBTAIN ENERGY AND DIPOLE INFORMATION ---
C
      NUNCVG = 0
C
C     OPEN THE FILE THAT RECEIVES THE RESTART INFORMATION...
C
      ISTEMP = ISGDDI
      ISGDDI= .FALSE.
      IRC=4
      CALL SEQOPN(IRC,'IRCDATA','NEW',.FALSE.,'FORMATTED')
      ISGDDI = ISTEMP
C
C        SINCE THE FINAL VSCF COMPUTATION IS DONE ONLY ON THE MASTER,
C        THERE IS NO NEED FOR OTHER PROCESSES TO HAVE GOOD ENERGY
C        OR DIPOLE INFORMATION, IN THE CASE OF RESTART RUNS.  HOWEVER
C        WE MUST ENSURE THAT OTHER NODES PARTICIPATE IN ANY ENERGY
C        EVALUATIONS, IN CASE THE RESTART INFORMATION IS INCOMPLETE.
C
      E   = ZERO
      DMX = ZERO
      DMY = ZERO
      DMZ = ZERO
C
      IEOF=0
C
C     FREQUENCIES IN ATOMIC UNITS
C     THE WAY WE AVOID ZERO FREQUENCY ROTATIONS AND TRANSLATIONS
C     BELOW IS LOOPING FROM HIGHEST FREQUENCIES ON DOWN TO LOWEST
C     TRUE VIBRATION, HERE CONVERT ONLY TRUE VIBRATIONAL FREQUENCIES
C
      NSTART = NC1 - NNM + 1
      FACT=ONE/SQRT(AMU)
      DO I=NC1,NSTART,-1
         II=NC1+1-I
         FREQ(II)=SQRT(EIG(I)/AMU)
      END DO
C
C
C     IF ONLY SOME FREQUENCIES ARE CHOOSEN  FOR ANHARMONIC VIBRATIONAL
C     ANALYSIS THEN
C     IMODE ARRAY IS NUMBERING FREQ THAT WILL BE IMPROVED
C     FOR ANHARMONICITY, WHEREAS
C     JMODE ARRAY IS NUMBERING FREQUENCIES THAT ARE KEPT IN
C     HARMONIC APPROXIATION
C
      DO I=1,NNM
         JMODE(I)=0
      END DO
      IF (IMODE(1).NE.0) THEN
         NVIB=ISVIB
         DO I=1,NNM
            ISKIP=0
            DO J=1,ISVIB
              IF (IMODE(J).EQ.I) ISKIP=1
            END DO
            IF (ISKIP.EQ.0) THEN
              NVIB=NVIB+1
              JMODE(NVIB)=I
            END IF
         END DO
      END IF
      DO IM=1,NNM
         IF (IM.LE.ISVIB) THEN
             I=NC1-IMODE(IM)+1
         ELSE
             I=NC1-JMODE(IM)+1
         END IF
         MAP_LIST(I) = IM
         FREQ(IM)=SQRT(EIG(I)/AMU)
      END DO
C
C     PRINT OUT THE AMPLITUDES FOR ALL VIBRATIONAL FREQUENCIES
C
      IF(MASWRK) THEN
         IF(AMPX(1).EQ.ZERO) THEN
            WRITE(IW,*) 'AMP= ',AMP
         ELSE
            WRITE(IW,9000)
            ISTART = ISVIB
            DO I = 1, ISVIB
               ID = NC1 - IMODE(I) + 1
               WRITE(IW,9002) ID,AMPX(ISTART)
               ISTART = ISTART - 1
            END DO
         END IF
         IF(PETYP.EQ.'QFF   ') THEN
            IF(STPSZX(1).NE.ZERO) THEN
               WRITE(IW,9001)
               ISTART = ISVIB
               DO I = 1, ISVIB
                  ID = NC1 - IMODE(I) + 1
                  WRITE(IW,9002) ID,STPSZX(ISTART)
                  ISTART = ISTART - 1
               END DO
            END IF
         END IF
      END IF
C
C     WE MUST ENSURE THAT DIPOLE MOMENTS ARE ALWAYS COMPUTED, UNLESS
C     THE USER WANTS TO USE THE HARMONIC DIPOLE DERIVATIVE TENSOR.
C
C     MP2 RUNS MUST PARTIALLY EXECUTE THROUGH THE MP2 GRADIENT CODE
C     IN ORDER TO GET THE MP2 DENSITY MATRIX.
C     UNFORTUNATELY, PARALLEL RUNS DON'T HAVE A FAST CUTOUT YET, SO
C     FOR THIS WE GIVE SOME ADVICE ABOUT APPROXIMATING THE INTENSITIES,
C     AND THEN PULL THE PLUG TO FORCE USER TO MAKE THE CHOICE.
C
      IEMOM=1
      IF(NFRG.GT.0) IEMOM=0
      IF(DMDR) IEMOM=0
                     JOBTYP='ENERGY AND DIPOLE'
      IF(IEMOM.EQ.0) JOBTYP='ENERGY'
C
      IF(MPLEVL.GT.0  .AND.  IEMOM.EQ.1) THEN
                   MPPROP=0
         IF(MPDIP) MPPROP=1
                         JOBTYP='MP2 ENERGY AND MP2 DIPOLE'
         IF(MPPROP.EQ.0) JOBTYP='MP2 ENERGY AND SCF DIPOLE'
      END IF
C
C     START CLOCK
C
      CALL VSCFTM(0)
C
C     ----- OBTAIN ENERGY AND DIPOLE AT THE INPUT GEOMETRY -----
C     FULL PRINTOUT SHOULD BE ON AT THIS POINT, SO NO NEED TO FORCE
C     A DIPOLE MOMENT COMPUTATION BY AN EXPLICIT CALL TO ELMOMC.
C
      IF(READV) THEN
         IF(MASWRK) CALL SEQREW(IR)
         CALL FNDGRP(IR,' $VIBSCF',IEOF)
         IF(IEOF.EQ.1) THEN
            IF(MASWRK) WRITE(IW,9006)
            CALL ABRT
         END IF
         IF(MASWRK) READ(IR,8330) E,DMX,DMY,DMZ
         IF(MASWRK) WRITE(IW,9004) E,DMX,DMY,DMZ
      ELSE IF (.NOT.BLANK) THEN
         IF(MASWRK) WRITE(IW,9008) JOBTYP
         IF(INTCRD .AND. INTTYP.EQ.1) THEN
            INPUT=0
            CALL CONVRT2(PETYP,NCOUP,NGRID,ISVIB,NNM,NAT1,NC1,NZVAR,
     *                   NCOL,IMODE,COORD_ALL,C0,DX,FACT,DVEC,RQ,
     *                   DELCOR,VEC,NCOUNT1,NCOUNT2,PESALL,CHOOSEN,STP1,
     *                   ZMAT_CUR,ZMAT_OLD,INTTYP,NZMAT,IZMAT,ITYP,
     *                   ICONNCT,INPUT)
         END IF
C
C        CALCULATE ENERGY AND MAYBE DIPOLE FOR THE INPUT GEOMETRY
C        IF ONE RUNS IN GROUPS ONE HAS TO ENTER GROUPS HERE
C        SINCE THE TOTAL NUMBER OF NODES CAN BE LARGER
C        THEN THE NUMBER OF PROCESSORS ON WHICH THE CALCULATION
C        CAN BE PARALLELIZED
C
         IF(ISGDDI) THEN
            INITGDDI = .FALSE.
            CALL GDDI_SCOPE(DDI_GROUP)
            CALL GDDI_MASTID(MASTID)
            CALL GDDICOUNT(-1,LGROUP,MYJOB)
            DO IGR=1,NGROUPS
               CALL GDDICOUNT(0,LGROUP,MYJOB)
               IF (.NOT.MYJOB) GOTO 5
               IF(MYGROUP.EQ.0) CALL ENERGX
    5          CONTINUE
            END DO
            CALL GDDICOUNT(1,LGROUP,MYJOB)
            CALL GDDI_SCOPE(DDI_WORLD)
            INITGDDI = .TRUE.
         ELSE
            CALL ENERGX
         END IF
         CALL VSCFTM(1)
      END IF
      IF(MASWRK) WRITE(IRC,8000) ' $VIBSCF',PETYP,E,DMX,DMY,DMZ
C
      IF(.NOT.PESALL) CALL COUP_VIB(IMODE,CHOOSEN,GRADES,VEC,
     *                DVEC,INTCRD,ISVIB,NAT1,NC1,NZVAR,CUTOFF,NFRG)
      IF(.NOT.PESALL .AND. MASWRK) THEN
         WRITE(IW,*) 'MODE COUPLING WAS NOT CALCULATED FOR'
      END IF
      DO IM=1,ISVIB-1
         I=NC1-IMODE(IM)+1
         DO JM=IM+1,ISVIB
            J=NC1-IMODE(JM)+1
            IF(.NOT.PESALL .AND. .NOT.CHOOSEN(IM,JM)) THEN
                IF(MASWRK) THEN
                   WRITE(IW,*) 'MODE PAIR',I,J
                END IF
            END IF
         END DO
      END DO
C
      IF(EXETYP.EQ.CHECK .AND. INTCRD) GO TO 1000
      IF(EXETYP.EQ.CHECK) RETURN
C
C     SAVE POTENTIAL ENERGY, DIPOLE MOMENT AND COORDS AT EQUILIBRIUM
C
      E0  =E
      DMX0=DMX
      DMY0=DMY
      DMZ0=DMZ
      CALL DCOPY(3*NAT1,C,1,C0,1)
      CALL DDI_BCAST(810,'F',E0,1,MASTER)
      CALL DDI_BCAST(811,'F',DMX0,1,MASTER)
      CALL DDI_BCAST(812,'F',DMY0,1,MASTER)
      CALL DDI_BCAST(813,'F',DMZ0,1,MASTER)
      CALL DDI_BCAST(814,'F',C0,3*NAT1,MASTER)
C
C     DISPLACING ALONG NON-SYMMETRIC MODES DESTROYS POINT GROUP SYMMETRY
C     REDUCE OUTPUT TO A MINIMUM, AS WELL.
C
      CALL SYMOFF
C
      NPRINT=-5
      NPUNCH=0
      IEMOUT=0
      INITGDDI = .FALSE.
C
C     --------- RESTART --------
C
C     READ IN RESTART IF ISGDDI=.TRUE.,STORE IT IN DM_LIST AND
C     WRITE IT TO THE .IRC FILE
C
      IF(MASWRK .AND. READV) THEN
        DO IPOINT=1,NCOL
           READ(IR,8310) WORD,I,J,K
           CALL UPRCAS(WORD,5)
           IF(WORD.EQ.' $END' .OR.  WORD.EQ.'$END ') THEN
              READV=.FALSE.
              IEOF = 1
              GO TO 01
           END IF
           IF(READV) THEN
              NC = 1
              IF(J.GT.0) NC = 2
              IF(K.GT.0) NC = 3
              READ(IR,8320) IL,JL,KL
              READ(IR,8330) DE,DMX,DMY,DMZ
              IF(PETYP.EQ.'DIRECT') THEN
                IF(NC.EQ.1) THEN
                   IM = MAP_LIST(I)
                   DIAGV(IM,IL) = DE
                   DM1X(IM,IL) = DMX - DMX0
                   DM1Y(IM,IL) = DMY - DMY0
                   DM1Z(IM,IL) = DMZ - DMZ0
                   WRITE(IW,9012) IL,I,DIAGV(IM,IL),DMX,DMY,DMZ
                   ID_DM = (IM-1)*NGRID + IL
                   PES_COM(ID_DM) = 1
                   IF(ISGDDI) THEN
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         DE,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     CALL IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,
     *                            PETYP,DM_LIST,FIN_IRC)
                   ELSE
                     WRITE(IRC,8110) I,IL,DE,DMX,DMY,DMZ
                   END IF
                ELSE IF(NC.EQ.2) THEN
                   IM = MAP_LIST(I)
                   JM = MAP_LIST(J)
                   WRITE(IW,9022) IL,JL,I,J,DE,DMX,DMY,DMZ
                   COUPV(IM,JM,IL,JL) = DE
                   DM2X(IM,JM,IL,JL)  = DMX - DMX0
                   DM2Y(IM,JM,IL,JL)  = DMY - DMY0
                   DM2Z(IM,JM,IL,JL)  = DMZ - DMZ0
                   NPAIR = 0
                   DO IC = 1, IM-1
                      NPAIR = NPAIR + (ISVIB - IC)
                   END DO
                   NPAIR = NPAIR + (JM-IM-1)
                   ID_DM = ISVIB*NGRID +
     *                     NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                   PES_COM(ID_DM) = 1
                   IF(ISGDDI) THEN
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         DE,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     CALL IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,
     *                            PETYP,DM_LIST,FIN_IRC)
                   ELSE
                     WRITE(IRC,8120) I,J,IL,JL,DE,DMX,DMY,DMZ
                   END IF
                ELSE IF(NC.EQ.3) THEN
                   IM = MAP_LIST(I)
                   JM = MAP_LIST(J)
                   KM = MAP_LIST(K)
                   WRITE(IW,9032) IL,JL,KL,I,J,K,DE,DMX,DMY,DMZ
                   TRIPV(IM,JM,KM,IL,JL,KL) = DE
                   NTRIP = 0
                   DO IC = 1, IM-1
                     DO JC = IC+1, ISVIB-1
                        NTRIP = NTRIP + (ISVIB - JC)
                     END DO
                   END DO
                   DO JC = IM+1, JM-1
                      NTRIP = NTRIP + (ISVIB - JC)
                   END DO
                   NTRIP = NTRIP + (KM - JM - 1)
                   ID_DM = ISVIB*NGRID +
     *                      ISVIB*(ISVIB-1)/2*NGRID*NGRID +
     *                      NTRIP*NGRID*NGRID*NGRID +
     *                      (IL-1)*NGRID*NGRID + (JL-1)*NGRID + KL
                   PES_COM(ID_DM) = 1
                   IF(ISGDDI) THEN
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         DE,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     CALL IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,
     *                            PETYP,DM_LIST,FIN_IRC)
                   ELSE
                     WRITE(IRC,8130) I,J,K,IL,JL,KL,DE,DMX,DMY,DMZ
                   END IF
                END IF
              ELSE IF(PETYP.EQ.'QFF   ') THEN
                IF(NC.EQ.1) THEN
                   IM = MAP_LIST(I)
                   DE1(IL,IM)       = DE
                   DDPL1(IL*3-2,IM) = DMX
                   DDPL1(IL*3-1,IM) = DMY
                   DDPL1(IL*3  ,IM) = DMZ
                   ID_DM = (IM-1)*6 + IL
                   QFF_COM(ID_DM) = 1
                   IF(ISGDDI) THEN
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         DE,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     CALL IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,
     *                            PETYP,DM_LIST,FIN_IRC)
                   ELSE
                     WRITE(IRC,8210) I,IL,DE,DMX,DMY,DMZ
                   END IF
                ELSE IF(NC.EQ.2) THEN
                   IM = MAP_LIST(I)
                   JM = MAP_LIST(J)
                   NPAIR = JM - IM
                   IF(IM.GT.1) THEN
                      DO IC = 1, IM-1
                         NPAIR = NPAIR + (ISVIB - IC)
                      END DO
                   END IF
                   DE2(IL,NPAIR)       = DE
                   DDPL2(IL*3-2,NPAIR) = DMX
                   DDPL2(IL*3-1,NPAIR) = DMY
                   DDPL2(IL*3  ,NPAIR) = DMZ
                   ID_DM = ISVIB*6 + (NPAIR-1)*12 + IL
                   QFF_COM(ID_DM) = 1
                   IF(ISGDDI) THEN
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         DE,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     CALL IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,
     *                            PETYP,DM_LIST,FIN_IRC)
                   ELSE
                     WRITE(IRC,8220) I,J,IL,DE,DMX,DMY,DMZ
                   END IF
                END IF
              END IF
           END IF
         END DO
      END IF
   01 CONTINUE
      CALL DDI_SYNC(11000)
      CALL DDI_BCAST(820,'I',IEOF,1,MASTER)
      CALL DDI_BCAST(821,'I',PES_COM,NPOINT,MASTER)
      IF(ISGDDI) CALL DDI_BCAST(822,'I',FIN_IRC,NCOL,MASTER)
C
      IF(MASWRK) THEN
         ISTART = ISVIB
         DO IM = 1, ISVIB
            I  = NC1 - IMODE(IM) + 1
            IF(AMPX(1).NE.ZERO) THEN
               AMP = AMPX(ISTART)
               ISTART = ISTART - 1
            END IF
            QR1=TWO*(AMP+HALF)*PLANC*FREQ(IM)*UNITCONV
            QR2=EIG(I)/AMU
            QRANGE=SQRT(QR1/QR2)
            QMIN   = -QRANGE
            DQ(IM) = (TWO*QRANGE)/(NGRID-1)
            DO IL = 1, NGRID
               RQ(IM,IL) = QMIN + (IL-1)*DQ(IM)
            END DO
         END DO
      END IF
      CALL DDI_SYNC(11010)
      CALL DDI_BCAST(823,'F',DQ,NNM,MASTER)
      CALL DDI_BCAST(824,'F',RQ,NNM*NGRID,MASTER)
C
C     CALCULATE COORDINATES FOR ALL THE POINTS ON PES
C     IF INTTYP=2 AND INTCRD=.T.
C
      IF(PETYP.EQ.'DIRECT' .AND. NAT1.GT.0 .AND. INTCRD) THEN
         INPUT=1
         CALL CONVRT2(PETYP,NCOUP,NGRID,ISVIB,NNM,NAT1,NC1,NZVAR,NCOL,
     *                IMODE,COORD_ALL,C0,DX,FACT,DVEC,RQ,DELCOR,VEC,
     *                NCOUNT1,NCOUNT2,PESALL,CHOOSEN,STP1,ZMAT_CUR,
     *                ZMAT_OLD,INTTYP,NZMAT,IZMAT,ITYP,ICONNCT,INPUT)
         CALL DDI_BCAST(826,'F',COORD_ALL,NCOL*3*NAT1,MASTER)
      END IF
C
C     CONSTRUCT QFF
C
      IF(PETYP.EQ.'QFF   ') THEN
         CALL DDI_BCAST(825,'I',QFF_COM,NCOL,MASTER)
         CALL MKQFF(NC1,NAT1,NNM,NNM2,NCOUP,C0,EIG,VEC,STPSZ,E0,DMX0,
     *              DMY0,DMZ0,BLANK,IRC,Q,DE1,DE2,STP1,DDPL1,DDPL2,
     *              HII,TIII,UIIII,TIIJ,UIIIJ,UIIJJ,DGI,DHII,DTIII,
     *              DUIIII,IMODE,ISVIB,DM_LIST,DMPACK,CUR_IRC,DATA_IRC,
     *              QFF_COM,FIN_IRC,NROW_DM,NCOL,PETYP,MASTID,INTCRD,
     *              DX,DVEC,NZVAR,INTTYP,NCOUNT1,NCOUNT2,PESALL,
     *              CHOOSEN,STPSZX,COORD_ALL,NGRID,RQ,DELCOR,ZMAT_CUR,
     *              ZMAT_OLD,IZMAT,ITYP,ICONNCT,NZMAT)
      END IF
      I = 0
      J = 0
      K = 0
      IL = 0
      KL = 0
      JL = 0
      RQD1I=ZERO
      RQD2I=ZERO
      RQD2J=ZERO
      RQD3I=ZERO
      RQD3J=ZERO
      RQD3K=ZERO
C
C     ----- BEGIN COMPUTATION OF POTENTIAL ALONG NORMAL MODES -----
C
      IF (MASWRK) WRITE(IW,9010) NGRID, ISVIB
C
      IF(ISGDDI) THEN
         CALL GDDI_SCOPE(DDI_GROUP)
         CALL GDDI_MASTID(MASTID)
         CALL GDDICOUNT(-1,LGROUP,MYJOB)
      END IF
C
      DO IM=1,ISVIB
         I = NC1-IMODE(IM)+1
         DO IL=1, NGRID
C
C        COMPUTE COORDINATES, ENERGY AND DIPOLE
C
C
            ID_DM = (IM-1)*NGRID + IL
            IF(PES_COM(ID_DM).EQ.1) GOTO 10
            IF(ISGDDI) THEN
               CALL GDDICOUNT(0,LGROUP,MYJOB)
               IF (.NOT.MYJOB) GOTO 10
            END IF
            IF(NAT1.GT.0 .AND. PETYP.EQ.'DIRECT') THEN
               IF(.NOT.INTCRD) THEN
                  MN = 0
                  DO M = 1, NAT1
                     DO N = 1, 3
                        MN = MN + 1
                        DX(MN) = FACT*VEC(MN,I)*RQ(IM,IL)
                        C(N,M) = C0(N,M) + DX(MN)
C
                        DO ICNT = 1,NFRZ
                           IF(IFREEZ(ICNT).EQ.MN) C(N,M) = C0(N,M)
                        END DO
                     END DO
                  END DO
               ELSE IF(INTCRD) THEN
                     JQ = 1
                     DO M = 1,NAT1
                        C(1,M) = COORD_ALL(ID_DM,JQ)
                        C(2,M) = COORD_ALL(ID_DM,JQ+1)
                        C(3,M) = COORD_ALL(ID_DM,JQ+2)
                        JQ = JQ + 3
                     END DO
               END IF
            END IF
C
C           MOVE THE EFP FRAGMENTS: DIAGONAL
C
            IF(NFRG.GT.0 .AND. PETYP.EQ.'DIRECT') THEN
               MOVE = 1
               J = 0
               K = 0
               RQD1I = RQ(IM,IL)*FACT
               CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                     RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
            END IF
C
            IF(.NOT.BLANK) THEN
               IF(PETYP.EQ.'DIRECT') THEN
                  IF(MASWRK) THEN
                     WRITE(IW,9016) JOBTYP,IL,I
C
C       PRINT OUT THE COORDINATES OF AB INITIO ATOMS
C
                     IF(NAT1.GT.0) THEN
                        WRITE(IW,9050)
                        DO IAT = 1,NAT1
                            WRITE(IW,9060) IAT, ZAN(IAT),
     *                            C(1,IAT),C(2,IAT),C(3,IAT)
                        ENDDO
                     END IF
C
C      PRINT OUT THE COORDINATES OF EFP
C
                     IF(NFRG.GT.0) THEN
                        WRITE(IW,9210)
                        WRITE(IW,9220)
                        IAT=0
                        KMASS=0
                        DO 120 IFRG=1,NFRG
                          WRITE(IW,9230) FRGNAM(IFRG)
                          DO 110 IV=1,NMPTS(IFRG)
                            IAT=IAT+1
                            IF(FMASS(IV+KMASS).GT.ZERO) THEN
                              XF = EFC(1,IAT)
                              YF = EFC(2,IAT)
                              ZF = EFC(3,IAT)
                              WRITE(IW,9240) FRGNME(IAT),XF,YF,ZF
                            END IF
  110                     CONTINUE
                          KMASS=KMASS+NMPTS(IFRG)
  120                   CONTINUE
                     END IF
                  END IF
C
C                 CALCULATE ENERGY AND DIPOLE
C
                  CALL ENERGX
                  CALL VSCFTM(1)
                  IF(E.EQ.ZERO .AND. MASWRK) WRITE(IW,9100)
                  IF(E.EQ.ZERO) NUNCVG=NUNCVG+1
                  IF(IEMOM.EQ.1) CALL ELMOMC
C
                  DIAGV(IM,IL) = E - E0
                  DM1X(IM,IL)  = DMX - DMX0
                  DM1Y(IM,IL)  = DMY - DMY0
                  DM1Z(IM,IL)  = DMZ - DMZ0
C
               ELSE IF(PETYP.EQ.'QFF   ') THEN
                  QI=RQ(IM,IL)*FACT
                  CALL QFF1(NNM,IM,QI,VQFF1,DXQFF1,DYQFF1,DZQFF1,
     *                      HII,TIII,UIIII,DGI,DHII,DTIII,DUIIII)
                  DIAGV(IM,IL) = VQFF1
                  DM1X(IM,IL)  = DXQFF1
                  DM1Y(IM,IL)  = DYQFF1
                  DM1Z(IM,IL)  = DZQFF1
               ENDIF
            END IF
C
            IF(MASWRK .AND. PETYP.EQ.'DIRECT') THEN
               IF(.NOT.ISGDDI) THEN
                  WRITE(IRC,8110) I,IL,DIAGV(IM,IL),
     *                            DMX,DMY,DMZ
                  CALL FLSHBF(IRC)
               ELSE IF(ISGDDI) THEN
                  V = DIAGV(IM,IL)
                  CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                      V,DMX,DMY,DMZ)
                  CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                  IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *                             DATA_IRC,NROW_DM,NCOL,PETYP,
     *                             DM_LIST,FIN_IRC)
               END IF
            END IF
C
C           MOVE THE EFP FRAGMENTS BACK: DIAGONAL
C
            IF(NFRG.GT.0) THEN
               MOVE = 0
               J = 0
               K = 0
               RQD1I = RQ(IM,IL)*FACT
               CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                     RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
            END IF
C
   10 CONTINUE
         END DO
      END DO
C
      IF(ISGDDI) THEN
         CALL GDDICOUNT(1,LGROUP,MYJOB)
         CALL GDDI_SCOPE(DDI_MASTER)
         IF(MASWRK) THEN
            IF(PETYP.EQ.'DIRECT' .AND. MYGROUP.EQ.0) THEN
               CALL IRC_OUT(CUR_IRC,
     *            DATA_IRC,NROW_DM,NCOL,PETYP,DM_LIST,FIN_IRC)
            END IF
            CALL DDI_GSUMF(10000,DIAGV,NNM*NGRID)
            CALL DDI_GSUMF(10000,DM1X,NNM*NGRID)
            CALL DDI_GSUMF(10000,DM1Y,NNM*NGRID)
            CALL DDI_GSUMF(10000,DM1Z,NNM*NGRID)
         END IF
         CALL GDDI_SCOPE(DDI_WORLD)
      END IF
C
      IF (MASWRK) WRITE(IW,9018)
C
C     ----- OFF-DIAGONAL PAIR-WISE MODE COUPLING POTENTIAL -----
C
      IF (NCOUP.LE.1) GO TO 200
      IF (MASWRK) WRITE(IW,9020) NGRID,NGRID,(ISVIB*ISVIB-ISVIB)/2
C
      IF(ISGDDI) THEN
         CALL GDDI_SCOPE(DDI_GROUP)
         CALL GDDI_MASTID(MASTID)
         CALL GDDICOUNT(-1,LGROUP,MYJOB)
      END IF
C
      DO IM=1,ISVIB-1
         I=NC1-IMODE(IM)+1
         DO JM=IM+1,ISVIB
            J=NC1-IMODE(JM)+1
            IF(.NOT.PESALL .AND. .NOT.CHOOSEN(IM,JM)) GO TO 25
C
            DO IL=1, NGRID
                DO JL=1, NGRID
C
                NPAIR = 0
                DO IC = 1, IM-1
                   NPAIR = NPAIR + (ISVIB - IC)
                END DO
                NPAIR = NPAIR + (JM-IM-1)
                ID_DM = ISVIB*NGRID +
     *                  NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                IF(PES_COM(ID_DM).EQ.1) GOTO 20
                IF(ISGDDI) THEN
                   CALL GDDICOUNT(0,LGROUP,MYJOB)
                   IF (.NOT.MYJOB) GOTO 20
                END IF
                IF(NAT1.GT.0) THEN
                   IF(.NOT.INTCRD) THEN
                      MN=0
                      DO M=1, NAT1
                         DO N=1, 3
                            MN=MN+1
                            DX(MN)= FACT*VEC(MN,I)*RQ(IM,IL) +
     *                              FACT*VEC(MN,J)*RQ(JM,JL)
                            C(N,M) = C0(N,M) + DX(MN)
                         END DO
                      END DO
                   ELSE IF(INTCRD .AND. PETYP.EQ.'DIRECT') THEN
                      JQ = 1
                      DO M = 1,NAT1
                         C(1,M) = COORD_ALL(ID_DM,JQ)
                         C(2,M) = COORD_ALL(ID_DM,JQ+1)
                         C(3,M) = COORD_ALL(ID_DM,JQ+2)
                         JQ = JQ + 3
                      END DO
                   END IF
                END IF
C
C           MOVE THE EFP FRAGMENTS: 2-MODE COUPLING
C
                IF(NFRG.GT.0) THEN
                   MOVE = 1
                   K = 0
                   RQD2I=RQ(IM,IL)*FACT
                   RQD2J=RQ(JM,JL)*FACT
                   CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                         RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
                END IF
C
                IF(.NOT.BLANK) THEN
                   IF(PETYP.EQ.'DIRECT') THEN
                      IF(MASWRK) THEN
                         WRITE(IW,9026) JOBTYP,IL,JL,I,J
C
C       PRINT OUT THE COORDINATES OF AB INITIO ATOMS
C
                         IF(NAT1.GT.0) THEN
                            WRITE (IW,9050)
                            DO IAT = 1,NAT1
                              WRITE(IW,9060) IAT, ZAN(IAT),
     *                              C(1,IAT),C(2,IAT),C(3,IAT)
                            ENDDO
                         END IF
C
C      PRINT OUT THE COORDINATES OF FRAGMENT MULTIPOLE CENTERS
C
                         IF(NFRG.GT.0) THEN
                            WRITE(IW,9210)
                            WRITE(IW,9220)
                            IAT=0
                            KMASS=0
                            DO 140 IFRG=1,NFRG
                              WRITE(IW,9230) FRGNAM(IFRG)
                              DO 130 IV=1,NMPTS(IFRG)
                                IAT=IAT+1
                                IF(FMASS(IV+KMASS).GT.ZERO) THEN
                                   XF = EFC(1,IAT)
                                   YF = EFC(2,IAT)
                                   ZF = EFC(3,IAT)
                                   WRITE(IW,9240) FRGNME(IAT),XF,YF,ZF
                                END IF
  130                         CONTINUE
                              KMASS=KMASS+NMPTS(IFRG)
  140                       CONTINUE
                         END IF
                      END IF
C
                      CALL ENERGX
                      CALL VSCFTM(1)
                      IF(E.EQ.ZERO .AND. MASWRK) WRITE(IW,9100)
                      IF(E.EQ.ZERO) NUNCVG=NUNCVG+1
                      IF(IEMOM.EQ.1) CALL ELMOMC
C
                      COUPV(IM,JM,IL,JL)= E-E0
     *                                    -DIAGV(IM,IL)-DIAGV(JM,JL)
                      DM2X(IM,JM,IL,JL) = DMX - DMX0
                      DM2Y(IM,JM,IL,JL) = DMY - DMY0
                      DM2Z(IM,JM,IL,JL) = DMZ - DMZ0
                   ELSE IF(PETYP.EQ.'QFF   ') THEN
                      QI=RQ(IM,IL)*FACT
                      QJ=RQ(JM,JL)*FACT
                      IMM=IM
                      JMM=JM
                      CALL QFF2(ISVIB,NNM2,IMM,JMM,QI,QJ,
     *                          VQFF2,DXQFF2,DYQFF2,DZQFF2,
     *                          TIIJ,UIIIJ,UIIJJ)
                      COUPV(IM,JM,IL,JL)= VQFF2
                      DM2X(IM,JM,IL,JL) = DXQFF2
                      DM2Y(IM,JM,IL,JL) = DYQFF2
                      DM2Z(IM,JM,IL,JL) = DZQFF2
                   ENDIF
                END IF
C
                IF(MASWRK .AND. PETYP.EQ.'DIRECT') THEN
                   IF(.NOT.ISGDDI) THEN
                     WRITE(IRC,8120) I,J,IL,JL,
     *                               COUPV(IM,JM,IL,JL),DMX,DMY,DMZ
                     CALL FLSHBF(IRC)
                   ELSE IF(ISGDDI) THEN
                     V = COUPV(IM,JM,IL,JL)
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         V,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *                               DATA_IRC,NROW_DM,NCOL,PETYP,
     *                                DM_LIST,FIN_IRC)
                   END IF
                END IF
C
C           MOVE THE EFP FRAGMENTS BACK: 2-MODE COUPLING
C
            IF(NFRG.GT.0) THEN
               MOVE = 0
               K = 0
               CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                     RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
            END IF
C
   20 CONTINUE
               END DO
            END DO
   25 CONTINUE
         END DO
      END DO
C
      IF(ISGDDI) THEN
         CALL GDDICOUNT(1,LGROUP,MYJOB)
         CALL GDDI_SCOPE(DDI_MASTER)
         IF(MASWRK) THEN
            IF(PETYP.EQ.'DIRECT' .AND. MYGROUP.EQ.0) THEN
               CALL IRC_OUT(CUR_IRC,
     *            DATA_IRC,NROW_DM,NCOL,PETYP,DM_LIST,FIN_IRC)
            END IF
            CALL DDI_GSUMF(10000,COUPV,NNM3*NGRID3)
            CALL DDI_GSUMF(10000,DM2X,NNM3*NGRID3)
            CALL DDI_GSUMF(10000,DM2Y,NNM3*NGRID3)
            CALL DDI_GSUMF(10000,DM2Z,NNM3*NGRID3)
         END IF
         CALL GDDI_SCOPE(DDI_WORLD)
      END IF
C
      IF (MASWRK) WRITE(IW,9028)
C
C     3-BODY COUPLING POTENTIAL
C
  200 CONTINUE
      IF (NCOUP.LE.2) GOTO 300
      IF (MASWRK) WRITE(IW,9030)
C
      IF(ISGDDI) THEN
         CALL GDDI_SCOPE(DDI_GROUP)
         CALL GDDI_MASTID(MASTID)
         CALL GDDICOUNT(-1,LGROUP,MYJOB)
      END IF
C
C     DIPOLE WILL NOT BE USED, AND SO IS NOT COMPUTED
C
      IEMOM=0
      IF(MPLEVL.EQ.2) MPPROP=0
      DMX = ZERO
      DMY = ZERO
      DMZ = ZERO
C
      DO IM=1,ISVIB-2
        I=NC1-IMODE(IM)+1
        DO JM=IM+1,ISVIB-1
          J=NC1-IMODE(JM)+1
          DO KM=JM+1,ISVIB
            K=NC1-IMODE(KM)+1
C
            DO IL=1, NGRID
              DO JL=1, NGRID
                DO KL=1, NGRID
C
                   NTRIP = 0
                   DO IC = 1, IM-1
                      DO JC = IC+1, ISVIB-1
                        NTRIP = NTRIP + (ISVIB - JC)
                      END DO
                   END DO
                   DO JC = IM+1, JM-1
                      NTRIP = NTRIP + (ISVIB - JC)
                   END DO
                   NTRIP = NTRIP + (KM - JM - 1)
                   ID_DM = ISVIB*NGRID +
     *                      ISVIB*(ISVIB-1)/2*NGRID*NGRID +
     *                      NTRIP*NGRID*NGRID*NGRID +
     *                      (IL-1)*NGRID*NGRID + (JL-1)*NGRID + KL
                   IF(PES_COM(ID_DM).EQ.1) GOTO 30
                   IF(ISGDDI) THEN
                      CALL GDDICOUNT(0,LGROUP,MYJOB)
                      IF (.NOT.MYJOB) GOTO 30
                   END IF
C
                  IF(NAT1.GT.0) THEN
                     IF(.NOT.INTCRD) THEN
                        MN=0
                        DO M=1, NAT1
                           DO N=1, 3
                              MN=MN+1
                              DX(MN)= FACT*VEC(MN,I)*RQ(IM,IL) +
     *                                FACT*VEC(MN,J)*RQ(JM,JL) +
     *                                FACT*VEC(MN,K)*RQ(KM,KL)
                              C(N,M) = C0(N,M) + DX(MN)
                           END DO
                        END DO
                     END IF
                  END IF
C
C           MOVE THE EFP FRAGMENTS: 3-MODE COUPLING
C
                  IF(NFRG.GT.0) THEN
                     MOVE = 1
                     RQD3I=RQ(IM,IL)*FACT
                     RQD3J=RQ(JM,JL)*FACT
                     RQD3K=RQ(KM,KL)*FACT
                     CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                           RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
                  END IF
C
                  IF(.NOT.BLANK) THEN
                     IF(MASWRK) THEN
                        WRITE(IW,9036) IL,JL,KL,I,J,K
C
C       PRINT OUT THE COORDINATES OF AB INITIO ATOMS
C
                        IF(NAT1.GT.0) THEN
                           WRITE (IW,9050)
                           DO IAT = 1,NAT1
                             WRITE(IW,9060) IAT, ZAN(IAT),
     *                             C(1,IAT),C(2,IAT),C(3,IAT)
                           ENDDO
                        END IF
C
C      PRINT OUT THE COORDINATES OF FRAGMENT MULTIPOLE CENTERS
C
                        IF(NFRG.GT.0) THEN
                           WRITE(IW,9210)
                           WRITE(IW,9220)
                           IAT=0
                           KMASS=0
                           DO 160 IFRG=1,NFRG
                             WRITE(IW,9230) FRGNAM(IFRG)
                             DO 150 IV=1,NMPTS(IFRG)
                               IAT=IAT+1
                               IF(FMASS(IV+KMASS).GT.ZERO) THEN
                                  XF = EFC(1,IAT)
                                  YF = EFC(2,IAT)
                                  ZF = EFC(3,IAT)
                                  WRITE(IW,9240) FRGNME(IAT),XF,YF,ZF
                               END IF
  150                        CONTINUE
                             KMASS=KMASS+NMPTS(IFRG)
  160                      CONTINUE
                        END IF
                     END IF
C
                     CALL ENERGX
                     CALL VSCFTM(1)
                     IF(E.EQ.ZERO .AND. MASWRK) WRITE(IW,9100)
                     IF(E.EQ.ZERO) NUNCVG=NUNCVG+1
C
                     TRIPV(IM,JM,KM,IL,JL,KL) =
     *                     E - E0 -DIAGV(IM,IL) -COUPV(IM,JM,IL,JL)
     *                            -DIAGV(JM,JL) -COUPV(IM,KM,IL,KL)
     *                            -DIAGV(KM,KL) -COUPV(JM,KM,JL,KL)
                  END IF
C
                  IF(MASWRK .AND. PETYP.EQ.'DIRECT') THEN
                      IF(.NOT.ISGDDI) THEN
                      WRITE(IRC,8130) I,J,K,IL,JL,KL,
     *                                TRIPV(IM,JM,KM,IL,JL,KL),
     *                                DMX,DMY,DMZ
                      CALL FLSHBF(IRC)
                    ELSE IF(ISGDDI) THEN
                     V = TRIPV(IM,JM,KM,IL,JL,KL)
                     CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                         V,DMX,DMY,DMZ)
                     CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                 DMPACK,IDWORLD)
                     IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *                               DATA_IRC,NROW_DM,NCOL,PETYP,
     *                                DM_LIST,FIN_IRC)
                    END IF
                  END IF
C
C           MOVE THE EFP FRAGMENTS BACK: 3-MODE COUPLING
C
                  IF(NFRG.GT.0) THEN
                     MOVE = 0
                     CALL MOVEFP(MOVE,I,J,K,VEC,NAT1,NC1,
     *                           RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
                  END IF
C
   30 CONTINUE
                END DO
              END DO
            END DO
          END DO
        END DO
      END DO
C
      IF(ISGDDI) THEN
         CALL GDDICOUNT(1,LGROUP,MYJOB)
         CALL GDDI_SCOPE(DDI_MASTER)
         IF(MASWRK) THEN
            IF(PETYP.EQ.'DIRECT' .AND. MYGROUP.EQ.0) THEN
               CALL IRC_OUT(CUR_IRC,
     *            DATA_IRC,NROW_DM,NCOL,PETYP,DM_LIST,FIN_IRC)
            END IF
            CALL DDI_GSUMF(10000,TRIPV,NNM3*NNM*NGRID3*NGRID)
         END IF
         CALL GDDI_SCOPE(DDI_WORLD)
      END IF
C
      IF (MASWRK) WRITE(IW,9038)
C
C        RESTORE INITIAL GEOMETRY, ENERGY, COORDINATES, AND SYMMETRY.
C
  300 CONTINUE
      IF(MASWRK) WRITE(IRC,'(5A)') ' $END'
      E=E0
      DMX = DMX0
      DMY = DMY0
      DMZ = DMZ0
      CALL DCOPY(3*NAT1,C0,1,C,1)
      CALL SYMON
C
      IF(NUNCVG.GT.0  .AND.  MASWRK) WRITE(IW,9110) NUNCVG
 1000 CONTINUE
      IF(EXETYP.EQ.CHECK) RETURN
C
      RETURN
C
C                 OUTPUT OF RESTART DATA
 8000 FORMAT(A8,' PETYP= ',A/'   E0=',F20.10,'   DIPOLE=',3F14.8)
C
C                 WRITE IN .IRC FOR PETYP=DIRECT
 8110 FORMAT('MODE=',I4,/
     *       ' GRID=',I4,/
     *       '   DIAGV=',F20.10,' DIPOLE=',3F14.8)
 8120 FORMAT('MODE=',2I4,/
     *       ' GRID=',2I4,/
     *       '   COUPV=',F20.10,' DIPOLE=',3F14.8)
 8130 FORMAT('MODE=',3I4,/
     *       ' GRID=',3I4,/
     *       '   TRIPV=',F20.10,' DIPOLE=',3F14.8)
C
C                 WRITE IN .IRC FOR PETYP=QFF
 8210 FORMAT('MODE=',I4,/
     *       ' GRID=',I4,/
     *       '   DE1  =',F20.10,' DDPL1 =',3F14.8)
 8220 FORMAT('MODE=',2I4,/
     *       ' GRID=',I4,/
     *       '   DE2  =',F20.10,' DDPL2 =',3F14.8)
C
C                 READ IN RESTART DATA, MUST MATCH FORMATS JUST ABOVE
 8310 FORMAT(A5,3I4)
 8320 FORMAT(6X,3I4)
 8330 FORMAT(9X,F20.10,8X,3F14.8)
C
 9000 FORMAT(//1X,'VSCF INPUT AMPLITUDES ARE:'/
     *       5X,'      MODE',5X,' AMPLITUDE'/)
 9001 FORMAT(//1X,'VSCF INPUT QFF STEP SIZES ARE:'/
     *       5X,'      MODE',5X,' STEP SIZE'/)
 9002 FORMAT(5X,I10,5X,F10.2)
 9004 FORMAT(//1X,'AT INPUT GEOMETRY, THE RESTART DATA IS'/
     *       1X,'E0=',F20.10,' DIPOLE=',3F11.6)
 9006 FORMAT(1X,'*** ERROR, NO RESTART $VIBSCF PROVIDED ***'/
     *       1X,'ALTHOUGH YOUR INPUT FILE SAYS READV=.TRUE.')
 9008 FORMAT(//1X,'VSCF: ',A,' AT INPUT GEOMETRY'//)
C
C                    FORMATS FOR ONE MODE
 9010 FORMAT(//1X,'STARTING DIAGONAL POTENTIAL ON A GRID OF ',I3,
     *       ' POINTS FOR ',I3,' NORMAL MODES')
 9012 FORMAT(1X,'READ GRID POINT',I4,' FOR MODE',I4/
     *       1X,'DE=',F20.10,' DIPOLE=',3F11.6)
 9016 FORMAT(//1X,'VSCF: ',A,' FOR GRID POINT',I3,
     *          ' ALONG MODE',I3)
 9018 FORMAT(/1X,'DONE WITH DIAGONAL POTENTIAL')
C
C                    FORMATS FOR TWO MODES
 9020 FORMAT(//1X,'STARTING PAIR COUPLING POTENTIAL ON A SQUARE GRID'/
     *  ' OF',I3,' BY',I3,' POINTS FOR',I6,' PAIRS OF NORMAL MODES')
 9022 FORMAT(1X,'READ GRID POINTS ',2I4,' FOR MODES',2I4/
     *       1X,'DE=',F20.10,' DIPOLE=',3F11.6)
 9026 FORMAT(//1X,'VSCF: ',A,' FOR GRID POINTS',2I3,
     *          ' FOR MODE PAIR',2I3)
 9028 FORMAT(/1X,'DONE WITH PAIR COUPLING POTENTIAL')
C
C                    FORMATS FOR MODE TRIPLETS
 9030 FORMAT(//1X,'STARTING 3-BODY COUPLING POTENTIAL')
 9032 FORMAT(1X,'READ GRID POINTS ',3I4,' FOR MODES',3I4/
     *       1X,'DE=',F20.10,' DIPOLE=',3F11.6)
 9036 FORMAT(//1X,'VSCF: ENERGY FOR GRID POINTS',3I3,
     *          ' FOR MODE TRIPLET',3I3)
 9038 FORMAT(/1X,'DONE WITH 3-BODY COUPLING POTENTIAL')
C
C                   FORMATS FOR PRINTING AB INITIO COORDINATES
 9050 FORMAT(/1X,'ATOM',6X,'ATOMIC',22X,'COORDINATES (BOHR)'/
     *         11X,'CHARGE',9X,'X',19X,'Y',19X,'Z')
 9060 FORMAT(1X,I3,6X,F5.1,F17.10,2F20.10)
C
C                   FORMATS FOR WARNINGS
 9100 FORMAT(1X,4(2H*-),'*'/1X,'WARNING !'/1X,4(2H*-),'*'/
     *       1X,'SCF HAS NOT CONVERGED AT THIS VSCF POINT!')
 9110 FORMAT(////1X,51(1H*)/
     *       1X,'*     VSCF COMPUTATION MAY NOT BE TRUSTWORTHY   *'/
     *       1X,'* SINCE ',I5,' SCF COMPUTATIONS DID NOT CONVERGE *'/
     *       1X,51(1H*))
C
C                  FORMATS FOR PRINTING EFP COORDINATES
 9210 FORMAT(1X,'COORDINATES OF FRAGMENT MULTIPOLE CENTERS (BOHR)')
 9220 FORMAT(1X,'MULTIPOLE NAME',8X,'X',14X,'Y',14X,'Z'/
     *       1X,60(1H-))
 9230 FORMAT(1X,'FRAGNAME=',A6)
 9240 FORMAT(1X,A8,7X,3F15.10)
C
      END
C
C*MODULE VSCF    *DECK VSCFTM
      SUBROUTINE VSCFTM(IPAR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /TMVALS/ TI,TX,TIM
      SAVE NEVALS
C
      IF(IPAR.EQ.0) THEN
         NEVALS=0
         RETURN
      END IF
C
      NEVALS = NEVALS+1
      TNEED = 1.5D+00 * TIM/NEVALS
      IF((TIMLIM-TIM) .LT. TNEED) THEN
         IF(MASWRK) WRITE(IW,9000) TIMLIM/60.0D+00
         CALL ABRT
      END IF
      RETURN
C
 9000 FORMAT(//1X,'***** FAILURE TO FINISH VSCF CALCULATION *****'/
     *       1X,'NOT ENOUGH TIME TO DO ANOTHER POINT, TIMLIM=',F8.0,
     *          ' MINUTES'/
     *       1X,'PLEASE USE THE $VIBSCF GROUP TO RESTART THIS JOB.'//)
      END
C*MODULE VSCF    *DECK VSCFMP
      SUBROUTINE VSCFMP(FREQ,RQ,DQ,DIAGV,COUPV,ISTATE,TV,VSCF,VHF,
     *            E,EDIAG,ESCF,EMPPT,WAVE,ALLWAVE,VIRTWAVE,VIRTE,
     *            IVST,IPVT,XX,A,PHI,R,RR,G,V,H,EC,VEC,SCR,IA,GR,TEMP,
     *            TWAVE,EMP0,VMP,OVRLP,JVIRT,JREF,FRSCF,FRMP2,DEMP2,
     *            TRIPV,VCFCT,NC1,NNM,NGRID,NGRID2,NST,NVST,NCOUP,NMAX,
     *            IEXC,HCI,ECI,VECI,SCRCI,IACI,NDET,ICAS1,ICAS2,VDPT,
     *            NDET2,KREF,ICASX,ICAST,IMP,CASMIN,ECAS,EQDPT2,SFACT,
     *            VCI,CC,COM,ZMS,NPART,IMODE,JMODE,ISVIB,IEXC2,NNM4,
     *            ISVIB4,SOLVER)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DBG,VDPT,VCI,CASMIN
      PARAMETER (MXATM=2000, MXFRG=1050)
C
      DIMENSION DIAGV(NNM,NGRID),COUPV(NNM,NNM,NGRID,NGRID)
      DIMENSION TRIPV(NNM,NNM,NNM,NGRID,NGRID,NGRID)
      DIMENSION FREQ(NNM4),DQ(NNM),RQ(NNM,NGRID)
      DIMENSION TV(NGRID),VSCF(NNM,NGRID),VHF(NGRID),E(NNM)
      DIMENSION EDIAG(NNM4+1), ESCF(NNM4+1), EMPPT(NNM4+1)
      DIMENSION WAVE(NNM,NGRID),ALLWAVE(NNM4+1,NNM,NGRID)
      DIMENSION VIRTWAVE(NNM,NST,NGRID),VIRTE(NNM,NST)
      DIMENSION ISTATE(NNM,NNM4+1),IVST(NVST,NNM),IPVT(NGRID)
      DIMENSION XX(NGRID),A(NGRID),PHI(NGRID,NGRID)
      DIMENSION R(NGRID,NGRID),RR(NGRID,NGRID),G(NGRID,NGRID)
      DIMENSION V(NGRID,NGRID),H(NGRID2),EC(NGRID),VEC(NGRID,NGRID)
      DIMENSION GR(NGRID,NGRID),TEMP(NGRID),SCR(NGRID,8),IA(NGRID)
      DIMENSION TWAVE(NGRID),EMP0(NVST),VMP(NDET,NVST)
      DIMENSION JVIRT(NVST,NNM),JREF(NNM),OVRLP(NNM)
      DIMENSION FRSCF(NNM4),FRMP2(NNM4),DEMP2(NNM4)
      DIMENSION HCI(NDET2),ECI(NDET),KREF(NNM)
      DIMENSION VECI(NDET,NDET),SCRCI(NDET,8),IACI(NDET),IMP(NNM)
      DIMENSION ECAS(NNM4+1),EQDPT2(NNM4+1),ICAST(NDET,NNM)
      DIMENSION IMODE(3*MXATM+6*MXFRG),JMODE(NC1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      PARAMETER (EPS=1.0D-06, CM=2.194747D+05)
      PARAMETER (MXITER=100)
C
      DATA ORIG/8HORIG    /
C
      DBG = .FALSE.
C
C     SCALE PAIR COUPLING POTENTIAL IF NEEDED
C
      IF(MASWRK) WRITE(IW,9000)
      VCFCT1=ONE
      THISFACT=ONE
  500 FCT=VCFCT/VCFCT1
      THISFACT=THISFACT*FCT
      CALL VCLR(ECAS  ,1,NNM4+1)
      CALL VCLR(EQDPT2,1,NNM4+1)
      IF (NCOUP.GT.1) THEN
      DO I=1, ISVIB-1
         DO J=I+1, ISVIB
              DO L=1, NGRID
                 DO M=1, NGRID
C
                  IF ( (ABS(COUPV(I,J,L,M)).GE.DIAGV(I,L)).OR.
     *                 (ABS(COUPV(I,J,L,M)).GE.DIAGV(J,M)) )
     *               COUPV(I,J,L,M) = FCT*COUPV(I,J,L,M)
C
                  COUPV(J,I,M,L) = COUPV(I,J,L,M)
C
                 END DO
              END DO
         END DO
      END DO
      END IF
C
C     SCALE 3-BODY COUPLING POTENTIAL IF NEEDED
C
      IF (NCOUP.GT.2) THEN
      DO I=1, ISVIB-2
         DO J=I+1, ISVIB-1
            DO K=J+1,ISVIB
C
               DO L1=1, NGRID
               DO L2=1, NGRID
               DO L3=1, NGRID
C
                 IF ( (ABS(TRIPV(I,J,K,L1,L2,L3)).GE.DIAGV(I,L1)).OR.
     *                (ABS(TRIPV(I,J,K,L1,L2,L3)).GE.DIAGV(J,L2)).OR.
     *                (ABS(TRIPV(I,J,K,L1,L2,L3)).GE.DIAGV(K,L3)) )
     *            TRIPV(I,J,K,L1,L2,L3) = FCT*TRIPV(I,J,K,L1,L2,L3)
C
                  TRIPV(I,K,J,L1,L3,L2) = TRIPV(I,J,K,L1,L2,L3)
                  TRIPV(J,I,K,L2,L1,L3) = TRIPV(I,J,K,L1,L2,L3)
                  TRIPV(J,K,I,L2,L3,L1) = TRIPV(I,J,K,L1,L2,L3)
                  TRIPV(K,J,I,L3,L2,L1) = TRIPV(I,J,K,L1,L2,L3)
                  TRIPV(K,I,J,L3,L1,L2) = TRIPV(I,J,K,L1,L2,L3)
C
               END DO
               END DO
               END DO
            END DO
         END DO
      END DO
      END IF
C
C     START LOOP OVER STATES
C
      INDEX=0
      DO INDEX1=-1, ISVIB-1
         IF (INDEX1.EQ.0) GOTO 200
         DO INDEX2=INDEX1+1, ISVIB
         INDEX=INDEX+1
         IF (IEXC2.EQ.0 .AND. INDEX.GT.ISVIB+1) GOTO 200
C
C        ARRAY OF STATE INDICES
C
         IF(MASWRK) THEN
            IF(INDEX.EQ.1) WRITE(IW,9060)
            IF(INDEX.GT.1) THEN
               IF(INDEX.LE.ISVIB+1) THEN
                  WRITE(IW,9070) IEXC,INDEX2
               ELSE
                  WRITE(IW,9075) IEXC,INDEX2,IEXC2,INDEX1
               END IF
            END IF
         END IF
         DO I=1, ISVIB
            IF (INDEX2.EQ.0) THEN
               ISTATE(I,INDEX)=0
            ELSE IF (INDEX2.EQ.I) THEN
               ISTATE(I,INDEX)=IEXC
            ELSE
               ISTATE(I,INDEX)=0
            END IF
            IF (INDEX1.EQ.I) ISTATE(I,INDEX)=IEXC2
         END DO
         IF(MASWRK) WRITE(IW,9005) INDEX-1,(ISTATE(I,INDEX),I=1,ISVIB)
C
C        INITIALIZE THE WAVEFUNCTIONS
C
         CALL VCLR(WAVE,1,NNM*NGRID)
         CALL VCLR(VSCF,1,NNM*NGRID)
C
C        CALCULATE THE EIGENVALUES AND EIGENFUNCTIONS OF
C        DIAGONAL POTENTIAL
C
         SUME=ZERO
         DO MODE=1, ISVIB
            DO L=1, NGRID
               TV(L)=DIAGV(MODE,L)
            END DO
C
            MODEX = MODE
            CALL COLLOCAT(MODEX,TV,TE,WAVE,ALLWAVE,VIRTWAVE,VIRTE,
     *           IPVT,RQ,DQ,XX,A,PHI,R,RR,G,V,H,EC,VEC,SCR,IA,GR,
     *           TEMP,TWAVE,NNM,NGRID,NGRID2,NST,ISTATE,INDEX,NNM4)
C
            E(MODE)=TE
            SUME=SUME+TE
            IF (DBG .AND. MASWRK) WRITE(IW,*) MODE,ISTATE(MODE,INDEX),
     *                                                          TE*CM
         END DO
         EDIAG(INDEX)=SUME
         ETOT=SUME
         EMP1=ZERO
         IF (NCOUP.LE.1) GOTO 50
C
C        START SCF ITERATIONS
C
         IF(MASWRK) WRITE(IW,9007)
         ITER=0
 1000    CONTINUE
         ITER=ITER+1
         EPREV=ETOT
         IF (ITER.EQ.1) EPREV=ZERO
         ETOT=ZERO
         SUME=ZERO
         DO MODE=1, ISVIB
C
C           EFFECTIVE POTENTIAL
C
            MODEX = MODE
            CALL VEFFECT(MODEX,VHF,WAVE,DQ,COUPV,TRIPV,NNM,NGRID,NCOUP,
     *                   ISVIB)
C
            DO L=1, NGRID
               TV(L)=VHF(L)+DIAGV(MODE,L)
               VSCF(MODE,L)=VHF(L)
            END DO
C
            CALL COLLOCAT(MODEX,TV,TE,WAVE,ALLWAVE,VIRTWAVE,VIRTE,
     *           IPVT,RQ,DQ,XX,A,PHI,R,RR,G,V,H,EC,VEC,SCR,IA,GR,
     *           TEMP,TWAVE,NNM,NGRID,NGRID2,NST,ISTATE,INDEX,NNM4)
C
            IF (DBG .AND. MASWRK) WRITE(IW,*) MODE,ISTATE(MODE,INDEX),
     *                                                          TE*CM
C
            IF (TE.LT.ZERO) THEN
               VCFCT1=FCT
               VCFCT=VCFCT-1.0D-02
               IF (VCFCT.LT.2.0D-01) THEN
                  IF(MASWRK)
     *            WRITE(IW,*) 'SCALING FACTOR IS LESS THAN 0.2'
                  CALL ABRT
               END IF
               IF (MASWRK) WRITE(IW,9010) VCFCT
               GOTO 500
            ENDIF
            E(MODE)=TE
            SUME=SUME + TE
         END DO
         IF (DBG  .AND.  MASWRK) WRITE(IW,*) "SCF ENERGY    :", SUME*CM
C
C        CALCULATE THE SCF CORRECTION
C
         CALL SCFCORR (WAVE,EMP1,DQ,COUPV,TRIPV,NNM,NGRID,NCOUP,ISVIB)
C
         ETOT=SUME-EMP1
         IF(MASWRK) WRITE(IW,9200) ITER,SUME*CM,EMP1*CM,ETOT*CM
         IF (DBG  .AND.  MASWRK) WRITE(IW,*)
     *      "MP1 CORRECTION:",EMP1*CM,"TOTAL ENERGY:",ETOT*CM
C
         IF (ABS(ETOT-EPREV).GT.EPS .AND. ITER.LE.MXITER) GOTO 1000
C
C        EXIT SCF ITERATIONS
C
         IF (MASWRK) THEN
            IF (ITER.LE.MXITER) THEN
               WRITE(IW,9080) ITER
            ELSE
               WRITE(IW,9090) ITER
            END IF
         END IF
   50    CONTINUE
C
C        PUNCH VSCF WAVEFUNCTIONS
C
         IF (MASWRK) THEN
            IF (INDEX.EQ.1) THEN
               WRITE(IP,9020)
               WRITE(IP,9040) VCFCT
            ELSEIF (INDEX.LE.ISVIB+1) THEN
               WRITE(IP,9030) INDEX2
               WRITE(IP,9040) VCFCT
            ELSE
               WRITE(IP,9035) INDEX2, INDEX1
               WRITE(IP,9040) VCFCT
            END IF
            WRITE(IP,*)
         END IF
         SUME=ZERO
         DO MODE=1, ISVIB
            IF (MASWRK) WRITE(IP,*) MODE,ISTATE(MODE,INDEX),E(MODE)*CM
            DO L=1, NGRID
               IF (MASWRK) WRITE(IP,*) MODE,RQ(MODE,L),WAVE(MODE,L)
            END DO
            SUME=SUME+E(MODE)
            IF (MASWRK) WRITE(IP,*)
         END DO
C
         ETOT=SUME-EMP1
         ESCF(INDEX)=ETOT
         IF (NCOUP.LE.1) GOTO 100
C
C        MP2 CORRECTION
C
C         CALL VIRTSTATE(INDEX1,INDEX2,NNM,NMAX,NVST,IVST,NCOUP,IEXC,
C     *                 IEXC2,ISVIB)
C
         IQDPT = 1
         SMALL = SFACT
         IF(SOLVER.EQ.ORIG.OR.VDPT.OR.NCOUP.NE.2) THEN
C
            CALL VIRTSTATE(INDEX1,INDEX2,NNM,NMAX,NVST,IVST,NCOUP,IEXC,
     *                     IEXC2,ISVIB)
C
            CALL MPPTORIG(EMP2,EMP0,VIRTWAVE,VMP,VIRTE,COUPV,TRIPV,
     *                    VSCF,DQ,OVRLP,NNM,NGRID,NST,NVST,IVST,
     *                    ISTATE(1,INDEX),JREF,JVIRT,NCOUP,DBG,NDET,
     *                    IQDPT,SMALL,ISVIB)
C
         ELSE
            CALL MPPTLIAT(EMP2,VIRTWAVE,VIRTE,COUPV,
     *                    VSCF,DQ,NNM,NGRID,NST,
     *                    ISTATE(1,INDEX),JREF,
     *                    SMALL,ISVIB)
C
C       TODO: NEED TO CHECK IF VIRTCI REAL NEED IVST
            IF (VCI) THEN
                CALL VIRTSTATE(INDEX1,INDEX2,NNM,NMAX,NVST,IVST,NCOUP,
     *                         IEXC,IEXC2,ISVIB)
            END IF
C
         END IF
C
         ETOT=ETOT+EMP2
         EMPPT(INDEX)=ETOT
C
C     ---- VIRTUAL CI FOLLOWED BY DEGENERATE PERTURBATION THEORY -----
C
         IF((VDPT .OR. VCI) .AND. IEXC.EQ.1 .AND. IEXC2.EQ.0) THEN
         III = INDEX-1
         CALL VIRTCI(VIRTWAVE,VIRTE,IVST,NNM,NST,NGRID,DQ,III,
     *               NVST,HCI,COUPV,VSCF,ECI,SCRCI,VECI,IACI,
     *               ICAS1,ICAS2,VDPT,NDET,OVRLP,JVIRT,
     *               ISTATE(1,INDEX),JREF,KREF,NDET2,ICASX,ICAST,
     *               IMP,CASMIN,VMP,TRIPV,EMP0,ECAS,EQDPT2,WAVE,
     *               SMALL,DBG,IEXC,ISVIB,NNM4)
         END IF
C
  100    CONTINUE
C
         IF (MASWRK) THEN
                           WRITE(IW,9100) EDIAG(INDEX)*CM
            IF(NCOUP.GT.1) THEN
              IF(IMODE(1).NE.0) THEN
                           WRITE(IW,9105) ESCF(INDEX)*CM,
     *                                    EMPPT(INDEX)*CM
              ELSE
                           WRITE(IW,9110) ESCF(INDEX)*CM,
     *                                    ECAS(INDEX)*CM,
     *                                    EMPPT(INDEX)*CM,
     *                                    EQDPT2(INDEX)*CM
              END IF
           END IF
         END IF
       END DO
  200  CONTINUE
      END DO
      IF(MASWRK) WRITE(IW,9045) THISFACT
C
C     CALCULATE VIBRATIONAL FREQUENCIES IN CM-1 AND PRINT THEM OUT
C
      IF (IEXC2.EQ.0) THEN
         NSTATE=NNM+1
         CALL ENDIFF(FREQ,FRSCF,FRMP2,DEMP2,EDIAG,ESCF,EMPPT,
     *               ECAS,EQDPT2,NNM,NSTATE,NCOUP,IEXC,CC,COM,ZMS,
     *               NPART,ISVIB,IMODE,JMODE,NC1)
      ELSE
         NSTATE=NNM4+1
         CALL ENDIFFC(FREQ,FRSCF,FRMP2,DEMP2,EDIAG,ESCF,EMPPT,
     *                NNM,NSTATE,NCOUP,CC,COM,ZMS,
     *                NPART,ISVIB,NNM4,ISVIB4,ISTATE)
      END IF
C
      RETURN
C
 9000 FORMAT(//1X,62(1H-)/,1X,'VIBRATIONAL SELF-CONSISTENT FIELD',
     *       ' AND VIBRATIONAL CORRELATIONS',/1X,62(1H-))
 9005 FORMAT(/1X,23(1H-),/1X,'VIBRATIONAL STATE # ',I3,/1X,23(1H-),
     *       /8X,'CONFIGURATION: ',100(I1))
 9007 FORMAT(/2X,'ITERATION         E(SCF)           E(MP1)',
     *        '         E(TOTAL)')
 9010 FORMAT(/1X,'SCALING COUPLING POTENTIAL BY ',F4.2)
 9020 FORMAT(/1X,'WAVEFUNCTIONS FOR THE GROUND VIBRATIONAL STATE')
 9030 FORMAT(/1X,'WAVEFUNCTIONS FOR THE EXCITED STATE OF MODE',I3)
 9035 FORMAT(/1X,'WAVEFUNCTIONS FOR THE COMBINATION OF EXCITATIONS',
     *           ' OF MODES',2(I3))
 9040 FORMAT(1X,'(SCALING FACTOR FOR COUPLING POTENTIAL ',F4.2,')')
 9045 FORMAT(/1X,'(CUMULATIVE SCALING FACTOR FOR COUPLING POTENTIAL ',
     *       F4.2,')')
 9060 FORMAT(/1X,'SOLVING VSCF FOR VIBRATIONAL GROUND STATE')
 9070 FORMAT(/1X,'SOLVING VSCF FOR',I3,' QUANTA IN MODE',I4)
 9075 FORMAT(/1X,'SOLVING VSCF FOR',I3,' QUANTA IN MODE',I4, ' AND',
     *                              I3,' QUANTA IN MODE',I4)
 9080 FORMAT(1X,'VSCF CONVERGED IN',I5,' ITERATIONS')
 9090 FORMAT(1X,'*** VSCF DID NOT CONVERGE *** AFTER',I5,' ITERATIONS')
 9100 FORMAT(/1X,'E(DIAG)=',F12.2,' (WITHOUT MODE COUPLING)')
 9105 FORMAT(1X,'E(VSCF)=',F12.2/1X,'E(VMP2)=',F12.2)
 9110 FORMAT(1X,'E(VSCF)=',F12.2/1X,'E(VCI )=',F12.2,
     *      /1X,'E(VMP2)=',F12.2/1X,'E(DPT2)=',F12.2)
 9200 FORMAT(5X,I3,2X,4(7X,F10.2))
C
      END
C
C*MODULE VSCF    *DECK COLLOCAT
      SUBROUTINE COLLOCAT(MODE,TV,TE,WAVE,ALLWAVE,VIRTWAVE,VIRTE,
     *                IPVT,X,DX,XX,A,PHI,R,RR,G,V,H,E,VEC,SCR,IA,
     *                GR,TEMP,TWAVE,NM,N,N2,NST,ISTATE,INDEX,NM4)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION ISTATE(NM,NM4+1)
      DIMENSION X(NM,N),DX(NM)
      DIMENSION WAVE(NM,N),ALLWAVE(NM4+1,NM,N)
      DIMENSION TV(N),VIRTWAVE(NM,NST,N),VIRTE(NM,NST)
      DIMENSION IPVT(N)
      DIMENSION XX(N),A(N),PHI(N,N)
      DIMENSION R(N,N),RR(N,N),G(N,N),V(N,N)
      DIMENSION H(N2),E(N),VEC(N,N)
      DIMENSION SCR(N,8),IA(N)
      DIMENSION GR(N,N),TEMP(N),DET(2)
      DIMENSION TWAVE(N)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, FOUR=4.0D+00)
      PARAMETER (TWO=2.0D+00, HALF=0.5D+00, QTR=0.25D+00)
      PARAMETER (C=0.7D+00)
C
C     THIS ROUTINE USES THE COLLOCATIONS METHOD TO GENERATE
C     THE EIGENVALUES AND WAVEFUNCTIONS:  E, WAVE
C     REF. CPL V153, 1988 PG.98   YANG & PEET
C
      PI=FOUR*ATAN(ONE)
C
C     NORMAL COORDINATE ON A GRID
C
      DO L=1, N
         XX(L)=X(MODE,L)
      END DO
C
C     GENERATE THE PARAMETERS A'S
C
      A(1)=(C**2)/((XX(2)-XX(1))**2)
      DO I=2, N-1
         A(I)=(4*(C**2))/((XX(I+1)-XX(I-1))**2)
      END DO
      A(N)=(C**2)/((XX(N)-XX(N-1))**2)
C
C     GENERATE N GAUSSIAN WAVEFUNCTIONS R(I,J)
C
      DO I=1, N
         FAC=(TWO*A(I)/PI)**QTR
         DO J=1, N
            R(I,J)=FAC*EXP(-A(I)*(XX(J)-XX(I))**2)
            IF (ABS(R(I,J)).LT.1.0D-99) R(I,J)=ZERO
            RR(I,J)=R(I,J)
         END DO
      END DO
C
C     GENERATE THE POTENTIAL MATRIX V(I,J)
C
      DO I=1, N
         DO J=1, N
            V(I,J)=ZERO
            IF (J.EQ.I) V(I,J)=TV(I)
         END DO
      END DO
C
C     GENERATE THE 2ND ORDER DERIVATIVE OF WAVEFUNCTIONS
C
      DO I=1, N
         DO J=1, N
            G(I,J)=ZERO
            DR2=(4*(A(I)**2)*((XX(J)-XX(I))**2))-2*A(I)
            G(I,J)=(-HALF)*DR2*R(I,J)
            IF (ABS(G(I,J)).LT.1.0D-99) G(I,J)=ZERO
         END DO
      END DO
C
C     GENERATE THE INVERSE MATRIX OF R(I,J):  R-1
C
      INFO=0
      CALL DGEFA(R,N,N,IPVT,INFO)
C
      IF(INFO.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'MATRIX R IS SINGULAR'
         CALL ABRT
      END IF
C
C     OPTIONS FOR DGEDI ROUTINE
C       JOB = 11 BOTH DETERMINANT AND INVERSE
C       JOB = 01 INVERSE ONLY
C       JOB = 10 DETERMINANT ONLY
C
      JOB=01
      CALL DGEDI(R,N,N,IPVT,DET,TEMP,JOB)
C
C     MULTIPLY KINETIC ENERGY MATRIX G AND INVERSE R
C
      CALL MRARBR(G,N,N,N,R,N,N,GR,N)
C
C     GENERATE THE HAMILTONIAN TO BE DIAGONALIZED : GR-1 + V
C     (AVERAGE THE OFF-DIAGONAL TERMS AND PUT IN TRIANGULAR
C      FORM FOR DIAGONALIZATION)
C
      IJ=0
      DO I=1, N
        DO J=1, I
           IJ=IJ+1
           IF(I.EQ.J) THEN
              H(IJ)=GR(I,J)+V(I,J)
           ELSE
              H(IJ)=(GR(I,J)+GR(J,I))/TWO
           ENDIF
        END DO
      END DO
C
C     DIAGONALIZE THE PSEDOSPECTRAL MATRIX FOR EIGENVALUES AND VECTORS
C
      IERR = 0
      CALL GLDIAG(N,N,N,H,SCR,E,VEC,IERR,IA)
      IF (IERR .NE. 0) CALL ABRT
C
C     REARRANGE INTO DESCENDING ORDER
C
      CALL EIGSRT(E,VEC,N,N)
C
C     FIND WAVEFUNCTIONS
C
      DO I=1, N
         DO J=1, N
            PHI(I,J)=VEC(J,I)*RR(J,J)
         END DO
      END DO
C
      DO I=1, N
         IF (I.GE.N-NST+1) THEN
            IST=N-I+1
C
            AREA=ZERO
            DO J=1, N/2
               AREA=AREA+PHI(I,J)
            END DO
C
            IF ((MOD(IST,2).EQ.1).AND.(AREA.LT.ZERO)) THEN
               DO J=1, N
                  TEMP(J)=-PHI(I,J)
               END DO
            ELSE IF ((MOD(IST,2).EQ.0).AND.(AREA.GT.ZERO)) THEN
               DO J=1, N
                  TEMP(J)=-PHI(I,J)
               END DO
            ELSE
               DO J=1, N
                  TEMP(J)=PHI(I,J)
               END DO
            END IF
C
            CALL NORM (MODE,TEMP,DX,NM,N)
C
            DO J=1, N
               VIRTWAVE(MODE,IST,J)=TEMP(J)
            END DO
            VIRTE(MODE,IST)=E(I)
C
            IF (I.EQ.(N-ISTATE(MODE,INDEX))) THEN
               DO J=1, N
                 TWAVE(J)=TEMP(J)
               END DO
               TE=E(I)
            END IF
         END IF
      END DO
C
      DO L=1, N
         WAVE(MODE,L)=TWAVE(L)
         ALLWAVE(INDEX,MODE,L)=TWAVE(L)
      END DO
C
      RETURN
      END
C*MODULE VSCF    *DECK NORM
      SUBROUTINE NORM (MODE,TWAVE,DX,NM,N)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     THIS ROUTINE NORMALIZES THE WAVEFUNCTION OBTAINED FROM THE
C     COLLOCATION GRID POINTS FOR (I) TH MODE.
C
      DIMENSION DX(NM)
      DIMENSION TWAVE(N)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C     CALCULATE THE NORMALIZATION CONSTANTS USING THE GRID WAVEFUNCTIONS
C
      WNORM=ZERO
      DO M=1, N
         TEMP=DX(MODE)*(TWAVE(M)**2)
         WNORM=WNORM+TEMP
      END DO
C
C     NORMALIZATION OF THE WAVEFUNCTIONS ON THE GRID POINTS
C
      DO M=1, N
         TWAVE(M)=(ONE/SQRT(WNORM))*TWAVE(M)
      END DO
C
C     CHECK FOR NORMALIZATION:
C
      AREA=ZERO
      DO L=1, N
         AREA=AREA+DX(MODE)*(TWAVE(L)**2)
      END DO
C
      RETURN
      END
C*MODULE VSCF    *DECK VEFFECT
      SUBROUTINE VEFFECT (MODE,VSCF,WAVE,DX,VC,VTR,NM,N,NCOUP,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION VSCF(N)
      DIMENSION WAVE(NM,N)
      DIMENSION DX(NM)
      DIMENSION VC(NM,NM,N,N)
      DIMENSION VTR(NM,NM,NM,N,N,N)
C
      PARAMETER (ZERO=0.0D+00)
C
C     THIS ROUTINE CALCULATES THE SCF AVERAGED POTENTIAL
C     ON THE GH-QUADRATURE GRID POINTS FOR (I) TH MODE.
C
      DO L=1, N
         VSCF(L)=ZERO
         DO J=1, ISVIB
            IF (J.NE.MODE) THEN
               CALL SCFAVG(SUM,WAVE,DX,VC,MODE,J,L,NM,N)
               VSCF(L)=VSCF(L)+SUM
            END IF
         END DO
      END DO
      IF (NCOUP.LE.2) GOTO 100
C
      DO L=1, N
         DO J=1, ISVIB-1
            DO K=J+1, ISVIB
              IF (J.NE.MODE .AND. K.NE.MODE) THEN
                 CALL SCFAVGT(SUM,WAVE,DX,VTR,MODE,J,K,L,NM,N)
                 VSCF(L)=VSCF(L)+SUM
              END IF
            END DO
         END DO
      END DO
C
  100 CONTINUE
      RETURN
      END
C*MODULE VSCF    *DECK SCFAVG
      SUBROUTINE SCFAVG(SUM,WAVE,DX,VC,I,J,L,NM,N)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     CALCULATE THE VSCF(I,L) FOR MODE I AND PT. L
C
      DIMENSION DX(NM)
      DIMENSION VC(NM,NM,N,N)
      DIMENSION WAVE(NM,N)
C
      PARAMETER (ZERO=0.0D+00)
C
      SUM=ZERO
      DO M=1, N
         TEMP1=DX(J)*VC(I,J,L,M)*(WAVE(J,M)**2)
         SUM=SUM+TEMP1
      END DO
C
      RETURN
      END
C*MODULE VSCF    *DECK SCFAVGT
      SUBROUTINE SCFAVGT(SUM,WAVE,DX,VTR,I,J,K,L,NM,N)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     CALCULATE THE VSCF(I,L) FOR MODE I AND PT. L
C
      DIMENSION DX(NM)
      DIMENSION VTR(NM,NM,NM,N,N,N)
      DIMENSION WAVE(NM,N)
C
      PARAMETER (ZERO=0.0D+00)
C
      SUM=ZERO
      DO M1=1, N
         DO M2=1, N
            TEMP1=DX(J)*DX(K)*VTR(I,J,K,L,M1,M2)*
     *                        (WAVE(J,M1)**2)*(WAVE(K,M2)**2)
            SUM=SUM+TEMP1
         END DO
      END DO
C
      RETURN
      END
C*MODULE VSCF    *DECK SCFCORR
      SUBROUTINE SCFCORR (WAVE,EMP1,DX,VC,VTR,NM,N,NCOUP,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     THIS ROUTINE CALCULATES THE SCF CORRECTION
C     ON THE GH-QUADRATURE GRID POINTS.
C
      DIMENSION DX(NM)
      DIMENSION VC(NM,NM,N,N)
      DIMENSION VTR(NM,NM,NM,N,N,N)
      DIMENSION WAVE(NM,N)
C
      PARAMETER (ZERO=0.0D+00)
C
      EMP1=ZERO
      DO I=1, ISVIB-1
         DO J=I+1, ISVIB
            DO L=1, N
              DO M=1, N
               SUM=DX(I)*DX(J)*VC(I,J,L,M)*(WAVE(I,L)**2)*(WAVE(J,M)**2)
               EMP1=EMP1+SUM
              END DO
            END DO
         END DO
      END DO
      IF (NCOUP.LE.2) GOTO 100
C
      EMP1T=ZERO
      DO I=1, ISVIB-2
         DO J=I+1, ISVIB-1
            DO K=J+1, ISVIB
               DO L1=1, N
               DO L2=1, N
               DO L3=1, N
                  SUM=DX(I)*DX(J)*DX(K)*VTR(I,J,K,L1,L2,L3)*
     *                (WAVE(I,L1)**2)*(WAVE(J,L2)**2)*(WAVE(K,L3)**2)
                  EMP1T=EMP1T+SUM
               END DO
               END DO
               END DO
            END DO
         END DO
      END DO
      EMP1 = EMP1 + EMP1T*2.0D+00
C
  100 CONTINUE
      RETURN
      END
C
C*MODULE VSCF    *DECK VIRTSTATE
      SUBROUTINE VIRTSTATE (KSTATE,KSTATE2,NM,NMAX,NVST,IVST,NCOUP,
     *                                             IEXC,IEXC2,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IVST(NVST,NM)
C
      NOST=0
C
C     GENERATE SINGLE EXCITATIONS
C
      DO ISTATE=0, NMAX
        DO I=1, ISVIB
          NOST=NOST+1
          DO MODE=1, ISVIB
            IF (MODE.EQ.I) THEN
              IVST(NOST,MODE)=ISTATE
            ELSE
              IVST(NOST,MODE)=0
            END IF
          END DO
          IF (NOST.EQ.1) GO TO 1000
        END DO
1000  END DO
C
C     GENERATE DOUBLE EXCITATIONS
C     LIAT PELE INVERTED THE MODE LOOP PAIR WITH THE STATE LOOP PAIR.
C     NOTE: THE ORDER HERE MUST MATCH THE ORDER DEFINED IN -STATEIND-
C
      DO I=1, ISVIB-1
         DO J=I+1, ISVIB
            DO JSTATE=1, NMAX
               DO ISTATE=1, NMAX
                  NOST=NOST+1
                  DO MODE=1, ISVIB
                     IF (MODE.EQ.I) THEN
                        IVST(NOST,MODE)=ISTATE
                     ELSE IF (MODE.EQ.J) THEN
                        IVST(NOST,MODE)=JSTATE
                     ELSE IF (MODE.EQ.KSTATE) THEN
                        IVST(NOST,MODE)=IEXC2
                     ELSE IF (MODE.EQ.KSTATE2) THEN
                        IVST(NOST,MODE)=IEXC
                     ELSE
                        IVST(NOST,MODE)=0
                     END IF
                  END DO
               END DO
            END DO
         END DO
      END DO
      IF (NCOUP.LE.2) GOTO 2000
C
C     TRIPLE EXCITATIONS IF 3BODY COUPLING IS INCLUDED
C
      DO ISTATE=1, NMAX
         DO JSTATE=1, NMAX
            DO LSTATE=1, NMAX
C              ISUM=ISTATE+JSTATE+LSTATE
               DO I=1, ISVIB-2
                  DO J=I+1, ISVIB-1
                     DO L=J+1, ISVIB
                        NOST=NOST+1
                        DO MODE=1, ISVIB
                           IF (MODE.EQ.I) THEN
                              IVST(NOST,MODE)=ISTATE
                           ELSE IF (MODE.EQ.J) THEN
                              IVST(NOST,MODE)=JSTATE
                           ELSE IF (MODE.EQ.L) THEN
                              IVST(NOST,MODE)=LSTATE
                           ELSE IF (MODE.EQ.KSTATE) THEN
                              IVST(NOST,MODE)=IEXC2
                           ELSE IF (MODE.EQ.KSTATE2) THEN
                              IVST(NOST,MODE)=IEXC
                           ELSE
                              IVST(NOST,MODE)=0
                           END IF
                        END DO
                     END DO
                  END DO
               END DO
            END DO
         END DO
      END DO
C
2000  CONTINUE
      RETURN
      END
C
C*MODULE VSCF    *DECK MPPTORIG
      SUBROUTINE MPPTORIG(EMP2,EMP0,WAVE,V,E,VC,VTR,VSCF,DX,OVRLP,
     *                    NM,N,NST,NVST,IVST,IREF,JREF,JVIRT,NCOUP,DBG,
     *                    NDET,IQDPT,SMALL,ISVIB)
C
C     THIS PROGRAM CALCULATES THE 2ND ORDER MPPT ENERGY CORRECTION.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,DBG
C
      DIMENSION WAVE(NM,NST,N)
      DIMENSION VC(NM,NM,N,N)
      DIMENSION VTR(NM,NM,NM,N,N,N)
      DIMENSION VSCF(NM,N)
      DIMENSION E(NM,NST)
      DIMENSION DX(NM)
      DIMENSION IREF(NM)
      DIMENSION IVST(NVST,NM)
      DIMENSION JVIRT(NVST,NM),JREF(NM)
      DIMENSION EMP0(NVST)
      DIMENSION V(NDET,NVST)
      DIMENSION OVRLP(NM)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     PARAMETER (ZERO=0.0D+00, SMALL=5.0D-03, CM=2.194747D+05)
      PARAMETER (ZERO=0.0D+00,                CM=2.194747D+05)
C
C     IF(MASWRK) WRITE(IW,9000)
C9000 FORMAT(1X,'COMPUTING THE VMP2 CORRECTION TO VSCF ENERGY')
C
C     REFERENCE STATE
C
      DO I=1, ISVIB
         IREF(I)=IREF(I)+1
      END DO
C
C     COMPARE VIRTUAL STATES WITH THE REFERENCE STATE
C
       INDEX=0
       DO J=1, NVST
          ISUM=0
          EMP0(J)=ZERO
          INDEX=INDEX+1
          DO I=1, ISVIB
             JREF(I)=IVST(INDEX,I)
             JVIRT(J,I)=JREF(I)+1
             EMP0(J)=EMP0(J)+E(I,JVIRT(J,I))
             IF (IREF(I).EQ.JVIRT(J,I)) ISUM=ISUM+1
           END DO
          IF (ISUM.EQ.ISVIB) ISTATE=J
        END DO
C
C     DEBUG
C      WRITE(*,*) 'E(1,1)',E(1,1)
C      WRITE(*,*) 'ISVIB ', ISVIB ,'NM ', NM
C      WRITE(*,*) 'EMP0(I) ',EMP0(ISTATE)
C      WRITE(*,*) 'SMALL' ,SMALL
C
C
C
C      GENERATE THE OVERLAP BETWEEN TWO STATES I AND J
C
       DO J=1, NVST
         V(IQDPT,J)=ZERO
         DO JMODE=1, ISVIB
           JREF(JMODE)=JVIRT(J,JMODE)
         END DO
C
         DO K=1, ISVIB-1
            DO L=K+1, ISVIB
               CALL AVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,OVRLP,NM,N,NST,
     *                  ISVIB)
               V(IQDPT,J)=V(IQDPT,J)+SUM
            END DO
         END DO
         IF (NCOUP.GT.2) THEN
            DO L1=1, ISVIB-2
              DO L2=L1+1, ISVIB-1
                DO L3=L2+1, ISVIB
                   CALL AVG3(SUM3,IREF,JREF,L1,L2,L3,DX,WAVE,VTR,
     *             OVRLP,NM,N,NST,ISVIB)
                   V(IQDPT,J)=V(IQDPT,J)+SUM3
                END DO
              END DO
            END DO
         END IF
C
C
       DO K=1, ISVIB
            CALL AVGHF(SUM2,IREF,JREF,K,DX,WAVE,VSCF,OVRLP,
     *                 NM,N,NST,ISVIB)
            V(IQDPT,J)=V(IQDPT,J)-SUM2
C
         END DO
C
C---      CALL STPRINT2 (J,JREF,EMP0(J),V(IQDPT,J),NM)
C
        END DO
C
C      ---- BAIL OUT IF ONLY NEED INTEGRALS. -----
C
       IF(IQDPT.GE.2) RETURN
C
C      1ST ORDER ENERGY CORRECTION:
C
       EMP1=V(IQDPT,ISTATE)
       IF (DBG  .AND.  MASWRK) WRITE(IW,9010) ISTATE,EMP1*CM
C
C      2ND ORDER ENERGY CORRECTION:
C
       NKEEP=0
       EMP2=ZERO
       DO J=1, NVST    !  STATE INDEX
         IF (J.NE.ISTATE) THEN
            SUMV=V(IQDPT,J)*V(IQDPT,J)
            SUME=EMP0(ISTATE)-EMP0(J)
            IF (ABS(SUME).GT.SMALL) THEN
            EMP2=EMP2+(SUMV/SUME)
            END IF
C
C      TO CUT DOWN ON THE COMPUTATION OF COEFFICIENTS FOR
C      2ND ORDER WAVEFUNCTION CORRECTION, SELECT ONLY THE STATES
C      WHICH CONTRIBUTE MOST TO THE ENERGY CORRECTION AND USE THESE
C      STATES AS THE BASIS.
C
            IF (ABS(SUMV/SUME).GT.1.0D-08) NKEEP=NKEEP+1
         END IF
       END DO
C
      DO I=1, ISVIB
         IREF(I)=IREF(I)-1
      END DO
C
      IF (MASWRK) THEN
C            IF(DBG) WRITE(IW,9020) ISTATE,EMP2*CM
        WRITE(IW,9020) ISTATE,EMP2
        WRITE(IW,9030) NVST
        WRITE(IW,9040) NKEEP
      ENDIF
      RETURN
C
 9010 FORMAT(1X,'MP1 (',I4,') :',E14.7)
 9020 FORMAT(1X,'MP2 (',I4,') :',E14.7)
 9030 FORMAT(1X,'NUMBER OF VIRTUAL STATES IS ',I6)
 9040 FORMAT(1X,'NUMBER OF SELECTED STATES IS',I6)
      END
C
C*MODULE VSCF    *DECK MPPTLIAT
      SUBROUTINE MPPTLIAT(EMP2,WAVE,E,VC,VSCF,DX,NM,N,NST,
     *                    IREF,JREF,SMALL,ISVIB)
C
C     THIS PROGRAM CALCULATES THE 2ND ORDER MPPT ENERGY CORRECTION.
C     ASSUME NCOUP == 2
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION WAVE(NM,NST,N)
      DIMENSION VC(NM,NM,N,N)
      DIMENSION VSCF(NM,N)
      DIMENSION E(NM,NST)
      DIMENSION DX(NM)
      DIMENSION IREF(NM),JREF(NM)
C
      PARAMETER (ZERO=0.0D+00)
C
C     THIS PROGRAM CALCULATES THE 2ND ORDER MPPT ENERGY CORRECTION.
C
C     REFERENCE STATE
C
      NMAX = NST-1
C
      DO I=1, ISVIB
         IREF(I)=IREF(I)+1
         JREF(I)=IREF(I)
      END DO
C
C     THE ENRGY OF IREF
C
      EMP0_I=ZERO
      DO I=1, ISVIB
          EMP0_I=EMP0_I+E(I,IREF(I))
      END DO
C
C       INIT
      EMP2=ZERO
C
C
C  2ND ORDER ENERGY CORRECTION.
C   GO OVER THE STATES
C   IN THIS WAY I CALL  ADD_TO_SUM EXACTLY ONCE FOR EACH STATE.
C
C    GO OVER OLL THE STATES WICH IS DIFFERENT FROM IREF IN
C    EXACTLY ONE COORDINATE
       IDEBUG=0
C         THE COORDINATE WITH THE CHANGED VALUE
       DO K=1,ISVIB 
         DO KVAL =1,NMAX+1
           IF (KVAL.NE.IREF(K)) THEN
              TMP_SUM=0
              JREF(K) = KVAL
              DO L=1,ISVIB
               IF (L.NE.K) THEN
C
                 IF (K.GT.L) THEN
                     CALL  N_OVRLPAVG(SUM,IREF,JREF,L,K,DX,WAVE,VC,NM,N,
     *                                                              NST)
                 ELSE
                     CALL  N_OVRLPAVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,NM,N,
     *                                                              NST)
                 END IF
C
                 TMP_SUM=TMP_SUM + SUM
               END IF
              END DO !L
C
              EMP0_J=EMP0_I-E(K,IREF(K)) + E(K,KVAL)
C
              CALL N_OL_AVGHF(SUM2,IREF,JREF,K,DX,WAVE,VSCF,NM,N,NST)
              TMP_SUM=TMP_SUM - SUM2
C
              IDEBUG = IDEBUG +1
C---           CALL STPRINT2 (IDEBUG,JREF,EMP0_J,TMP_SUM,NM)
              CALL ADD_TO_SUM (EMP2,TMP_SUM,EMP0_I,EMP0_J,SMALL)
C
C                  RESTOR JREF
              JREF(K) = IREF(K)
            END IF !KV
          END DO !KVAL
        END DO !K
C
      
C      GO OVER ALL THE STATES WICH IS DIFFERENT FROM IREF IN EXACTLY
C      TWO COORDINATES:
      DO K=1,ISVIB -1
         DO KVAL = 1, NMAX+1
           IF (KVAL.NE.IREF(K)) THEN
             DO L = K+1,ISVIB
               DO LVAL = 1,NMAX+1
                 IF (LVAL.NE.IREF(L)) THEN
                   JREF(K)=KVAL
                   JREF(L)=LVAL
C
                   CALL  N_OVRLPAVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,NM,N,
     *                                                            NST)
                   EMP0_J=EMP0_I-E(K,IREF(K)) + E(K,KVAL)
     *                          -E(L,IREF(L)) + E(L,LVAL)
C
                   IDEBUG = IDEBUG +1
C---               CALL STPRINT2 (IDEBUG,JREF,EMP0_J,SUM,NM)
                   CALL ADD_TO_SUM (EMP2,SUM,EMP0_I,EMP0_J,SMALL)
C
                   JREF(K)=IREF(K) !RESTORE IREF
                   JREF(L)=IREF(L)
C
                 END IF
               END DO !LVAL
             END DO !L
           END IF !(KVAL.NE.IREF(K))
         END DO !KVAL
       END DO !K
C
       DO I=1, ISVIB
         IREF(I)=IREF(I)-1
       END DO
C
C
C       !PRINT RESULTES
C       IF (MASWRK) THEN
C       IF(DBG) WRITE(IW,9020) ISTATE,EMP2*CM
C         WRITE(IW,9030) NVST
C       ENDIF
C
       RETURN
C
C 9020 FORMAT(1X,'MP2 (',I4,') :',E14.7)
C 9030 FORMAT(1X,'NUMBER OF VIRTUAL STATES IS ',I6)
C
      END !SUB
C
C*MODULE VSCF    *DECK ADD_TO_SUM
      SUBROUTINE ADD_TO_SUM (EMP2,V_TOADD,EMP0_I,EMP0_J,SMALL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     THIS ROUTINE IS USED FOR SUMMING OVER THE SECOND ORDER
C     PERTURBATION THEORY SUMMATION
C
      SUMV=V_TOADD*V_TOADD
      SUME=EMP0_I-EMP0_J
      IF (ABS(SUME).GT.SMALL) THEN
         EMP2=EMP2+(SUMV/SUME)
      END IF
      RETURN
      END
C
C---C*MODULE VSCF    *DECK STPRINT2
C---        SUBROUTINE STPRINT2 (INDEX,NREF,E,V,NM)
C---C       THIS SUB IS USED FOR DEBUGGING. IT GET STATE (VECTOR)
C---C       ITS ENRGY END V VALUE
C---C       AND PRINT IT ON THE SCR IN ONE LINE.
C---        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C---C
C---        DIMENSION NREF(NM)
C---C
C---        NUM=0
C---         DO I=1 , NM
C---           NUM= NUM*10+ NREF(I)
C---        END DO
C---        WRITE (*,*)INDEX,',',NUM ,',',E,',',V
C---        RETURN
C---C
C---C 9007 FORMAT(I30,' ',E14.7,' ',E14.7)
C---        END
C
C*MODULE VSCF    *DECK N_OVRLPAVG
      SUBROUTINE N_OVRLPAVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,NM,N,NST)
C
C     THIS ROUTINE CALCULATES THE
C     AVG = < PSI1 | VC(K,L) | PSI2 >
C     THE RESULTS OF THIS SUB IS THE SAME AS THE RESULTS OF AVG -
C     BUT WITHOUT CALCULATE OVER-LAPPING
C     THIS ROUTINE ASSUMES THAT THE OVERLAPPING BETWEEN THE
C     WAVEFUNCTION IN EACH J<>K,L IS ONE.
C     IN THIS WAY THIS SUB RUNS IN O(1) RUN TIME
C     WE TRUST THE USER TO GIVE THIS ROUTINE ONLY STATES THAT WILL
C     NOT RETURN ZERO BECAUSE OF THE ORTHONORMALIZATION PROPERTY.
C     LIAT 6.11.06
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM)  ! THE STAGE OF EACH NM
      DIMENSION WAVE(NM,NST,N)     ! WAVE FUNCTION
      DIMENSION VC(NM,NM,N,N)      ! COUPLING POTENTIAL
      DIMENSION DX(NM)             ! INTEGRATION (LENGTH BETWEN 2 PTS)
C
      PARAMETER (ZERO=0.0D+00)
C
      SUM=ZERO
      DO KL=1, N
        SI=DX(K)*WAVE(K,IREF(K),KL)*WAVE(K,JREF(K),KL)
        DO LL=1, N
           SJ=DX(L)*WAVE(L,IREF(L),LL)*WAVE(L,JREF(L),LL)
           SUM=SUM+VC(K,L,KL,LL)*SI*SJ
        END DO
      END DO
C
      RETURN
      END
C
C
C*MODULE VSCF    *DECK N_OL_AVGHF
      SUBROUTINE N_OL_AVGHF(SUM,IREF,JREF,K,DX,WAVE,VSCF,NM,N,NST)
C
C     -THIS IS NOT USED NOW - BECOUSE OF THE DPT BUG ...
C     THIS ROUTINE CALCULATES THE
C     AVG = < PSI1 | VHF(K) | PSI2 >
C     THE RESULTS OF THIS SUB IS THE SAME AS THE RESULTS OF AVGHF -
C     BUT WITHOUT CALCULATE OVER-LAPPING
C     THIS ROUTINE ASSUMES THAT THE OVERLAPPING BETWEEN THE
C     WAVEFUNCTION IN EACH J<>K IS ONE.
C     IN THIS WAY THIS SUB RUNS IN O(1) RUN TIME
C     WE TRUST THE USER TO GIVE THIS ROUTINE ONLY STATES THAT WILL NOT
C     RETURN ZERO BECAUSE OF THE ORTHONORMALIZATION PROPERTY.
C     LIAT 7.11.06
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM)
      DIMENSION WAVE(NM,NST,N)
      DIMENSION VSCF(NM,N)
      DIMENSION DX(NM)
C
      PARAMETER (ZERO=0.0D+00)
C
C
      SUM=ZERO
C
       DO LL=1, N
          TEMP=DX(K)*WAVE(K,JREF(K),LL)*WAVE(K,IREF(K),LL)
          SUM=SUM+VSCF(K,LL)*TEMP
       END DO
C
      RETURN
      END
C
C
C*MODULE VSCF    *DECK AVG
      SUBROUTINE AVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,OVRLP,NM,N,NST,
     *               ISVIB)
C
C     THIS ROUTINE CALCULATES THE
C     AVG = < PSI | VC(K,L) | PSI >
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM)  ! THE STAGE OF EACH NM
      DIMENSION OVRLP(NM)          ! DENSITY WAVE ^2
      DIMENSION WAVE(NM,NST,N)     ! WAVE FUNCTION
      DIMENSION VC(NM,NM,N,N)      ! COUPLING POTENTIAL
      DIMENSION DX(NM)             ! INTEGRATION (LENGTH BETWEEN 2 PTS)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C     ---------------------------------------------------------------
C     ADDED BY LIAT 19/01/04 IN ORDER TO ACCELERATE VSCF CALCULATIONS
C
      DO M=1, ISVIB
         IF (IREF(M).NE.JREF(M)) THEN
            IF ((M.NE.K) .AND. (M.NE.L)) THEN
               SUM=ZERO
               RETURN
            END IF
         END IF
      END DO
C     ---------------------------------------------------------------
      SUM=ZERO
      DO KL=1, N
        SI=DX(K)*WAVE(K,IREF(K),KL)*WAVE(K,JREF(K),KL)
        DO LL=1, N
           SJ=DX(L)*WAVE(L,IREF(L),LL)*WAVE(L,JREF(L),LL)
           SUM=SUM+VC(K,L,KL,LL)*SI*SJ
        END DO
      END DO
C
      SIJ=ONE
      DO M=1, ISVIB
        IF ((M.EQ.K).OR.(M.EQ.L)) THEN
           OVRLP(M)=ONE
        ELSE
           OVRLP(M)=ZERO
           IF (IREF(M).EQ.JREF(M)) THEN
             DO LL=1, N
               OVRLP(M)=OVRLP(M)+
     *                  DX(M)*WAVE(M,IREF(M),LL)*WAVE(M,JREF(M),LL)
             END DO
           ELSE
             SIJ=ZERO
             GOTO 1000
           END IF
        END IF
        !DEBUG
        SIJ=SIJ*OVRLP(M)
      END DO
C
      IF (ABS(SIJ-ONE).GT.1.0D-15.AND.SIJ.NE.ZERO) THEN
        WRITE(*,9001) SIJ
       END IF
C
1000  SUM=SUM*SIJ
      RETURN
C
9001  FORMAT('ASSERT: SIJ IS ',E17.7)
C
      END
C*MODULE VSCF    *DECK AVG3
      SUBROUTINE AVG3(SUM,IREF,JREF,L1,L2,L3,DX,WAVE,VTR,
     *                OVRLP,NM,N,NST,ISVIB)
C
C     THIS ROUTINE CALCULATES THE
C     AVG = < PSI | VTRIP(L1,L2,L3) | PSI >
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM)
      DIMENSION OVRLP(NM)
      DIMENSION WAVE(NM,NST,N)
      DIMENSION VTR(NM,NM,NM,N,N,N)
      DIMENSION DX(NM)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      SUM=ZERO
      DO LL1=1, N
        S1=DX(L1)*WAVE(L1,IREF(L1),LL1)*WAVE(L1,JREF(L1),LL1)
        DO LL2=1, N
          S2=DX(L2)*WAVE(L2,IREF(L2),LL2)*WAVE(L2,JREF(L2),LL2)
          DO LL3=1, N
            S3=DX(L3)*WAVE(L3,IREF(L3),LL3)*WAVE(L3,JREF(L3),LL3)
            SUM=SUM+VTR(L1,L2,L3,LL1,LL2,LL3)*S1*S2*S3
          END DO
        END DO
      END DO
C
      SIJ=ONE
      DO M=1, ISVIB
        IF ((M.EQ.L1).OR.(M.EQ.L2).OR.(M.EQ.L3)) THEN
           OVRLP(M)=ONE
        ELSE
           OVRLP(M)=ZERO
           IF (IREF(M).EQ.JREF(M)) THEN
             DO LL=1, N
               OVRLP(M)=OVRLP(M)+
     *                  DX(M)*WAVE(M,IREF(M),LL)*WAVE(M,JREF(M),LL)
             END DO
           ELSE
             SIJ=ZERO
             GOTO 1000
           END IF
        END IF
        SIJ=SIJ*OVRLP(M)
      END DO
1000  SUM=SUM*SIJ
      RETURN
      END
C*MODULE VSCF    *DECK AVGHF
      SUBROUTINE AVGHF(SUM,IREF,JREF,K,DX,WAVE,VSCF,OVRLP,
     *                 NM,N,NST,ISVIB)
C
C     THIS ROUTINE CALCULATES THE
C     AVG = < PSI | VHF(K) | PSI >
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM)
      DIMENSION WAVE(NM,NST,N)
      DIMENSION VSCF(NM,N)
      DIMENSION DX(NM)
      DIMENSION OVRLP(NM)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      SUM=ZERO
      SIJ=ONE
      DO M=1, ISVIB
         IF (M.EQ.K) THEN
           OVRLP(M)=ONE
           DO LL=1, N
             TEMP=DX(M)*WAVE(M,JREF(M),LL)*WAVE(M,IREF(M),LL)
             SUM=SUM+VSCF(M,LL)*TEMP
           END DO
         ELSE
           OVRLP(M)=ZERO
           IF (IREF(M).EQ.JREF(M)) THEN
             DO LL=1, N
               OVRLP(M)=OVRLP(M)+
     *              DX(M)*WAVE(M,JREF(M),LL)*WAVE(M,IREF(M),LL)
             END DO
           ELSE
             SIJ=ZERO
             GOTO 1000
           END IF
         END IF
         SIJ=SIJ*OVRLP(M)
      END DO
1000  SUM=SUM*SIJ
      RETURN
      END
C*MODULE VSCF    *DECK EIGSRT
      SUBROUTINE EIGSRT(D,V,N,NP)
C
C     THIS ROUTINE RESORTS THE EIGENVALUES FROM ASCENDING
C     TO DESCENDING ORDER, AND REARRANGES THE COLUMNS OF V
C     CORRESPONDINGLY.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION  D(NP),V(NP,NP)
C
      DO 130 I=1,N/2
         K=N-I+1
         P=D(K)
         D(K)=D(I)
         D(I)=P
         DO 120 J=1,N
            P=V(J,K)
            V(J,K)=V(J,I)
            V(J,I)=P
  120    CONTINUE
  130 CONTINUE
C
      RETURN
      END
C*MODULE VSCF    *DECK ENDIFF
      SUBROUTINE ENDIFF(FREQ,FRSCF,FRMP2,DEMP2,DIAG,EMP1,EMP2,
     *                  ECAS,EQDPT2,NM,NSTATE,NCOUP,IEXC,CC,COM,ZMS,
     *                  NPART,ISVIB,IMODE,JMODE,NC1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION FREQ(NM), EMP1(NSTATE), EMP2(NSTATE), DIAG(NSTATE)
      DIMENSION FRSCF(NM), FRMP2(NM), ECAS(NSTATE), EQDPT2(NSTATE)
      DIMENSION DEMP2(NM), IMODE(NC1), JMODE(NC1)
C
      PARAMETER (CM=2.194747D+05, TWO=2.0D+00, ZERO=0.0D+00)
C
      IF(MASWRK) WRITE(IW,9000)
C
      ANHZPE = ZERO
      IF (NCOUP.LE.1) THEN
         IF(MASWRK) WRITE(IW,9010)
         DO MODE = 1, ISVIB
            I = NC1 - IMODE(MODE) + 1
            HFR = FREQ(MODE)*CM
            IF (IEXC.GT.1) HFR=HFR*IEXC
            DDIAG = (DIAG(MODE+1) - DIAG(1))*CM
            IF (MASWRK) WRITE(IW,9020) I, HFR, DDIAG
            FRSCF(MODE)=DDIAG/CM
            FRMP2(MODE)=FRSCF(MODE)
            DEMP2(MODE)=DDIAG
         END DO
         ANHZPE = DIAG(1)*CM
         IF (ISVIB.NE.NM) THEN
           IF (MASWRK) WRITE(IW,9050)
           IF (MASWRK) WRITE(IW,9060)
           DO MODE = ISVIB+1, NM
             I = NC1 - JMODE(MODE) + 1
             HFR = FREQ(MODE)*CM
             IF (IEXC.GT.1) HFR=HFR*IEXC
             IF (MASWRK) WRITE(IW,9070) I, HFR
             DEMP2(MODE)=HFR
             ANHZPE = ANHZPE + HFR/TWO
           END DO
         END IF
      ELSE
         IF(MASWRK) WRITE(IW,9030)
         DO MODE = 1, ISVIB
            I = NC1 - IMODE(MODE) + 1
            HFR = FREQ(MODE)*CM
            IF (IEXC.GT.1) HFR=HFR*IEXC
            DDIAG = (DIAG(MODE+1) - DIAG(1))*CM
            DVSCF = (EMP1(MODE+1) - EMP1(1))*CM
            DEMP2(MODE) = (EMP2(MODE+1) - EMP2(1))*CM
            DCAS  = (ECAS(MODE+1) - ECAS(1))*CM
            DQDPT = (EQDPT2(MODE+1)-EQDPT2(1))*CM
            IF (MASWRK) WRITE(IW,9040) I,HFR,DDIAG,DVSCF,
     *                                 DEMP2(MODE),DCAS,DQDPT
            FRSCF(MODE)=DVSCF/CM
            FRMP2(MODE)=DEMP2(MODE)/CM
         END DO
         ANHZPE = EMP2(1)*CM
         IF (ISVIB.NE.NM) THEN
           IF (MASWRK) WRITE(IW,9050)
           IF (MASWRK) WRITE(IW,9060)
           DO MODE = ISVIB+1, NM
             I = NC1 - JMODE(MODE) + 1
             HFR = FREQ(MODE)*CM
             IF (IEXC.GT.1) HFR=HFR*IEXC
             IF (MASWRK) WRITE(IW,9070) I, HFR
             DEMP2(MODE)=HFR
             ANHZPE = ANHZPE + HFR/TWO
           END DO
         END IF
       END IF
C
C     THERMOCHEMISTRY
C
      NSWITCH=1
      CALL THERMO(IW,ANHZPE,DEMP2,CC,COM,ZMS,NPART,NSWITCH,NM)
C
      RETURN
C
 9000 FORMAT(/1X,'RESULTS OF VIBRATIONAL SCF CALCULATION:',
     *          ' (FREQUENCIES IN CM-1)')
 9010 FORMAT(1X,'MODE      HARMONIC     DIAGONAL')
 9020 FORMAT(2X,I2,5X,2(F10.2,3X))
 9030 FORMAT(1X,'MODE  HARMONIC   DIAGONAL     VSCF      ',
     *          'PT2-VSCF   VCI-VSCF  DPT2-VSCF')
 9040 FORMAT(2X,I2,2X,6(F9.2,2X))
 9050 FORMAT(/1X,'FOLLOWING FREQUENCIES ARE KEPT IN      ',
     *            'HARMONIC APPROXIMATION:',
     *            ' (FREQUENCIES IN CM-1)')
 9060 FORMAT(1X,'MODE      HARMONIC')
 9070 FORMAT(2X,I2,5X,2(F10.2,3X))
      END
C*MODULE VSCF    *DECK ENDIFFC
      SUBROUTINE ENDIFFC(FREQ,FRSCF,FRMP2,DEMP2,DIAG,EMP1,EMP2,
     *                   NM,NSTATE,NCOUP,CC,COM,ZMS,
     *                   NPART,ISVIB,NM4,ISVIB4,ISTATE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION FREQ(NM4), EMP1(NSTATE), EMP2(NSTATE), DIAG(NSTATE)
      DIMENSION FRSCF(NM4), FRMP2(NM4)
C-    DIMENSION ECAS(NSTATE), EQDPT2(NSTATE)
      DIMENSION DEMP2(NM4)
      DIMENSION ISTATE(NM,NM4+1)
C
      PARAMETER (CM=2.194747D+05, ZERO=0.0D+00)
C
      IF(MASWRK) WRITE(IW,9000)
C
      ANHZPE = ZERO
C
      IF (NCOUP.LE.1) THEN
         IF(MASWRK) WRITE(IW,9010)
         DO I = 2, ISVIB4+1
            HFR = 0.0D+00
            DO J=1,ISVIB
               HFR=HFR+FREQ(J)*ISTATE(J,I)
            ENDDO
            HFR = HFR*CM
            DDIAG = (DIAG(I) - DIAG(1))*CM
            IF (MASWRK) WRITE(IW,9020) HFR,DDIAG,(ISTATE(K,I),K=1,ISVIB)
            FRSCF(I-1)=DDIAG/CM
            FRMP2(I-1)=FRSCF(I-1)
            DEMP2(I-1)=DDIAG
         END DO
         ANHZPE = DIAG(1)*CM
      ELSE
         IF(MASWRK) WRITE(IW,9030)
         DO I = 2, ISVIB4+1
            HFR = 0.0D+00
            DO J=1,ISVIB
               HFR=HFR+FREQ(J)*ISTATE(J,I)
            ENDDO
            HFR = HFR*CM
            DDIAG = (DIAG(I) - DIAG(1))*CM
            DVSCF = (EMP1(I) - EMP1(1))*CM
            DEMP2(I-1) = (EMP2(I) - EMP2(1))*CM
C-          DCAS  = (ECAS(I) - ECAS(1))*CM
C-          DQDPT = (EQDPT2(I)-EQDPT2(1))*CM
            IF (MASWRK) WRITE(IW,9040) HFR,DDIAG,DVSCF,DEMP2(I-1),
     *                         (ISTATE(K,I),K=1,ISVIB)
            FRSCF(I-1)=DVSCF/CM
            FRMP2(I-1)=DEMP2(I-1)/CM
         END DO
         ANHZPE = EMP2(1)*CM
       END IF
C
C     THERMOCHEMISTRY
C
      IF (ISVIB.EQ.NM) THEN
         NSWITCH=1
         CALL THERMO(IW,ANHZPE,DEMP2,CC,COM,ZMS,NPART,NSWITCH,NM)
      END IF
C
      RETURN
C
 9000 FORMAT(/1X,'RESULTS OF VIBRATIONAL SCF CALCULATION:',
     *          ' (FREQUENCIES IN CM-1)')
 9010 FORMAT(1X,'  HARMONIC    DIAGONAL   EXCITATION')
 9020 FORMAT (2(F10.2,3X),100(I2))
 9030 FORMAT(1X,'  HARMONIC     DIAGONAL     VSCF      ',
     *          '   PT2-VSCF   EXCITATION')
 9040 FORMAT (4(F10.2,3X),100(I2))
      END
C*MODULE VSCF    *DECK INTENS
      SUBROUTINE INTENS(SINTSCF,UX,UY,UZ,U2X,U2Y,U2Z,FRSCF,FRMP2,
     *                  DQ,WAVE,ISTATE,NM,N,ISVIB,NM4,ISVIB4,IEXC2,
     *                  IMODE,NC1)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXFRG=1050)
      DIMENSION IMODE(3*MXATM+6*MXFRG)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     THIS ROUTINE CALCULATES IR INTENSITY FOR I-TH MODE
C     USING THE FOLLOWING EQUATION:
C
C     INTENSITY(I) = |<GROUND PSI(I)| U(I) |EXCITED PSI(I)>|^2
C
C             WHERE   PSI(I) = WAVEFUNCTION CORRESPONDING TO MODE I
C                     U(I)   = DIPOLE MOMENT ALONG NORMAL COORDINATE I
C
C     FOR COMBINATIONS, SEE
C        FIRST - PRINCIPLES CALCULATIONS OF ANHARMONIC VIBRATIONAL
C        SPECTROSCOPY OF LARGE MOLECULES.
C        R. BENNY GERBER, GALINA M. CHABAN, BRINA BRAUER, YIFAT MILLER
C     IN "THEORY AND APPLICATIONS OF COMPUTATIONAL CHEMISTRY:
C     THE FIRST 40 YEARS (A VOLUME OF TECHNICAL AND  HISTORICAL
C     PERSPECTIVES)". EDITED BY: CLIFFORD E. DYKSTRA, GERNOT FRENKING,
C     KWANG S. KIM, AND GUSTAVO E. SCUSERIA.  ELSEVIER, 2005, PAGE 178.
C
      DIMENSION DQ(NM)
      DIMENSION WAVE(NM4+1,NM,N)            ! VSCF WAVEFUNCTIONS
      DIMENSION FRSCF(NM4)                  ! VSCF FREQUENCIES
      DIMENSION FRMP2(NM4)                  ! VMP2 FREQUENCIES
      DIMENSION UX(NM,N),UY(NM,N),UZ(NM,N)  ! DIPOLE MOMENT COMPONENTS
      DIMENSION U2X(NM,NM,N,N),U2Y(NM,NM,N,N),U2Z(NM,NM,N,N)
      DIMENSION SINTSCF(NM4)                ! VSCF INTENSITY
      DIMENSION ISTATE(NM,NM4+1)
C
      PARAMETER (ZERO=0.0D+00)
      PARAMETER (CONST=2.5048D+00, CM=2.194747D+05)
C
C     CONST = 8*PI^3*NAVOGADRO*(E-18)^2*E-5/(3*H*C) IN CGS
C
      IF (MASWRK .AND. IEXC2.EQ.0) WRITE(IW,9000)
      IF (MASWRK .AND. IEXC2.GT.0) WRITE(IW,9005)
C
      DO I=2, ISVIB4+1
         II = NC1 - IMODE(I-1) + 1
         TEMPX=ZERO
         TEMPY=ZERO
         TEMPZ=ZERO
         IF (I.LE.ISVIB+1) THEN
           DO J=1, ISVIB
             IF (ISTATE(J,I).NE.0) THEN
               DO L=1, N
                 TEMPX=TEMPX+UX(J,L)*WAVE(1,J,L)*WAVE(I,J,L)*DQ(J)
                 TEMPY=TEMPY+UY(J,L)*WAVE(1,J,L)*WAVE(I,J,L)*DQ(J)
                 TEMPZ=TEMPZ+UZ(J,L)*WAVE(1,J,L)*WAVE(I,J,L)*DQ(J)
               END DO
             END IF
           END DO
         ELSEIF (IEXC2.GT.0) THEN
           J=1
   10      IF (ISTATE(J,I).NE.0) THEN
              J1=J
              K=J1+1
   20         IF (ISTATE(K,I).NE.0) THEN
                 J2=K
              ELSE
                 K=K+1
                 GOTO 20
              ENDIF
           ELSE
              J=J+1
              GOTO 10
           ENDIF
           DO L=1, N
              DO M=1, N
                 TEMPX=TEMPX+U2X(J1,J2,L,M)*WAVE(1,J1,L)*WAVE(1,J2,M)*
     *                 WAVE(I,J1,L)*WAVE(I,J2,M)*DQ(J1)*DQ(J2)
                 TEMPY=TEMPY+U2Y(J1,J2,L,M)*WAVE(1,J1,L)*WAVE(1,J2,M)*
     *                 WAVE(I,J1,L)*WAVE(I,J2,M)*DQ(J1)*DQ(J2)
                 TEMPZ=TEMPZ+U2Z(J1,J2,L,M)*WAVE(1,J1,L)*WAVE(1,J2,M)*
     *                 WAVE(I,J1,L)*WAVE(I,J2,M)*DQ(J1)*DQ(J2)
              END DO
            END DO
         END IF
         SINTSCF(I-1)=TEMPX*TEMPX+TEMPY*TEMPY+TEMPZ*TEMPZ
         SINTSCF(I-1) = FRSCF(I-1)*CM*CONST*SINTSCF(I-1)
C
         IF (MASWRK) THEN
            IF (IEXC2.EQ.0 .AND. I.LE.ISVIB+1) THEN
               WRITE(IW,9010) II, FRMP2(I-1)*CM, SINTSCF(I-1)
            ELSEIF (IEXC2.GT.0) THEN
               WRITE(IW,9020) FRMP2(I-1)*CM, SINTSCF(I-1),
     *                                     (ISTATE(K,I),K=1,ISVIB)
            ENDIF
         ENDIF
C
      END DO
      RETURN
C
 9000 FORMAT(/1X,'IR INTENSITIES ARE CALCULATED USING DIPOLE MOMENTS'/
     *       1X,'MODE   FREQUENCY, CM-1  INTENSITY, KM/MOL')
 9005 FORMAT(/1X,'IR INTENSITIES ARE CALCULATED USING DIPOLE MOMENTS'/
     *       '   FREQUENCY, CM-1  INTENSITY, KM/MOL    EXCITATION')
 9010 FORMAT (2X,I2,5X,F10.2,4X,F10.2)
 9020 FORMAT (2X,F10.2,6X,F10.2,12X,100(I2))
      END
C
C*MODULE VSCF    *DECK DINTENS
      SUBROUTINE DINTENS(SINTSCF,DDM,DDER,FRSCF,FRMP2,
     *                   VEC,Q,DQ,WAVE,NM,NM4,N,NC,IMODE,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXFRG=1050)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     THIS ROUTINE CALCULATES IR INTENSITY FOR I-TH MODE
C     USING THE FOLLOWING EQUATION:
C
C     INTENSITY(I) = ( DU/DQ(I) |<GR. PSI(I)| Q(I) |EX. PSI(I)>| )^2
C
C             WHERE   DU/DQ(I) = DIPOLE DERIVATIVE AT EQUILIBRIUM
C
      DIMENSION DQ(NM)
      DIMENSION Q(NM,N)
      DIMENSION VEC(NC,NC)
      DIMENSION WAVE(NM4+1,NM,N)    ! VSCF WAVEFUNCTIONS
      DIMENSION FRSCF(NM4)          ! VSCF FREQUENCIES
      DIMENSION FRMP2(NM4)          ! VMP2 FREQUENCIES
      DIMENSION SINTSCF(NM4)        ! VSCF INTENSITY
      DIMENSION DDM(NC*3)           ! DIPOLE DERIVATIVE IN CARTESIANS
      DIMENSION DDER(NM)            ! SQUARE OF DIPOLE MOMENT DERIVATIVE
      DIMENSION IMODE(3*MXATM+6*MXFRG)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      PARAMETER (AMU=1.8229D+03, CM=2.19474D+05)
      PARAMETER (CONST=2.5048D+00, BOHR=5.2918D-01)
C
C     CONST = 8*PI^3*NAVOGADRO*(E-18)^2*E-5/(3*H*C) IN CGS
C
      IF(MASWRK) WRITE(IW,9000)
C
      FACT = ONE/AMU
C
      DO IM = 1, ISVIB
           I=NC-IMODE(IM)+1
         DDX = DDOT(NC,VEC(1,I),1,DDM(1),3)
         DDY = DDOT(NC,VEC(1,I),1,DDM(2),3)
         DDZ = DDOT(NC,VEC(1,I),1,DDM(3),3)
         DDER(IM) = DDX*DDX + DDY*DDY + DDZ*DDZ
      ENDDO
C
      DO J=1, ISVIB
         II = NC - IMODE(J) + 1
         SINTSCF(J) = ZERO
         DO L=1, N
            SINTSCF(J) = SINTSCF(J) +
     *                   Q(J,L)*WAVE(1,J,L)*WAVE(J+1,J,L)*DQ(J)
         END DO
C
         SINTSCF(J) = FRSCF(J)*CM*SINTSCF(J)**2
         SINTSCF(J) = SINTSCF(J)*DDER(J)*CONST*FACT*BOHR*BOHR
         IF (MASWRK)
     *          WRITE(IW,9010) II, FRMP2(J)*CM, SINTSCF(J)
C
      END DO
C
      RETURN
C
 9000 FORMAT(/1X,'IR INTENSITIES ARE CALCULATED USING HARMONIC DIPOLE',
     *           ' DERIVATIVES.'/
     *       1X,'MODE   FREQUENCY, CM-1  INTENSITY, KM/MOL')
 9010 FORMAT (2X,I2,5X,F10.2,4X,F10.2)
      END
C
C*MODULE VSCF    *DECK VIRTCI
      SUBROUTINE VIRTCI(VIRTWAVE,VIRTE,IVST,NM,NST,NG,DX,III,
     *                  NVST,H,VC,VSCF,E,SCR,VEC,IA,
     *                  ICAS1,ICAS2,VDPT,NDET,OVRLP,JVIRT,
     *                  KREF,JREF,IREF,NDET2,ICASX,ICAST,IMP,
     *                  CASMIN,VMP,TRIPV,EMP0,ECAS,EQDPT2,VWAVE,
     *                  SMALL,DEBUG,IEXC,ISVIB,NM4)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL VDPT,CASMIN,DEBUG
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION VIRTWAVE(NM,NST,NG),DX(NM)
      DIMENSION VIRTE(NM,NST),IVST(NVST,NM),ICAST(NDET,NM)
      DIMENSION VC(NM,NM,NG,NG),VSCF(NM,NG),IA(NVST)
      DIMENSION H(NDET2),E(NDET),SCR(NDET,8),VEC(NDET,NDET)
      DIMENSION OVRLP(NM),JVIRT(NVST,NM),IMP(NM)
      DIMENSION TRIPV(NM,NM,NM,NG,NG,NG),EMP0(NVST)
      DIMENSION IREF(NM),JREF(NM),KREF(NM),VMP(NDET,NVST)
      DIMENSION ECAS(NM4+1),EQDPT2(NM4+1),VWAVE(NM,NG)
C
      PARAMETER(CM=219474.7D+00)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- DRIVER ROUTINE FOR VIRTUAL CI -----
C           KREF = REFERENCE SCF STATE   STARTS WITH 1
C           IREF = <BRA| VIRTUAL STATE
C           JREF = |KET> VIRTUAL STATE
C
      IF(IEXC.GT.1) RETURN
C
      DO I=1, ISVIB
         KREF(I)=KREF(I)+1
      END DO
C
      ICAS = ICAS2 - ICAS1 + 1
      CALL VCLR(H,1,NDET2)
C
C     ----- PREPARE DETERMINANTS FOR SMALL CI -----
C
      CALL PREPD(ICAST,ICAS,ICASX,ICAS1,ICAS2,NDET,NM,III,IMP,CASMIN,
     *           ISVIB)
C
C     ----- DIAGONAL PART -----
C       *** KREF STARTS WITH 1, NOT WITH 0 ***
C
      CALL VCIDIAG(VIRTE,ICAST,NM,NST,H,NDET,NDET2,IMP,DX,VIRTWAVE,
     *             VC,TRIPV,NG,IREF,JREF,VWAVE,ISVIB)
C
      IF(DEBUG) THEN
         WRITE(IW,*) '****** DIAGONAL HAMILTONIAN *****'
         WRITE(IW,*) 'NM   = ',NM
         WRITE(IW,*) 'NDET = ',NDET
         CALL PRTRI(H,NDET)
      END IF
C
C     ----- PUTING RIGHT POTENTIAL COUPLING IN CI HAMILTONIAN -----
C
      DO 200 I=1,NDET-1
         DO 100 J=I+1,NDET
            DO 80 K=1,ISVIB
               IREF(K) = ICAST(I,K)
               JREF(K) = ICAST(J,K)
   80       CONTINUE
C
            CALL VCIP(I,J,VIRTWAVE,VC,VSCF,NM,NST,NG,DX,NDET,
     *                 IREF,JREF,OVRLP,NDET2,IMP,H,ISVIB)
C
  100    CONTINUE
  200 CONTINUE
C
      IF(DEBUG) THEN
         WRITE(IW,9999)
 9999    FORMAT(5X,'***** BACK TO VIRTCI ROUTINE *****'//,
     *     '  HAMILTONIAN MATRIX')
         CALL PRTRI(H,NDET)
      END IF
C
C     ----- DIAGONALIZE HAMILTONIAN -----
C
      IERR = 0
      CALL GLDIAG(NDET,NDET,NDET,H,SCR,E,VEC,IERR,IA)
C
      IF(IERR.NE.0) THEN
         WRITE(IW,9050)
         CALL ABRT
      END IF
C
      DO I=1,ISVIB
         IREF(I)=0
      END DO
C
      IF(MASWRK) THEN
        WRITE(IW,9010)
        WRITE(IW,9060)
      END IF
      IADD = 0
C
C     ----- PRINT OUT EIGENVALUES AND EIGENVECTORS -----
C
      DO 300 I=1,NDET
         CALL WHDET(I,VEC,IREF,ICAST,NM,NDET,IWHCH,ISVIB)
         CALL REAREF(IREF,IMP,OVRLP,NM,IADD,ISVIB)
         CALL REAREF(JREF,IMP,OVRLP,NM,IADD,ISVIB)
         WRITE(IW,9020) I,E(I)*CM,(IREF(K),K=1,ISVIB)
  300 CONTINUE
C
      CALL WHEST(VEC,IREF,KREF,ICAST,IMP,OVRLP,NM,NDET,ITHVEC,
     *           ISVIB)
      IST         = III + 1
      ECAS(IST)   = E(ITHVEC)
C
C     ----- PRINT EIGENVECTORS! -----
C
      IF(MASWRK) THEN
        WRITE(IW,9040)
        CALL PREV(VEC,E,NDET,NDET,NDET)
        WRITE(IW,9045)
      END IF
C
C     ----- FINALLY DO MP2 ON TOP OF CI -----
C
      IF(VDPT) THEN
      CALL VCIPT(VIRTWAVE,VIRTE,VC,TRIPV,VSCF,VEC,NM,NDET,NG,DX,NST,
     *           NVST,IREF,JREF,KREF,III,IVST,JVIRT,
     *           OVRLP,CASMIN,IMP,ICAST,VMP,
     *           EMP0,ECAS,EQDPT2,SMALL,DEBUG,ISVIB,NM4)
      END IF
C
      RETURN
C
 9010 FORMAT(1X,'VIBRATIONAL VIRTUAL CI EIGENVALUES')
 9020 FORMAT(5X,I3,1X,F12.2,2X,40I1)
 9040 FORMAT(/1X,'VIBRATIONAL VIRTUAL CI EIGENVECTORS')
 9045 FORMAT(/)
 9050 FORMAT(5X,'***** PROBLEM WITH DIAGONALIZATION *****')
 9060 FORMAT('      #    EIGENVALUE  DETERMINANT',/
     *       '     ===   ==========  ===========')
      END
C
C*MODULE VSCF    *DECK VCIDIAG
      SUBROUTINE VCIDIAG(VIRTE,ICAST,NM,NST,H,NDET,NDET2,IMAP,DX,WAVE,
     *                   VC,VTR,NG,IREF,JREF,VWAVE,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VIRTE(NM,NST),ICAST(NDET,NM),H(NDET2)
      DIMENSION IMAP(NM),WAVE(NM,NST,NG),DX(NM),VWAVE(NM,NG)
      DIMENSION IREF(NM),JREF(NM)
      DIMENSION VC(NM,NM,NG,NG),VTR(NM,NM,NM,NG,NG,NG)
C
C     ----- DIAGONAL VALENCE CI -----
C
      IM = 0
      NCOUP = 2
      DO I=1,NDET
         IM = IM + I
C
         DO J=1,ISVIB
            JM = IMAP(J)
            IREF(J) = ICAST(I,JM) + 1
            JREF(J) = IREF(J)
            IRF = ICAST(I,JM) + 1
            H(IM) = H(IM) + VIRTE(J,IRF)
         END DO
C
         CALL GETWAV(WAVE,IREF,NM,NST,NG,VWAVE,ISVIB)
         CALL SCFCORR(VWAVE,EMP1,DX,VC,VTR,NM,NG,NCOUP,ISVIB)
         H(IM) = H(IM) - EMP1
      END DO
      RETURN
      END
C
C*MODULE VSCF    *DECK VCIP
      SUBROUTINE VCIP(I,J,WAVE,VC,VSCF,NM,NST,N,DX,NDET,IREF,JREF,
     *                OVRLP,NDET2,IMAP,H,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION IREF(NM),JREF(NM),H(NDET2)
      DIMENSION WAVE(NM,NST,N),VC(NM,NM,N,N)
      DIMENSION VSCF(NM,N),DX(NM)
      DIMENSION OVRLP(NM),IMAP(NM)
      PARAMETER(ZERO=0.0D+00)
C
C     ----- REARRANGE IREF AND KREF THAT AVG AND AVGHF UNDERSTAND ------
C
      IADD = 1
      IM = 0
      CALL REAREF(IREF,IMAP,OVRLP,NM,IADD,ISVIB)
      CALL REAREF(JREF,IMAP,OVRLP,NM,IADD,ISVIB)
C
C     ----- < I | V - VSCF | J > FOR MODES ICAS1 TO ICAS2 -----
C
      ELEM1 =ZERO
      ELEM2 =ZERO
C
C     NEED TO GENERATE DETERMINANTS CORRESPONDS TO <I| AND |J>
C
      DO K=1, ISVIB-1
         DO L=K+1, ISVIB
      CALL AVG(SUM,IREF,JREF,K,L,DX,WAVE,VC,OVRLP,NM,N,NST,ISVIB)
            ELEM1 = ELEM1 + SUM
         END DO
      END DO
C
C     CALCULATE AVERAGED V OF HF
C
      DO K=1, ISVIB
         CALL AVGHF(SUM2,IREF,JREF,K,DX,WAVE,VSCF,OVRLP,NM,N,NST,ISVIB)
         ELEM2 = ELEM2 + SUM2
      END DO
C
C     ----- FIND WHICH ELEMENT <I| AND |J> CORRESPOND TO -----
C
      IJ = 0
      DO IC=1,NDET
         DO IR=1,IC
            IJ = IJ + 1
            IF(IR.EQ.I .AND. IC.EQ.J) IM = IJ
         END DO
      END DO
C
      H(IM) = ELEM1 - ELEM2
C
      RETURN
      END
C
C*MODULE VSCF    *DECK PREPD
      SUBROUTINE PREPD(ICAST,ICAS,ICASX,ICAS1,ICAS2,NDET,NM,III,IMP,
     *                 CASMIN,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL CASMIN
      DIMENSION ICAST(NDET,NM),IMP(NM)
C
C     ------ GENERATION OF ALL DETERMINANTS -----
C         ICAST = CAS STATES
C         NMAX  = MAXIMUM EXCITATION
C
      NMAX = ICASX
      CALL VICLR(ICAST,1,NDET*NM)
C
C     ----- MAP CAS AND NON-CAS IN IMP -----
C
      I = 0
      DO J=1,ISVIB
         IF(J.GE.ICAS1 .AND. J.LE.ICAS2) THEN
            IMP(J) = J - ICAS1 + 1
         END IF
         IF(J.LT.ICAS1) THEN
            IMP(J) = J + ICAS
         END IF
         IF(J.GT.ICAS2) THEN
            IMP(J) = J
         END IF
      END DO
C
C     ----- GET ALL POSSIBLE COMBINATION IN CAS -----
C
      IF(CASMIN) THEN
         DO K=1,NDET
            DO L=1,ISVIB
               IF(L.EQ.K-1) ICAST(K,L) = 1
            END DO
         END DO
      ELSE
         IEXC = 1
C
C     ALLOCATE MEMORY FOR IREF
C
         CALL VALFM(LOADFM)
         LIREF = LOADFM + 1
         LAST  = LIREF + ISVIB
         NEED9  = LAST - LOADFM -1
         CALL GETFM(NEED9)
C
         CALL VIRTSTATE (0,0,ICAS,NMAX,NDET,ICAST,2,IEXC,0,ISVIB)
C
         CALL RETFM(NEED9)
C
      END IF
C
C     ----- PUT NON-CAS EXCITATION -----
C
      IF(III.GT.0) THEN
         IF(III.LT.ICAS1 .OR. III.GT.ICAS2) THEN
            I = IMP(III)
            ICAST(1,I) = 1
         END IF
      END IF
C
      RETURN
      END
C
C*MODULE VSCF    *DECK REAREF
      SUBROUTINE REAREF(IREF,IMAP,ISCR,NM,IADD,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION IREF(NM),ISCR(NM),IMAP(NM)
C
C     ----- REARRANGE IREF AND KREF IN RIGHT ORDER -----
C
      CALL VCLR(ISCR,1,NM)
      DO K=1,ISVIB
         ISCR(K) = IREF(K) + IADD
      END DO
      DO K=1,ISVIB
         K1 = IMAP(K)
         IREF(K) = ISCR(K1)
      END DO
      CALL VCLR(ISCR,1,NM)
C
      RETURN
      END
C
C*MODULE VSCF    *DECK WHDET
      SUBROUTINE WHDET(I,VEC,IREF,ICAST,NM,NDET,IWHCH,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VEC(NDET,NDET),IREF(NM),ICAST(NDET,NM)
C
C     ----- DETERMINE WHICH DETERMINANTS HAS THE LARGEST CI COEFF. -----
C     GIVEN I-TH COLUMN VECTOR, PICK OUT THE CI COEFF
C     ON RETURN, IREF IS FILLED AND IWHCH, POINTS TO THE LARGEST ROW
C
      TMP1 = ABS(VEC(1,I))
      IWHCH = 1
      DO J=2,NDET
         TMP2 = ABS(VEC(J,I))
         IF(TMP1.LT.TMP2) THEN
            TMP1 = TMP2
            IWHCH = J
         END IF
      END DO
C
      DO J=1,ISVIB
         IREF(J) = ICAST(IWHCH,J)
      END DO
C
      RETURN
      END
C
C*MODULE VSCF    *DECK VCIPT
      SUBROUTINE VCIPT(WAVE,VIRTE,VC,VTR,VSCF,VEC,NM,NDET,NG,DX,NST,
     *                 NVST,IREF,JREF,KREF,III,
     *                 IVST,JVIRT,OVRLP,CASMIN,IMP,ICAST,VMP,
     *                 EMP0,ECAS,EQDPT2,SMALL,DBG,ISVIB,NM4)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL CASMIN,DBG
      DIMENSION WAVE(NM,NST,NG),VIRTE(NM,NST),DX(NM),IMP(NM)
      DIMENSION VC(NM,NM,NG,NG),VSCF(NM,NG),VTR(NM,NM,NM,NG,NG,NG)
      DIMENSION VEC(NDET,NDET),VMP(NDET,NVST)
      DIMENSION IVST(NVST,NM),ICAST(NDET,NM)
      DIMENSION EMP0(NVST)
      DIMENSION OVRLP(NM),JVIRT(NVST,NM)
      DIMENSION IREF(NM),JREF(NM),KREF(NM)
      DIMENSION ECAS(NM4+1),EQDPT2(NM4+1)
C
C     ===== DEGENERATE PERTURBATION THEORY =====
C
C     KREF = SCF REFERENCE STATE
C
      CASMIN = .TRUE.
      NCOUP = 2
C
C     ----- DETERMINE CI EIGENSTATE OF INTEREST -----
C
      CALL WHEST(VEC,IREF,KREF,ICAST,IMP,OVRLP,NM,NDET,ITHVEC,
     *           ISVIB)
C
      IST         = III + 1
C
C     ----- SET UP MP2 -----
C
      DO I=1,ISVIB
         KREF(I) = KREF(I) - 1
      END DO
C
      IF(CASMIN) THEN
         CALL QDPT(EMP2,EMP0,WAVE,VMP,VIRTE,VC,VTR,VSCF,DX,OVRLP,
     *           NM,NG,NST,NVST,IVST,IREF,JREF,JVIRT,NCOUP,NDET,
     *           VEC,ICAST,III,ITHVEC,EPT2,SMALL,DBG,ISVIB)
      END IF
C
C     ----- WRAP UP ----
C
      EQDPT2(IST) = ECAS(IST) + EPT2
C
      RETURN
      END
C
C*MODULE VSCF    *DECK GETWAV
      SUBROUTINE GETWAV(WAVE,IREF,NM,NST,NG,VWAVE,ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION WAVE(NM,NST,NG),IREF(NM),VWAVE(NM,NG)
C
      DO I=1,ISVIB
         IST = IREF(I)
         DO J=1,NG
            VWAVE(I,J) = WAVE(I,IST,J)
         END DO
      END DO
      RETURN
      END
C
C*MODULE VSCF    *DECK WHEST
      SUBROUTINE WHEST(VEC,IREF,KREF,ICAST,IMP,OVRLP,NM,NDET,ITHVEC,
     *                 ISVIB)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION VEC(NDET,NDET),IREF(NM),KREF(NM),ICAST(NDET,NM)
      DIMENSION OVRLP(NM),IMP(NM)
C
C     ----- DETERMINE EIGENSTATE OF INTEREST -----
C
      IADD = 0
      DO I=1,NDET
         CALL WHDET(I,VEC,IREF,ICAST,NM,NDET,IWHCH,ISVIB)
         CALL REAREF(IREF,IMP,OVRLP,NM,IADD,ISVIB)
         DO J=1,ISVIB
            KTHREF = KREF(J) - 1
            IF(IREF(J).NE.KTHREF) GOTO 1000
         END DO
         GOTO 2000
 1000 END DO
 2000 CONTINUE
      ITHVEC = I
      RETURN
      END
C
C*MODULE VSCF    *DECK FILEMP0
      SUBROUTINE FILEMP0(IVST,ESCF,JVIRT,NVST,NM,NST,EMP0,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION IVST(NVST,NM),JVIRT(NVST,NM)
      DIMENSION ESCF(NM,NST),EMP0(NVST)
      PARAMETER (ZERO=0.0D+00)
C
      DO J=1, NVST
         EMP0(J)=ZERO
         DO I=1, ISVIB
            JVIRT(J,I)=IVST(J,I)+1
            EMP0(J)=EMP0(J)+ESCF(I,JVIRT(J,I))
         END DO
      END DO
C
      RETURN
      END
C
C*MODULE VSCF    *DECK QDPT
      SUBROUTINE QDPT(EMP2,EMP0,WAVE,VMP,ESCF,VC,VTR,VSCF,DX,OVRLP,
     *           NM,N,NST,NVST,IVST,IREF,JREF,JVIRT,NCOUP,NDET,
     *           CIVEC,ICAST,ISTATE,ITHVEC,EQDPT2,SMALL,DBG,ISVIB)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DBG
      DIMENSION WAVE(NM,NST,N),VC(NM,NM,N,N),VTR(NM,NM,NM,N,N,N)
      DIMENSION VSCF(NM,N),ESCF(NM,NST),DX(NM),IREF(NM)
      DIMENSION IVST(NVST,NM),JVIRT(NVST,NM),JREF(NM),VMP(NDET,NVST)
      DIMENSION EMP0(NVST),OVRLP(NM)
      DIMENSION CIVEC(NDET,NDET),ICAST(NDET,NM)
      PARAMETER (ZERO=0.0D+00)
C
C     IWHCH = WHICH STATE OF INTEREST
C
      IWHCH = ISTATE + 1
C     WRITE(6,9002) ISTATE
C9002 FORMAT(2X,'STATE OF INTEREST = ',I3)
      EQDPT2= ZERO
      NKEEP = 0
C
C     ----- FILL EMP0 ARRAY -----
C
      CALL FILEMP0(IVST,ESCF,JVIRT,NVST,NM,NST,EMP0,ISVIB)
C
C     ----- DECIDE ON WHICH CI STATE WE ARE LOOKING AT -----
C
      DO I=1,NDET
         CALL WHDET(I,CIVEC,IREF,ICAST,NM,NDET,IDET,ISVIB)
      END DO
C
C     ----- DO INTEGRALS ----- FIRST SET OF INTEGRALS ARE DONE
C
      DO ICI=2,NDET
         DO JMODE=1,ISVIB
           IREF(JMODE) = ICAST(ICI,JMODE)
         END DO
         IQDPT = ICI
C
            CALL MPPTORIG(EMP2,EMP0,WAVE,VMP,ESCF,VC,VTR,VSCF,
     *                    DX,OVRLP,NM,N,NST,NVST,IVST,
     *                    IREF,JREF,JVIRT,NCOUP,DBG,NDET,
     *                    IQDPT,SMALL,ISVIB)
C
      END DO
C
      DO I=1,ISVIB
         IREF(I) = IREF(I) + 1
      END DO
C
C     ----- 2ND ORDER ENERGY CORRECTION -----
C
         EQDPT2 = ZERO
         SUMV = ZERO
C
C     ----- LOOP OVER ALL VIRTUAL STATE -----
C
C     DO J=1,10
      DO J=1,NVST
         SUMV = ZERO
         DO I=1,ISVIB
            JREF(I) = IVST(J,I)
         END DO
C
C     ----- SKIP IF SCF STATE BELONG TO CI SPACE -----
C
      DO K1=1,NDET
         ISUM = 0
         DO I=1,ISVIB
            IREF(I) = ICAST(K1,I)
            IF(IREF(I) .EQ. JREF(I)) ISUM = ISUM + 1
         END DO
         IF(ISUM .EQ. ISVIB) GOTO 5000
      END DO
C
C     ----- LOOP OVER DETERMINANTS -----
C
      DO K1=1,NDET
         DO I=1,ISVIB
            IREF(I) = ICAST(K1,I)
         END DO
C
         CICOF1 = CIVEC(K1,ITHVEC)
         VMPCI1 = VMP(K1,J)*CICOF1
         DO K2=1,NDET
            CICOF2 = CIVEC(K2,ITHVEC)
            VMPCI2 = VMP(K2,J)*CICOF2
            CIV1 = CICOF1*VMPCI1
            CIV2 = CICOF2*VMPCI2
            SUMV = SUMV + CIV1*CIV2
         END DO
      END DO
      SUME = EMP0(IWHCH) - EMP0(J)
      IF (ABS(SUME).LT.SMALL) THEN
         SUMV=ZERO
      END IF
      EQDPT2 = EQDPT2 + (SUMV/SUME)
      IF (ABS(SUMV/SUME).GT.1.0D-08) THEN
         NKEEP=NKEEP+1
      ELSE
C        WRITE(6,*) 'SKIP J =',J
      END IF
C
C     ----- END OF LOOP -----
C
 5000 END DO
C
      RETURN
      END
C
C----------------------------------------------------------------------
C     ------------------------------------------------------------
C     --  CONSTRUCTION OF TWO-MODE REPRESENTATION QFF IN TERMS  --
C     --  OF NORMAL COORDINATES                                 --
C     --                                                        --
C     --  ROUTINES                                              --
C     --  >  MKQFF                                              --
C     --  >  Q2X                                                --
C     --  >  GOENX                                              --
C     --  >  QFF1                                               --
C     --  >  QFF2                                               --
C     --                                                        --
C     --                  CODE DESCRIPTION BY KIYOSHI YAGI      --
C     --                  YAGI@QCL.T.U-TOKYO.AC.JP              --
C     ------------------------------------------------------------
C----------------------------------------------------------------------
C
C*MODULE VSCF    *DECK MKQFF
      SUBROUTINE MKQFF(NC1,NAT1,NNM,NNM2,NCOUP,C0,EIG,VEC,STPSZ,
     *                 E0,DMX0,DMY0,DMZ0,BLANK,IRC,Q,DE1,DE2,
     *                 STP1,DDPL1,DDPL2,HII,TIII,UIIII,TIIJ,
     *                 UIIIJ,UIIJJ,DGI,DHII,DTIII,DUIIII,
     *                 IMODE,ISVIB,DM_LIST,DMPACK,CUR_IRC,
     *                 DATA_IRC,QFF_COM,FIN_IRC,NROW_DM,NCOL,
     *                 PETYP,MASTID,INTCRD,DX,DVEC,NZVAR,INTTYP,
     *                 NCOUNT1,NCOUNT2,PESALL,CHOOSEN,STPSZX,
     *                 COORD_ALL,NGRID,RQ,DELCOR,ZMAT_CUR,
     *                 ZMAT_OLD,IZMAT,ITYP,ICONNCT,NZMAT)
C
C----------------------------------------------------------------------
C
C     ---- PURPOSE
C     COMPUTE COEFFICIENTS IN QFF BY NUMERICAL DIFFERENTIATIONS OF
C     THE ENERGY.
C
C     ---- INPUT PARAMETERS ----
C     NC1  : NAT1*3
C     NAT1 : THE NUMBER OF ATOMS
C     NNM  : THE NUMBER OF MODES
C     NCOUP: MAX NUMBER OF NORMAL MODES TO BE COUPLED
C     C0   : THE EQUILIBRIUM GEOMETRY (BOHR)
C     EIG  : EIGENVALUES OF THE HESSIAN MATRIX (HARTREE/AMU-BOHR^2)
C     VEC  : NORMAL DISPLACEMENT VECTORS * M**(-1/2) (AMU**(-1/2))
C     STPSZ: A STEPSIZE FOR NUMERICAL DIFFERENCIATIONS
C     E0   : THE ENERGY AT C0 (HARTREE)
C     DMX0 : X COMPONENT OF DIPOLE MOMENT AT C0 (DEBYE)
C     DMY0 : Y COMPONENT OF DIPOLE MOMENT AT C0 (DEBYE)
C     DMZ0 : Z COMPONENT OF DIPOLE MOMENT AT C0 (DEBYE)
C     BLANK: UNDOCUMENTED KEYWORD
C     IRC  : A FILE SPECIFIER FOR .IRC FILE
C----------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER DDI_WORLD,DDI_GROUP,DDI_MASTER,DM_LIST,QFF_COM,FIN_IRC
C
      PARAMETER(DDI_WORLD=0,DDI_GROUP=1,DDI_MASTER=2,
     *          H2J=2.6255D+06, BOHR=0.5291772D+00, HBAR=1.054573D-34,
     *          AVOGADRO=6.022137D+23, ZERO=0.0D+00, ONE=1.0D+00,
     *          MXATM=2000, MXFRG=1050)
C
      LOGICAL BLANK,GOPARR,DSKWRK,MASWRK,INTCRD,ISGDDI,PAROUT,
     *        INITGDDI,MYJOB,PESALL,CHOOSEN
C
      CHARACTER*6 PETYP
C
      DIMENSION C0(3,NAT1),STP1(NC1),EIG(NC1),VEC(NC1,NC1),
     *          Q(NNM),DE1(6,NNM),DE2(12,NNM2),DDPL1(18,NNM),
     *          DDPL2(36,NNM2),HII(NNM),TIII(NNM),UIIII(NNM),
     *          TIIJ(NNM2*2),UIIIJ(NNM2*2),UIIJJ(NNM2),
     *          DGI(3,NNM),DHII(3,NNM),DTIII(3,NNM),DUIIII(3,NNM),
     *          DVEC(NZVAR,NC1),
     *          DPL0(3),DQI(12),DQJ(12),IMODE(NC1),DMPACK(NROW_DM),
     *          QFF_COM(NCOL),FIN_IRC(NCOL),CUR_IRC(NCOL),
     *          DATA_IRC(NROW_DM),MASTID(*),DX(NC1),
     *          NCOUNT1(ISVIB),NCOUNT2(ISVIB,ISVIB),
     *          CHOOSEN(ISVIB,ISVIB),RQ(NNM,NGRID),
     *          COORD_ALL(NCOL,3*NAT1),STPSZX(3*MXATM+6*MXFRG),
     *          DELCOR(NC1),ZMAT_CUR(NZVAR),ZMAT_OLD(NZVAR),
     *          IZMAT(NZMAT),ITYP(NZVAR),ICONNCT(NZVAR,4)
C
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /GDDI  / ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
C
      DATA DQI / 3.0D+00, 1.0D+00, 1.0D+00, 3.0D+00, 1.0D+00, 1.0D+00,
     *          -1.0D+00,-1.0D+00,-3.0D+00,-1.0D+00,-1.0D+00,-3.0D+00/
      DATA DQJ / 1.0D+00, 1.0D+00, 3.0D+00,-1.0D+00,-1.0D+00,-3.0D+00,
     *           3.0D+00, 1.0D+00, 1.0D+00,-3.0D+00,-1.0D+00,-1.0D+00/
C----------------------------------------------------------------------
C
      IF(ISGDDI) CALL DDI_COMMID(DDI_WORLD,IDWORLD)
C
      IF(MASWRK) THEN
         WRITE(IW,1000)
C
C        >>> INITIALIZE
         NSTART=NC1-ISVIB+1
         DPL0(1)=DMX0
         DPL0(2)=DMY0
         DPL0(3)=DMZ0
         CALL VCLR(Q    ,1,   NNM)
         IF(STPSZX(1).EQ.ZERO) THEN
            ISTART=ISVIB
            DO IM=1,ISVIB
               STPSZX(ISTART)=ONE
               ISTART = ISTART-1
            END DO
         END IF
C
C        >>> SETUP STEPSIZES FOR EACH MODES
C
         FACT=SQRT(H2J/BOHR/BOHR*1.0D+23)
         ISTART=ISVIB
         DO IM=1,ISVIB
            I=NC1-IMODE(IM)+1
            OMEGA=SQRT(EIG(I))*FACT
            STP1(I)=STPSZ*SQRT(HBAR*AVOGADRO*1.0D+23/OMEGA)/BOHR
            STP1(I)=STP1(I)*STPSZX(ISTART)
            ISTART = ISTART-1
            STP4=STP1(I)*STP1(I)*STP1(I)*STP1(I)
C         > CHECK
            PREC4=1.0D-08/STP4
            IF(PREC4.GT.1.0D+00) THEN
C             > STPSZ IS TOO SMALL,
                IF(MASWRK) WRITE(IW,9300)
                CALL ABRT
            ELSEIF(PREC4.GT.1.0D-02) THEN
C             > PRINT WARNING MESSAGES AND CONTINUE
                IF(MASWRK) WRITE(IW,9400) PREC4
            ENDIF
         END DO
      END IF
      CALL DDI_BCAST(827,'F',DPL0,3,MASTER)
      CALL DDI_BCAST(828,'F',STP1,NC1,MASTER)
C
      IF(MASWRK) THEN
         WRITE(IW,1150)
         WRITE(IW,1170) (I,STP1(I),I=NC1,NSTART,-1)
      ENDIF
C
C     GENERATE ALL THE POINTS ON PES IF INTERNAL COORDINATES
C     NORMAL MODE DISPLACEMENT IS BEING USED
C
      IF(INTCRD .AND. NAT1.GT.0) THEN
         INPUT=1
         CALL CONVRT2(PETYP,NCOUP,NGRID,ISVIB,NNM,NAT1,NC1,NZVAR,NCOL,
     *                IMODE,COORD_ALL,C0,DX,FACT,DVEC,RQ,DELCOR,VEC,
     *                NCOUNT1,NCOUNT2,PESALL,CHOOSEN,STP1,ZMAT_CUR,
     *                ZMAT_OLD,INTTYP,NZMAT,IZMAT,ITYP,ICONNCT,INPUT)
         CALL DDI_BCAST(829,'F',COORD_ALL,NCOL*3*NAT1,MASTER)
      END IF
C
      NPTOT1 = ISVIB*6
      NPTOTL = NPTOT1
      IF(MASWRK) WRITE(IW,1100) NPTOT1
      IF(NCOUP.EQ.2) THEN
         NPTOT2 = ISVIB*(ISVIB-1)/2*12
         NPTOTL = NPTOTL + NPTOT2
         IF(MASWRK) WRITE(IW,2100) NPTOT2
      END IF
      IF(MASWRK) WRITE(IW,2150) NPTOTL
C
C   -----   ONE-MODE TERMS   -----
C
         IF(ISGDDI) THEN
             CALL GDDI_SCOPE(DDI_GROUP)
             CALL GDDI_MASTID(MASTID)
             CALL GDDICOUNT(-1,LGROUP,MYJOB)
         END IF
C
C        >>>  COMPUTE THE ENERGIES AND DIPOLE MOMENTS AT GRIDS
C
         IF(.NOT.BLANK) THEN
C
            DO IM=1,ISVIB
               I=NC1-IMODE(IM)+1
C
               DO IL=1,6
                  ID_DM = (IM-1)*6 + IL
                  NPT = NPTOTL - ID_DM + 1
                  IF(QFF_COM(ID_DM).EQ.1) GOTO 10
                  IF(ISGDDI) THEN
                     CALL GDDICOUNT(0,LGROUP,MYJOB)
                     IF(.NOT.MYJOB) GOTO 10
                  END IF
                  IF(IL.LT.4) THEN
                     DQ=4.0D+00 - IL
                  ELSE
                     DQ=3.0D+00 - IL
                  ENDIF
                  IF(MASWRK) WRITE(IW,1200) INT(DQ),I,NPT
CTMP                  Q(IM)= DQ*STPSZ
                  Q(IM)= DQ*STP1(I)
                  IM_CUR = IM
                  JM_CUR = 0
                  IL_CUR = IL
                  CALL GOENX(NC1,NAT1,NNM,C0,VEC,Q,E,DMX,DMY,DMZ,IMODE,
     *                       ISVIB,INTCRD,IM_CUR,JM_CUR,IL_CUR,
     *                       COORD_ALL,NCOL)
                  IF(E.EQ.ZERO .AND. MASWRK) WRITE(IW,9000)
                  DE1(IL,IM)=E
                  DDPL1(IL*3-2,IM)=DMX
                  DDPL1(IL*3-1,IM)=DMY
                  DDPL1(IL*3  ,IM)=DMZ
                  IF(MASWRK)  THEN
                   IF(.NOT.ISGDDI) THEN
                    WRITE(IRC,8210) I,IL,DE1(IL,IM),
     *              DDPL1(IL*3-2,IM),DDPL1(IL*3-1,IM),DDPL1(IL*3,IM)
                    CALL FLSHBF(IRC)
                   ELSE
                    J  = 0
                    K  = 0
                    JL = 0
                    KL = 0
                    CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                        E,DMX,DMY,DMZ)
                    CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                DMPACK,IDWORLD)
                    IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *                               DATA_IRC,NROW_DM,NCOL,
     *                               PETYP,DM_LIST,FIN_IRC)
                    END IF
                  ENDIF
   10 CONTINUE
               END DO
C
               Q(IM)=0.0D+00
C
            END DO
C
         ENDIF
C
         IF(ISGDDI) THEN
            CALL GDDICOUNT(1,LGROUP,MYJOB)
            CALL GDDI_SCOPE(DDI_MASTER)
            IF(MASWRK) THEN
               IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *            DATA_IRC,NROW_DM,NCOL,PETYP,DM_LIST,FIN_IRC)
               CALL DDI_GSUMF(10000,DE1,NNM*6)
               CALL DDI_GSUMF(10000,DDPL1,NNM*18)
            END IF
            CALL GDDI_SCOPE(DDI_WORLD)
         END IF
C
C        >>> COMPUTE THE COEFFICIENTS (ONE MODE TERMS)
C
C           --------- NUMERICAL DIFFERENCIATION ---------
C           |   J= 1 -> +3DQ, =2 -> +2DQ, =3 -> +1DQ,   |
C           |    = 4 -> -1DQ, =5 -> -2DQ, =6 -> -3DQ,   |
C           ---------------------------------------------
C
      IF(MASWRK) THEN
         DO IM=1,ISVIB
            I=NC1-IMODE(IM)+1
C            STP1=STPSZ/SQRT(SQRT(EIG(I)*FACT))
            STP2=STP1(I)*STP1(I)
            STP3=STP2*STP1(I)
            STP4=STP3*STP1(I)
C
            HII(IM)=EIG(I)
            TIII(IM)=(DE1(1,IM)-3.0D+00*DE1(3,IM)
     *               +3.0D+00*DE1(4,IM)-DE1(6,IM))/STP3*0.125D+00
            UIIII(IM)=(DE1(2,IM)-4.0D+00*DE1(3,IM)+6.0D+00*E0
     *                          -4.0D+00*DE1(4,IM)+DE1(5,IM))/STP4
C
            IF(IEMOM.EQ.1) THEN
               DO J=1,3
                   DGI(J,IM)=(DDPL1(6+J,IM)-DDPL1(9+J,IM))
     *                       /STP1(I)*0.5D+00
                  DHII(J,IM)=(DDPL1(6+J,IM)+DDPL1(9+J,IM)
     *                       -2.0D+00*DPL0(J))/STP2
                  DTIII(J,IM)=(DDPL1(J,IM)-3.0D+00*DDPL1(6+J,IM)
     *                       +3.0D+00*DDPL1(9+J,IM)-DDPL1(15+J,IM))
     *                       /STP3*0.125D+00
                  DUIIII(J,IM)=(DDPL1(3+J,IM)-4.0D+00*DDPL1(6+J,IM)
     *                  +6.0D+00*DPL0(J)
     *                  -4.0D+00*DDPL1(9+J,IM)+DDPL1(12+J,IM))/STP4
               END DO
            ENDIF
C
C           ---  OUTPUT THE RESULTS ---
C
C            IF(MASWRK) THEN
               WRITE(IW,1500) I,HII(IM),TIII(IM),UIIII(IM)
               IF(IEMOM.EQ.1) THEN
                  WRITE(IW,1510) (DGI(J,IM),DHII(J,IM),
     *                        DTIII(J,IM),DUIIII(J,IM),J=1,3)
               ENDIF
               CALL FLSHBF(IRC)
C            END IF
C
         END DO
      END IF
      CALL DDI_BCAST(830,'F',HII,NNM,MASTER)
      CALL DDI_BCAST(831,'F',TIII,NNM,MASTER)
      CALL DDI_BCAST(832,'F',UIIII,NNM,MASTER)
      CALL DDI_BCAST(833,'F',DGI,3*NNM,MASTER)
      CALL DDI_BCAST(834,'F',DHII,3*NNM,MASTER)
      CALL DDI_BCAST(835,'F',DTIII,3*NNM,MASTER)
      CALL DDI_BCAST(836,'F',DUIIII,3*NNM,MASTER)
C
      IF(NCOUP.LE.1) RETURN
C
C   -----   TWO-MODE COUPLING TERMS   -----
C
         IF(ISGDDI) THEN
            CALL GDDI_SCOPE(DDI_GROUP)
            CALL GDDI_MASTID(MASTID)
            CALL GDDICOUNT(-1,LGROUP,MYJOB)
         END IF
C
         KM1=1
C
C        >>>  COMPUTE THE ENERGIES AND DIPOLE MOMENTS AT GRIDS
C
         IF(.NOT.BLANK) THEN
C
            DO IM=1,ISVIB-1
               I=NC1-IMODE(IM)+1
               DO JM=IM+1,ISVIB
                  J=NC1-IMODE(JM)+1
                  IF(.NOT.PESALL .AND. .NOT.CHOOSEN(IM,JM)) GO TO 30
C
C                 --> COUPLINGS BETWEEN Q(IM) AND Q(JM)
C
                  DO IL=1,12
                    NPAIR = JM - IM
                    IF(IM.GT.1) THEN
                       DO IC = 1, IM-1
                          NPAIR = NPAIR + (ISVIB - IC)
                       END DO
                    END IF
                    ID_DM = ISVIB*6 + (NPAIR-1)*12 + IL
                    NPT = NPTOTL - ID_DM + 1
                    IF(QFF_COM(ID_DM).EQ.1) GOTO 20
                    IF(ISGDDI) THEN
                       CALL GDDICOUNT(0,LGROUP,MYJOB)
                       IF(.NOT.MYJOB) GOTO 20
                     END IF
                     IF(MASWRK) WRITE(IW,2200)
     *                          INT(DQI(IL)),I,INT(DQJ(IL)),J,NPT
C                     Q(IM)= DQI(IL)*STPSZ
C                     Q(JM)= DQJ(IL)*STPSZ
                     Q(IM)= DQI(IL)*STP1(I)
                     Q(JM)= DQJ(IL)*STP1(J)
                     IM_CUR = IM
                     JM_CUR = JM
                     IL_CUR = IL
                     CALL GOENX(NC1,NAT1,NNM,C0,VEC,Q,E,DMX,DMY,DMZ,
     *                          IMODE,ISVIB,INTCRD,IM_CUR,JM_CUR,
     *                          IL_CUR,COORD_ALL,NCOL)
                     IF(E.EQ.ZERO .AND. MASWRK) WRITE(IW,9000)
                     DE2(IL,KM1)=E
                     DDPL2(IL*3-2,KM1)=DMX
                     DDPL2(IL*3-1,KM1)=DMY
                     DDPL2(IL*3,KM1)=DMZ
C
                     IF(MASWRK)  THEN
                       IF(.NOT.ISGDDI) THEN
                       WRITE(IRC,8220) I,J,IL,E,DMX,DMY,DMZ
                       CALL FLSHBF(IRC)
                      ELSE
                       K  = 0
                       JL = 0
                       KL = 0
                       CALL PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,
     *                           E,DMX,DMY,DMZ)
                       CALL DDI_PUT_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,
     *                                   DMPACK,IDWORLD)
                       IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *                                  DATA_IRC,NROW_DM,NCOL,
     *                                  PETYP,DM_LIST,FIN_IRC)
                      END IF
                     END IF
   20 CONTINUE
                  END DO
   30 CONTINUE
                  Q(IM)=0.0D+00
                  Q(JM)=0.0D+00
C
                  KM1=KM1+1
               END DO
            END DO
         END IF
         IF(ISGDDI) THEN
            CALL GDDICOUNT(1,LGROUP,MYJOB)
            CALL GDDI_SCOPE(DDI_MASTER)
            IF(MASWRK) THEN
               IF(MYGROUP.EQ.0) CALL IRC_OUT(CUR_IRC,
     *            DATA_IRC,NROW_DM,NCOL,PETYP,DM_LIST,FIN_IRC)
               CALL DDI_GSUMF(10000,DE2,NNM2*12)
               CALL DDI_GSUMF(10000,DDPL2,NNM2*36)
            END IF
            CALL GDDI_SCOPE(DDI_WORLD)
          END IF
C
C     >>> COMPUTE COEFFICIENTS (TWO MODE TERMS)
C
      IF(MASWRK) THEN
      KM1=1
      KM2=1
      DO IM=1,ISVIB-1
         I=NC1-IMODE(IM)+1
C-         STP1I=STPSZ/SQRT(SQRT(EIG(I)*FACT))
         STP2I=STP1(I)*STP1(I)
         STP3I=STP2I*STP1(I)
C-         STP4I=STP3I*STP1(I)
            DO JM=IM+1,ISVIB
               J=NC1-IMODE(JM)+1
C-               STP1J=STPSZ/SQRT(SQRT(EIG(J)*FACT))
               STP2J=STP1(J)*STP1(J)
               STP3J=STP2J*STP1(J)
C-               STP4J=STP3J*STP1(J)
C
               TIIJ(KM2)  =(DE2(2,KM1)-2.0D+00*DE1(3,JM)+DE2(8,KM1)
     *                   -DE2(5,KM1)+2.0D+00*DE1(4,JM)-DE2(11,KM1))
     *                   /STP2I/STP1(J)*0.5D+00
C-     *                   /STP3*0.5D+00
               TIIJ(KM2+1)=(DE2(2,KM1)-2.0D+00*DE1(3,IM)+DE2(5,KM1)
     *                   -DE2(8,KM1)+2.0D+00*DE1(4,IM)-DE2(11,KM1))
     *                   /STP2J/STP1(I)*0.5D+00
C-     *                   /STP3*0.5D+00
               UIIIJ(KM2)  =(DE2(1,KM1)-3.0D+00*DE2(2,KM1)
     *                      +3.0D+00*DE2(8,KM1)-DE2(9,KM1)
     *                      -DE2(4,KM1)+3.0D+00*DE2(5,KM1)
     *                      -3.0D+00*DE2(11,KM1)+DE2(12,KM1))
     *                   /STP3I/STP1(J)*0.0625D+00
C-     *                   /STP4*0.0625D+00
               UIIIJ(KM2+1)=(DE2(3,KM1)-3.0D+00*DE2(2,KM1)
     *                      +3.0D+00*DE2(5,KM1)-DE2(6,KM1)
     *                      -DE2(7,KM1)+3.0D+00*DE2(8,KM1)
     *                      -3.0D+00*DE2(11,KM1)+DE2(10,KM1))
     *                   /STP3J/STP1(I)*0.0625D+00
C-     *                   /STP4*0.0625D+00
               DEE1=DE1(3,IM)+DE1(4,IM)+DE1(3,JM)+DE1(4,JM)
               UIIJJ(KM1)  =(DE2(2,KM1)+DE2(8,KM1)
     *                      +DE2(5,KM1)+DE2(11,KM1)
     *                      -2.0D+00*DEE1+4.0D+00*E0)/STP2I/STP2J
C-     *                      -2.0D+00*DEE1+4.0D+00*E0)/STP4
C
C              ---  OUTPUT THE RESULTS ---
C
               IF(MASWRK) THEN
                  WRITE(IW,2500) I,J,TIIJ(KM2),TIIJ(KM2+1),
     *              UIIIJ(KM2),UIIIJ(KM2+1),UIIJJ(KM1)
                  CALL FLSHBF(IRC)
               END IF
C
               KM1=KM1+1
               KM2=KM2+2
            END DO
      END DO
      END IF
      CALL DDI_BCAST(837,'F',TIIJ,NNM2*2,MASTER)
      CALL DDI_BCAST(838,'F',UIIIJ,NNM2*2,MASTER)
      CALL DDI_BCAST(839,'F',UIIJJ,NNM2,MASTER)
C
         RETURN
C
C     WRITE IN .IRC
 8210 FORMAT('MODE=',I4,/
     *       ' GRID=',I4,/
     *       '   DE1  =',F20.10,' DDPL1 =',3F14.8)
 8220 FORMAT('MODE=',2I4,/
     *       ' GRID=',I4,/
     *       '   DE2  =',F20.10,' DDPL2 =',3F14.8)
C
 1000 FORMAT(/,7X,19('-'),/,7X,'QUARTIC FORCE FIELD',/,7X,19('-'),/)
 1100 FORMAT(/,1X,'QFF> COMPUTE THE ENERGIES AND DIPOLE MOMENTS AT ',
     *         'GRIDS ( ONE-MODE TERMS ).',/,
     *       1X,'QFF> ENERGIES AT 6 GRIDS ALONG EACH NORMAL ',
     *         'COORDINATES ARE REQUIRED.',/,
     *       1X,'QFF> -- ',I6.6,' POINTS FOR ONE-MODE TERMS.',/)
 1150 FORMAT(1X,'QFF> -- STEPSIZE FOR NORMAL COORDINATES')
 1170 FORMAT(1X,'QFF>    ',I5,F12.2,' / AMU**0.5-BOHR')
 1200 FORMAT(/,1X,'QFF> ENERGY FOR',I2,'DQ ALONG MODE ',I3.3,
     *         ': ',I6.6,' POINTS LEFT.',/)
 1500 FORMAT(1X,'QFF>  MODE= ',I3,/,
     *  1X,'QFF>     HII= ',D16.8,' [HARTREE/AMU-BOHR**2]'/,
     *  1X,'QFF>    TIII= ',D16.8,' [HARTREE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF>   UIIII= ',D16.8,' [HARTREE/AMU**2-BOHR**4]'/)
 1510 FORMAT(1X,'QFF>    DMXI= ',D16.8,' [DEBYE/AMU**(1/2)-BOHR]'/,
     *  1X,'QFF>   DMXII= ',D16.8,' [DEBYE/AMU-BOHR**2]'/,
     *  1X,'QFF>  DMXIII= ',D16.8,' [DEBYE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF> DMXIIII= ',D16.8,' [DEBYE/AMU**2-BOHR**4]'/,
     *  1X,'QFF>    DMYI= ',D16.8,' [DEBYE/AMU**(1/2)-BOHR]'/,
     *  1X,'QFF>   DMYII= ',D16.8,' [DEBYE/AMU-BOHR**2]'/,
     *  1X,'QFF>  DMYIII= ',D16.8,' [DEBYE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF> DMYIIII= ',D16.8,' [DEBYE/AMU**2-BOHR**4]'/,
     *  1X,'QFF>    DMZI= ',D16.8,' [DEBYE/AMU**(1/2)-BOHR]'/,
     *  1X,'QFF>   DMZII= ',D16.8,' [DEBYE/AMU-BOHR**2]'/,
     *  1X,'QFF>  DMZIII= ',D16.8,' [DEBYE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF> DMZIIII= ',D16.8,' [DEBYE/AMU**2-BOHR**4]'/)
 2100 FORMAT(/,1X,'QFF> COMPUTE THE ENERGIES AND DIPOLE MOMENTS AT ',
     *         'GRIDS ( TWO-MODE TERMS ).',/,
     *       1X,'QFF> ENERGIES AT 12 GRIDS FOR EACH COUPLE OF ',
     *         'NORMAL COORDINATES ARE REQUIRED.',/,
     *       1X,'QFF> -- ',I6.6,' POINTS FOR TWO-MODE TERMS.',/)
 2150 FORMAT(3X,'TOTAL NUMBER OF POINTS = ',I10.10)
 2200 FORMAT(/,1X,'QFF> ENERGY FOR',I2,'DQ ALONG MODE ',I3.3,
     *          ' AND',I2,'DQ ALONG MODE ', I3.3,
     *          ': ',I6.6,' POINTS LEFT.',/)
 2500 FORMAT(1X,'QFF>  MODE (I,J)=( ',I3,', ',I3,')',/,
     *  1X,'QFF>    TIIJ= ',D16.8,' [HARTREE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF>    TJJI= ',D16.8,' [HARTREE/AMU**(3/2)-BOHR**3]'/,
     *  1X,'QFF>   UIIIJ= ',D16.8,' [HARTREE/AMU**2-BOHR**4]'/,
     *  1X,'QFF>   UJJJI= ',D16.8,' [HARTREE/AMU**2-BOHR**4]'/,
     *  1X,'QFF>   UIIJJ= ',D16.8,' [HARTREE/AMU**2-BOHR**4]'/)
 9000 FORMAT(1X,4(2H*-),'*'/1X,'ERROR TERMINATION !'/1X,4(2H*-),'*'/
     *       1X,'SCF HAS NOT CONVERGED!')
 9300 FORMAT(1X,'QFF> *** ERROR, STPSZ IS TOO SMALL')
 9400 FORMAT(1X,'QFF> *** WARNING, STPSZ MAY BE TOO SMALL.',/,
     *       1X,'QFF> *** FOURTH-ORDER DERIVATIVES SMALLER THAN ',
     *          D9.1,' MAY OVERFLOW.')
C
      END
C
C----------------------------------------------------------------------
C
C*MODULE VSCF    *DECK Q2X
      SUBROUTINE Q2X(NC1,NAT1,NNM,C0,VEC,QIN,IMODE,ISVIB,INTCRD,IM,JM,
     *               IL,MOVE,COORD_ALL,NCOL)
C
C     ---- PURPOSE
C     TRANSFORMATION FROM Q TO X
C
C     ---- INPUT PARAMETERS
C     NC1 : NAT1*3 + 6*NFRG
C     NAT1: THE NUMBER OF ATOMS
C     NNM : THE NUMBER OF MODES
C     C0  : THE GEOMETRY WHERE VEC IS DEFINED, WHICH IS USUALLY
C           THE EQUILIBRIUM GEOMETRY.
C     VEC : NORMAL DISPLACEMENT VECTORS * M**(-1/2) (/AMU**(-1/2))
C     QIN : NORMAL COORDINATES
C
C     ---- OUTPUT
C     C: CARTESIAN COORDINATES IN BOHR
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL INTCRD,GOPARR,DSKWRK,MASWRK
C
      CHARACTER*6 FRGNAM
      CHARACTER*8 FRGNME
      CHARACTER*8 PTNAM
C
      PARAMETER (MXATM=2000, MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12, ZERO=0.0D+00)
C
      DIMENSION C0(3,NAT1),VEC(NC1,NC1),QIN(NNM),
     *          IMODE(NC1),COORD_ALL(NCOL,3*NAT1)
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 /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(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 /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 /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF(NAT1.GT.0) THEN
         IF(INTCRD) THEN
            IF(JM.EQ.0) THEN
               ID_DM = (IM-1)*6 + IL
            ELSE
               NPAIR = 0
               DO IC = 1, IM-1
                  NPAIR = NPAIR + (ISVIB - IC)
               END DO
               NPAIR = NPAIR + (JM-IM-1)
               ID_DM = ISVIB*6 + NPAIR*12 + IL
            END IF
            JQ = 1
            DO M = 1,NAT1
              C(1,M) = COORD_ALL(ID_DM,JQ)
              C(2,M) = COORD_ALL(ID_DM,JQ+1)
              C(3,M) = COORD_ALL(ID_DM,JQ+2)
              JQ = JQ + 3
            END DO
         END IF
         IF(.NOT.INTCRD) THEN
            IF(MASWRK) WRITE(IW,9010)
            I = NC1 - IMODE(IM) + 1
            J = NC1 - IMODE(JM) + 1
            MN = 0
            DO M = 1, NAT1
               DO N = 1, 3
                  MN = MN + 1
                  IF(J.EQ.0) THEN
                     C(N,M) = C0(N,M) + VEC(MN,I)*QIN(IM)
                  ELSE
                     C(N,M) = C0(N,M) + VEC(MN,I)*QIN(IM)
     *                      + VEC(MN,J)*QIN(JM)
                  END IF
               END DO
            END DO
         END IF
      END IF
C
      IF(NFRG.GT.0) THEN
         ID = NC1 - IMODE(IM) + 1
         JD = 0
         KD = 0
         RQD1I = QIN(IM)
         RQD2I = 0
         RQD2J = 0
         RQD3I = 0
         RQD3J = 0
         RQD3K = 0
         IF(JM.GT.0) THEN
            JD = NC1 - IMODE(JM) + 1
            RQD2I = QIN(IM)
            RQD2J = QIN(JM)
         END IF
         CALL MOVEFP(MOVE,ID,JD,KD,VEC,NAT1,NC1,
     *               RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
      END IF
C
      IF(MASWRK .AND. MOVE.EQ.1) THEN
C
C       PRINT OUT THE COORDINATES OF AB INITIO ATOMS
C
         IF(NAT1.GT.0) THEN
            WRITE(IW,9050)
            DO IAT = 1,NAT1
               WRITE(IW,9060) IAT, ZAN(IAT),
     *                        C(1,IAT),C(2,IAT),C(3,IAT)
            ENDDO
         END IF
C
C      PRINT OUT THE COORDINATES OF EFP
C
         IF(NFRG.GT.0) THEN
            WRITE(IW,9210)
            WRITE(IW,9220)
            IAT=0
            KMASS=0
            DO 120 IFRG=1,NFRG
               WRITE(IW,9230) FRGNAM(IFRG)
               DO 110 IV=1,NMPTS(IFRG)
                  IAT=IAT+1
                  IF(FMASS(IV+KMASS).GT.ZERO) THEN
                     XF = EFC(1,IAT)
                     YF = EFC(2,IAT)
                     ZF = EFC(3,IAT)
                     WRITE(IW,9240) FRGNME(IAT),XF,YF,ZF
                  END IF
  110          CONTINUE
               KMASS=KMASS+NMPTS(IFRG)
  120       CONTINUE
         END IF
      END IF
C
      RETURN
C
C            INTERNAL NORMAL MODE DISPLACEMENTS
 9010 FORMAT(1X,'CARTESIAN NORMAL MODE DISPLACEMENT WAS USED')
C
C            FORMATS FOR PRINTING AB INITIO COORDINATES
 9050 FORMAT(/1X,'ATOM',6X,'ATOMIC',22X,'COORDINATES (BOHR)'/
     *         11X,'CHARGE',9X,'X',19X,'Y',19X,'Z')
 9060 FORMAT(1X,I3,6X,F5.1,F17.10,2F20.10)
C
C            FORMATS FOR PRINTING EFP COORDINATES
 9210 FORMAT(1X,'COORDINATES OF FRAGMENT MULTIPOLE CENTERS (BOHR)')
 9220 FORMAT(1X,'MULTIPOLE NAME',8X,'X',14X,'Y',14X,'Z'/
     *       1X,60(1H-))
 9230 FORMAT(1X,'FRAGNAME=',A6)
 9240 FORMAT(1X,A8,7X,3F15.10)
C
      END
C
C----------------------------------------------------------------------
C
C*MODULE VSCF    *DECK GOENX
      SUBROUTINE GOENX(NC1,NAT1,NNM,C0,VEC,QIN,ENE,DX,DY,DZ,IMODE,ISVIB,
     *                 INTCRD,IM,JM,IL,COORD_ALL,NCOL)
C
C     ---- PURPOSE
C     AN INTERFACE TO ENERGX
C
C     ---- INPUT PARAMETERS
C     NC1 : NAT1*3 + 6*NFRG
C     NAT1: THE NUMBER OF ATOMS
C     NNM : THE NUMBER OF MODES
C     C0  : THE EQUILIBRIUM GEOMETRY (/BOHR)
C     VEC : NORMAL DISPLACEMENT VECTORS * M**(-1/2) (/AMU**(-1/2))
C     QIN : NORMAL COORDINATES (/BOHR AMU**1/2)
C
C     ---- OUTPUT ----
C     ENE : THE ENERGY AT QIN (/HARTREE)
C     DX,DY,DZ: THE DIPOLE MOMENT VECTOR AT QIN ()
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL INTCRD
      PARAMETER(MXATM=2000, MXFRG=1050, MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION C0(3,NAT1),VEC(NC1,NC1),QIN(NNM),IMODE(NC1),
     *          COORD_ALL(NCOL,3*NAT1)
C
      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 /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /XYZPRP/ XP,YP,ZP,
     *                DMX,DMY,DMZ,
     *                QXX,QYY,QZZ,QXY,QXZ,QYZ,
     *                QMXX,QMYY,QMZZ,QMXY,QMXZ,QMYZ,
     *                OXXX,OXXY,OXXZ,OXYY,OYYY,OYYZ,
     *                OXZZ,OYZZ,OZZZ,OXYZ,
     *                OMXXX,OMXXY,OMXXZ,OMXYY,OMYYY,
     *                OMYYZ,OMXZZ,OMYZZ,OMZZZ,OMXYZ
C
      MOVE = 1
      CALL Q2X(NC1,NAT1,NNM,C0,VEC,QIN,IMODE,ISVIB,INTCRD,IM,JM,IL,
     *         MOVE,COORD_ALL,NCOL)
C
C--         WRITE(6,'(''DEBUG'')')
C--         DO I=1,NAT1
C--            WRITE(6,'(3F12.6)') C(:,I)*BOHR
C--         END DO
      CALL ENERGX
      CALL VSCFTM(1)
      ENE=E
      DX=0.0D+00
      DY=0.0D+00
      DZ=0.0D+00
      IF(IEMOM.EQ.1) THEN
         CALL ELMOMC
         DX=DMX
         DY=DMY
         DZ=DMZ
      ENDIF
      IF(NFRG.NE.0) THEN
         MOVE = 0
         CALL Q2X(NC1,NAT1,NNM,C0,VEC,QIN,IMODE,ISVIB,INTCRD,IM,JM,IL,
     *            MOVE,COORD_ALL,NCOL)
      END IF
C
      RETURN
      END
C
C----------------------------------------------------------------------
C
C*MODULE VSCF    *DECK QFF1
      SUBROUTINE QFF1(NNM,IM,Q,V,DX,DY,DZ,
     *                HII,TIII,UIIII,DGI,DHII,DTIII,DUIIII)
C
C     ---- PURPOSE
C     GIVEN A GEOMETRY IN NORMAL COORDINATES, THIS
C     ROUTINE RETURNS THE POTENTIAL ENERGY WITH
C     RESPECT TO THE EQUILIBRIUM ENERGY.
C
C     ---- INPUT PARAMETERS
C     IM   : AN INDEX OF DISPLACED MODE
C     Q    : THE (IM)TH COMPONENT OF NORMAL COORDS  (/BOHR AMU**1/2)
C
C     ---- OUTPUT PARAMETERS
C     V    : POTENTIAL ENERGY (/HARTREE)
C     DX   : X COMPONENT OF DIPOLE MOMENT AT C0 (/)
C     DY   : Y COMPONENT OF DIPOLE MOMENT AT C0 (/)
C     DZ   : Z COMPONENT OF DIPOLE MOMENT AT C0 (/)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DPL(3),HII(NNM),TIII(NNM),UIIII(NNM),
     *          DGI(3,NNM),DHII(3,NNM),DTIII(3,NNM),DUIIII(3,NNM)
C
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
C
      V=0.0D+00
      DX=0.0D+00
      DY=0.0D+00
      DZ=0.0D+00
      DO I=1,3
         DPL(I)=0.0D+00
      END DO
C
      V=V + HII(IM)*Q*Q*0.5D+00
     *    + TIII(IM)*Q*Q*Q/6.0D+00
     *    + UIIII(IM)*Q*Q*Q*Q/24.0D+00
C
      IF(IEMOM.EQ.1) THEN
         DO I=1,3
            DPL(I)=DPL(I)
     *            +DGI(I,IM)*Q
     *            +DHII(I,IM)*Q*Q*0.5D+00
     *            +DTIII(I,IM)*Q*Q*Q/6.0D+00
     *            +DUIIII(I,IM)*Q*Q*Q*Q/24D+00
         END DO
         DX=DPL(1)
         DY=DPL(2)
         DZ=DPL(3)
      END IF
      RETURN
      END
C
C----------------------------------------------------------------------
C
C*MODULE VSCF    *DECK QFF2
      SUBROUTINE QFF2(ISVIB,NNM2,IM,JM,QI,QJ,V,DX,DY,DZ,
     *                TIIJ,UIIIJ,UIIJJ)
C
C     ---- PURPOSE
C     GIVEN A GEOMETRY IN NORMAL COORDINATES, THIS
C     ROUTINE RETURNS THE POTENTIAL ENERGY WITH
C     RESPECT TO THE EQUILIBRIUM ENERGY.
C
C     ---- INPUT PARAMETERS
C     NNM  : THE NUMBER OF NORMAL MODES
C     IM,JM: INDICES OF DISPLACED MODES
C     QI   : THE (IM)TH COMPONENT OF NORMAL COORDINATES (/BOHR AMU**1/2)
C     QJ   : THE (JM)TH COMPONENT OF NORMAL COORDINATES (/BOHR AMU**1/2)
C
C     ---- OUTPUT PARAMETERS
C     V    : POTENTIAL ENERGY (/HARTREE)
C     DX   : X COMPONENT OF DIPOLE MOMENT AT C0 (/)
C     DY   : Y COMPONENT OF DIPOLE MOMENT AT C0 (/)
C     DZ   : Z COMPONENT OF DIPOLE MOMENT AT C0 (/)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION TIIJ(NNM2*2),UIIIJ(NNM2*2),UIIJJ(NNM2)
C
      V=0.0D+00
      DX=0.0D+00
      DY=0.0D+00
      DZ=0.0D+00
C
      IF(IM.GT.JM) THEN
         J=IM
         IM=JM
         JM=J
         Q=QI
         QI=QJ
         QJ=Q
      ENDIF
C
      KM1=(IM-1)*ISVIB-(IM-1)*IM/2+JM-IM
      KM2=KM1*2-1
      V=V +TIIJ(KM2)*QI*QI*QJ*0.5D+00
     *    +TIIJ(KM2+1)*QJ*QJ*QI*0.5D+00
     *    +UIIIJ(KM2)*QI*QI*QI*QJ/6.0D+00
     *    +UIIIJ(KM2+1)*QJ*QJ*QJ*QI/6.0D+00
     *    +UIIJJ(KM1)*QI*QI*QJ*QJ*0.25D+00
      RETURN
      END
C
C*MODULE VSCF    *DECK PACKVSCF
      SUBROUTINE PACKVSCF(DMPACK,NROW_DM,I,J,K,IL,JL,KL,V,DMX,DMY,DMZ)
C
C     DMPACK - ARRAY THAT HOLDS .IRC INFORMATION FOR THE IDM
C              POINT ON THE PES
C     I,J,K,IL,JL,KL POINT ON THE PES MAPPED INTO 1D MATRIX
C     V - DIAGV, COUPV OR TRIPV
C     DMX, DMY, DMZ - DIPOLE MOMENTS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DMPACK(NROW_DM)
C
         DMPACK(1)  = I
         DMPACK(2)  = J
         DMPACK(3)  = K
         DMPACK(4)  = IL
         DMPACK(5)  = JL
         DMPACK(6)  = KL
         DMPACK(7)  = V
         DMPACK(8)  = DMX
         DMPACK(9)  = DMY
         DMPACK(10) = DMZ
C
      RETURN
      END
C
C*MODULE VSCF    *DECK IRC_OUT
      SUBROUTINE IRC_OUT(CUR_IRC,DATA_IRC,NROW_DM,NCOL,PETYP,
     *                   DM_LIST,FIN_IRC)
C
C     DMPACK - ARRAY THAT HOLDS FOLLOWING INFORMATION FOR
C              THE ID_DM POINT ON THE PES
C     I,J,K,IL,JL,KL POINT ON THE PES MAPPED INTO IDM
C     V - DIAGV, COUPV OR TRIPV
C     DMX, DMY, DMZ - DIPOLE MOMENTS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER DM_LIST,FIN_IRC
C
      CHARACTER*6 PETYP
C
      DIMENSION CUR_IRC(NCOL),DATA_IRC(NROW_DM),FIN_IRC(NCOL)
C
      PARAMETER (ZERO = 0.0D+00)
C
      IRC=4
C
      CALL DDI_COMMID(0,IDWORLD)
C
      CALL DDI_GET_COMM(DM_LIST,7,7,1,NCOL,CUR_IRC,IDWORLD)
      DO ID_DM = 1, NCOL
         IF(FIN_IRC(ID_DM).EQ.0 .AND. CUR_IRC(ID_DM).NE.ZERO) THEN
            FIN_IRC(ID_DM) = 1
C
C              GET THE FULL COLUMN OF DATA
C
         CALL DDI_GET_COMM(DM_LIST,1,NROW_DM,ID_DM,ID_DM,DATA_IRC,
     *                     IDWORLD)
         CALL UNPACKVSCF(DATA_IRC,NROW_DM,I,J,K,IL,JL,KL,
     *                   V,DMX,DMY,DMZ)
         IF(PETYP.EQ.'DIRECT') THEN
            IF(J.EQ.0 .AND. K.EQ.0) THEN
               WRITE(IRC,1100) I,IL,V,DMX,DMY,DMZ
               CALL FLSHBF(IRC)
            ELSE IF(J.NE.0 .AND. K.EQ.0) THEN
               WRITE(IRC,1200) I,J,IL,JL,V,DMX,DMY,DMZ
               CALL FLSHBF(IRC)
            ELSE
               WRITE(IRC,1300) I,J,K,IL,JL,KL,V,DMX,DMY,DMZ
               CALL FLSHBF(IRC)
            END IF
         ELSE IF(PETYP.EQ.'QFF   ') THEN
            IF(J.EQ.0) THEN
               WRITE(IRC,2100) I,IL,V,DMX,DMY,DMZ
               CALL FLSHBF(IRC)
            ELSE
               WRITE(IRC,2200) I,J,IL,V,DMX,DMY,DMZ
               CALL FLSHBF(IRC)
            END IF
         END IF
       END IF
      END DO
C
      RETURN
C
C     WRITE IN .IRC FOR PETYP=DIRECT
 1100 FORMAT('MODE=',I4,/
     *       ' GRID=',I4,/
     *       '   DIAGV=',F20.10,' DIPOLE=',3F14.8)
 1200 FORMAT('MODE=',2I4,/
     *       ' GRID=',2I4,/
     *       '   COUPV=',F20.10,' DIPOLE=',3F14.8)
 1300 FORMAT('MODE=',3I4,/
     *       ' GRID=',3I4,/
     *       '   TRIPV=',F20.10,' DIPOLE=',3F14.8)
C
C     WRITE IN .IRC FOR PETYP=QFF
 2100 FORMAT('MODE=',I4,/
     *       ' GRID=',I4,/
     *       '   DE1  =',F20.10,' DDPL1 =',3F14.8)
 2200 FORMAT('MODE=',2I4,/
     *       ' GRID=',I4,/
     *       '   DE2  =',F20.10,' DDPL2 =',3F14.8)
      END
C
C*MODULE VSCF    *DECK UNPACKVSCF
      SUBROUTINE UNPACKVSCF(DATA_IRC,NROW_DM,I,J,K,IL,JL,KL,V,
     *                      DMX,DMY,DMZ)
C
C     DATA_IRC - ARRAY THAT HOLDS FOLLOWING INFORMATION FOR THE IDM
C              POINT ON THE PES
C     I,J,K,IL,JL,KL POINT ON THE PES MAPPED INTO 1D MATRIX
C     V - DIAGV, COUPV OR TRIPV
C     DMX, DMY, DMZ - DIPOLE MOMENTS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION DATA_IRC(NROW_DM)
C
         I   = INT(DATA_IRC(1))
         J   = INT(DATA_IRC(2))
         K   = INT(DATA_IRC(3))
         IL  = INT(DATA_IRC(4))
         JL  = INT(DATA_IRC(5))
         KL  = INT(DATA_IRC(6))
         V   = DATA_IRC(7)
         DMX = DATA_IRC(8)
         DMY = DATA_IRC(9)
         DMZ = DATA_IRC(10)
C
      RETURN
      END
C
C*MODULE VSCF    *DECK INTVEC
      SUBROUTINE INTVEC(VEC,B,D,NC1,NZVAR)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (ZERO=0.0D+00)
C
      DIMENSION VEC(NC1,NC1),B(NZVAR,NC1),D(NZVAR,NC1)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
C
C     ----- CALCULATE NORMAL MODES IN INTERNAL COORDINATES (D) -----
C
      CALL DAREAD(IDAF,IODA,B,NZVAR*NC1,49,0)
      DO I=1,NZVAR
         DO J=1,NC1
             SUM=ZERO
             DO K=1,NC1
                SUM=SUM+B(I,K)*VEC(K,J)
             END DO
             D(I,J)=SUM
        END DO
      END DO
C
      RETURN
      END
C
C*MODULE VSCF    *DECK CONVRT
      SUBROUTINE CONVRT(ZMATN,BL,ALPHA,BETA,NAT1,NZVAR,IZT,BETAT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*10 AATOM
      CHARACTER*4  ATM
      DIMENSION BL(NAT1),ALPHA(NAT1),BETA(NAT1),
     *          V1(3),V2(3),VP(3),VJ(3),
     *          AL1(3),AL2(3),AL3(3),AL4(3),
     *          ZMATN(NZVAR),
     *          IZT(NAT1),BETAT(NAT1),
     *          A(MXATM),B(MXATM),D(MXATM),V3(3)
C
      COMMON /INFO  / C(MXATM,3),IZAN(MXATM),NATOMS,IUNTRD,ATM(MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),CD(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 /ZMINF / CORD(MXATM,3),AZNUC(MXATM),CORD2(MXATM,3),
     *                AATOM(MXATM)
      COMMON /CONNEC/ IZ(MXATM,4),IATMOR(MXATM),NATM,NRATM,NDATM
C
      DATA ANGS/0.52917724924D+00/
      DATA ZERO,ONE,TWO,TM5/0.0D+00,1.0D+00,2.0D+00,1.0D-05/
      DATA PI/3.14159265359D+00/
C, ONE80/180.0D+00/
C
C      RTOD = ONE80/ACOS(-ONE)
      NATOMS = NAT1
      DO I=1, NAT1
         IZT(I)=0
         BETAT(I)=ZERO
      END DO
C
      DO J=1, NZVAR
         L = 0
         DO K=2,NAT1
            IF (K.EQ.2) THEN
                L=L+1
                BL(2) = ZMATN(L)*ANGS
            ELSE IF (K.EQ.3) THEN
                L=L+1
                BL(3) = ZMATN(L)*ANGS
                L=L+1
                ALPHA(3) = ZMATN(L)
            ELSE IF (K.GT.3) THEN
                L=L+1
                BL(K) = ZMATN(L)*ANGS
                L=L+1
                ALPHA(K) = ZMATN(L)
                L=L+1
                BETA(K)  = ZMATN(L)
            END IF
         END DO
      END DO
C
      DO I=1,NAT1
       IF(IABS(IZ(I,4)).EQ.2 .AND. BETA(I).GT.ZERO) IZ(I,4)=2
       IF(IABS(IZ(I,4)).EQ.2 .AND. BETA(I).LT.ZERO) IZ(I,4)=-2
       IF(IABS(IZ(I,4)).EQ.4 .AND. BETA(I).GT.ZERO) IZ(I,4)=2
       IF(IABS(IZ(I,4)).EQ.4 .AND. BETA(I).LT.ZERO) IZ(I,4)=-2
       IF(IZ(I,4).EQ.3) IZ(I,4)=0
      END DO
C
C          * * * * MODEL BUILDER * * * *
C     ORIGINAL AUTHOR - MANY, MANY MOONS AGO:
C                 MARK S. GORDON
C             DEPARTMENT OF CHEMISTRY
C          NORTH DAKOTA STATE UNIVERSITY
C            FARGO, NORTH DAKOTA 58105
C
      DO 110 I=1,MXATM
         C(I,1)=ZERO
         C(I,2)=ZERO
         C(I,3)=ZERO
  110 CONTINUE
C
C        PRINT OUT NUMERIC Z MATRIX
C
      IF (MASWRK) THEN
      WRITE(IW,9000)
      WRITE(IW,9010)
      DO 137 I=1,NATOMS
         IF(I.EQ.1) WRITE(IW,9020) I
         IF(I.EQ.2) WRITE(IW,9020) I,IZ(I,1),BL(I)
         IF(I.EQ.3) WRITE(IW,9020) I,IZ(I,1),BL(I),
     *                               IZ(I,2),ALPHA(I)
         IF(I.GE.4) WRITE(IW,9020) I,IZ(I,1),BL(I),
     *                               IZ(I,2),ALPHA(I),
     *                               IZ(I,3),BETA(I),IZ(I,4)
  137 CONTINUE
      ENDIF
C
      M=NATOMS
C
C              HANDLE ATOMS 1, 2, 3 AS SPECIAL CASES
C
      C(1,1)=ZERO
      C(1,2)=ZERO
      C(1,3)=ZERO
C
      C(2,1)=ZERO
      C(2,2)=ZERO
      C(2,3)=BL(2)
      IF(M.LT.3) GO TO 700
C
      C(3,1)=BL(3)*SIN(ALPHA(3))
      C(3,2)=ZERO
      IF(IZ(3,1).EQ.1) C(3,3) = BL(3)*COS(ALPHA(3))
      IF(IZ(3,1).EQ.2) C(3,3) = C(2,3)-BL(3)*COS(ALPHA(3))
      I=3
      IF(ABS(C(3,1)).GE.TM5) GO TO 240
      DO 220 I = 4,MXATM
         IF(I.LE.M.AND.ABS(C(I-1,1)).LT.TM5) GO TO 210
            GO TO 240
  210    C(I,1) = BL(I)*SIN(ALPHA(I))
         C(I,2) = ZERO
         ITEMP = IZ(I,1)
         JTEMP = IZ(I,2)
         C(I,3)=C(ITEMP,3)-BL(I) * COS(ALPHA(I)) *
     *           SIGN(ONE,C(ITEMP,3)-C(JTEMP,3))
  220 CONTINUE
  240 CONTINUE
      K=I
      IF(I.EQ.3) K=4
C
C               LOOP OVER COORDINATES OF ATOMS 4 TO M
C
      IF(K.GT.M) GO TO 700
      DO 600 J = K,M
      IF(IZ(J,4).NE.0) THEN
        WRITE(IW,*) 'ERROR: ONLY IZ(I,4)=0 IS ACCEPTABLE INPUT'
        CALL ABRT
      END IF
C
C                  ****** USE DIHEDRAL ANGLE *****
C
      IF(IABS(IZ(J,4)).NE.0) GO TO 400
C
      CALL RELVEC(V1,IZ(J,2),IZ(J,3))
      CALL UNIVEC(AL1,V1)
C
C     V1 IS A VECTOR FROM ATOM IZ(J,3) TO ATOM IZ(J,2)
C     AL1 IS A UNIT VECTOR OF V1.
C     BL(IZ(J,2)) IS BONDLENGTH OF ATOM IZ(J,2)
C
      CALL RELVEC(V2,IZ(J,1),IZ(J,2))
      CALL UNIVEC(AL2,V2)
C
C     V2 IS THE VECTOR FROM ATOM IZ(J,2) TO ATOM IZ(J,1)
C     AL2 IS THE UNIT VECTOR OF V2.
C     BL(IZ(J,1)) IS BONDLENGTH DEFINING ATOM IZ(J,1)
C
      CALL VECPRD(VP,AL1,AL2)
      DO 300 I = 1,3
         AL3(I) = VP(I)/
     *        SQRT(ONE-(AL1(1)*AL2(1)+AL1(2)*AL2(2)+AL1(3)*AL2(3))**2)
  300 CONTINUE
C
C     AL3 IS THE UNIT VECTOR OF VP.ALPHA(IZ(J,1))IS THE ANGLE DEFINING
C     ATOM IZ(J,1)
C
      CALL VECPRD(AL4,AL3,AL2)
C
C     AL4,AL3,AL2 ARE A NEW SET OF MUTUALLY ORTHOGONAL AXES. WE WILL NOW
C     GET COORD OF ATOM J IN TERMS OF THESE AXES RELATIVE TO ATOM IZ(J)
C
      DO 320 I=1,3
         VJ(I) = BL(J)*(-AL2(I)*COS(ALPHA(J))+AL4(I)*SIN(ALPHA(J))*
     *           COS(BETA(J))+AL3(I)*SIN(ALPHA(J))*SIN(BETA(J)))
C
C     VJ IS THE VECTOR FROM ATOM IZ(J,1) TO ATOM J
C
         ITEMP = IZ(J,1)
         C(J,I) = VJ(I) + C(ITEMP,I)
         IF(ABS(C(J,I)).LT.TM5) C(J,I)=ZERO
  320 CONTINUE
      GO TO 600
C
C              ***** USE SECOND BOND ANGLE *****
C
  400 CONTINUE
      IF(IABS(IZ(J,4)).NE.1) GO TO 500
C
      CALL RELVEC(V1,IZ(J,1),IZ(J,3))
      CALL UNIVEC(AL1,V1)
      CALL RELVEC(V2,IZ(J,2),IZ(J,1))
      CALL UNIVEC(AL2,V2)
      ZETA = -(AL1(1)*AL2(1)+AL1(2)*AL2(2)+AL1(3)*AL2(3))
      OMZSQ = ONE - ZETA * ZETA
      A(J) = (-COS(BETA(J))+ZETA*COS(ALPHA(J)))/OMZSQ
      B(J) = (COS(ALPHA(J))-ZETA*COS(BETA(J)))/OMZSQ
      TEMP=ZERO
      IF(ZETA.LT.ZERO) TEMP=PI
      GAMMA = PI/TWO
      IF(ZETA.NE.ZERO) GAMMA = ATAN (SQRT(OMZSQ)/ZETA) +TEMP
      IF (ABS(GAMMA+ALPHA(J)+BETA(J)-TWO*PI).GT.TM5)
     *     D(J) = IZ(J,4)*(SQRT(ONE+A(J)*COS(BETA(J))-B(J)*
     *            COS(ALPHA(J))))/SQRT(OMZSQ)
      CALL VECPRD(V3,AL1,AL2)
      DO 420 I = 1,3
         AL3(I) = A(J)*AL1(I)+B(J)*AL2(I)+D(J)*V3(I)
         VJ(I) = BL(J)*AL3(I)
         ITEMP = IZ(J,1)
         C(J,I) = VJ(I)+C(ITEMP,I)
         IF(ABS(C(J,I)).LT.TM5) C(J,I)=ZERO
  420 CONTINUE
      GO TO 600
C
C            ***** USE BOND-PLANE ANGLE ******
C
C     THIS PART IS USED IF ATOM IS DEFINED BY ONE BONDANGLE AND BY THE
C     ANGLE WHICH BOND IZ(J,1)-J MAKES WITH THE PLANE OF IZ(J,1),IZ(J,2)
C     AND IZ(J,3)
C
  500 CONTINUE
C
      CALL RELVEC(V1,IZ(J,1),IZ(J,3))
      CALL UNIVEC(AL1,V1)
      CALL RELVEC(V2,IZ(J,2),IZ(J,1))
      CALL UNIVEC(AL2,V2)
      ZETA = -(AL1(1)*AL2(1)+AL1(2)*AL2(2)+AL1(3)*AL2(3))
      OMZSQ = ONE - ZETA * ZETA
      CALL VECPRD(V3,AL1,AL2)
C
C     BETA(J) HERE REFERS TO 90-ANGLE WHICH BOND IZ(J,1)-J MAKES
C     WITH THE AFOREMENTIONED PLANE
C
      V3MAG = SQRT(V3(1)*V3(1) + V3(2)*V3(2) + V3(3)*V3(3))
      A(J)=(COS(BETA(J))/OMZSQ)*V3MAG
      B(J)=SQRT((ONE-COS(ALPHA(J))**2
     *              - A(J)*COS(BETA(J))*V3MAG)/OMZSQ)
      IF(IZ(J,4).EQ.-2) B(J) = -B(J)
      D(J) = B(J)*ZETA+COS(ALPHA(J))
      DO 520 I=1,3
         AL3(I) = B(J)*AL1(I)+D(J)*AL2(I)+A(J)*V3(I)
         VJ(I) = BL(J)*AL3(I)
         ITEMP = IZ(J,1)
         C(J,I) = VJ(I) + C(ITEMP,I)
         IF(ABS(C(J,I)).LT.TM5) C(J,I)=ZERO
  520 CONTINUE
C
  600 CONTINUE
  700 CONTINUE
C
      IQ = 0
      DO 720 J=1,M
         IQ = IQ + 1
         AZNUC(IQ) = IZAN(IQ)
         AATOM(IQ) = ATM(IQ)
         CORD(IQ,1) = C(IQ,1)
         CORD(IQ,2) = C(IQ,2)
         CORD(IQ,3) = C(IQ,3)
C
         CD(1,IQ) = C(IQ,1)/ANGS
         CD(2,IQ) = C(IQ,2)/ANGS
         CD(3,IQ) = C(IQ,3)/ANGS
  720 CONTINUE
       NAT = M
C
       DO I=1, NAT1
          IF(IABS(IZT(I)).EQ.2) THEN
             IZ(I,4)=IZT(I)
             BETA(J)=BETAT(J)
          END IF
       END DO
C
      RETURN
C
 9000 FORMAT(/1X,'YOUR FULLY SUBSTITUTED Z-MATRIX IS')
 9010 FORMAT(1X,'ATOM',4X,'I',3X,'BL',9X,'J',3X,'ANGLE',
     *       6X,'K',3X,'TORS')
 9020 FORMAT(1X,I4,1X,I4,3X,F7.4,2X,I3,3X,F7.3,1X,I3,3X,F7.3,2X,I3)
C
      END
C
C*MODULE VSCF    *DECK CONVRT2
      SUBROUTINE CONVRT2(PETYP,NCOUP,NGRID,ISVIB,NM,NAT1,NC1,NZVAR,
     *                   NPOINT,IMODE,COORD_ALL,C0,DX,FACT,DVEC,RQ,
     *                   DELCOR,VEC,NCOUNT1,NCOUNT2,PESALL,CHOOSEN,
     *                   STP1,ZMAT_CUR,ZMAT_OLD,INTTYP,NZMAT,IZMAT,
     *                   ITYP,ICONNCT,INPUT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000, DXMAXT=0.3D+00,
     *           ONE=1.0D+00, TWO=2.0D+00)
C
      LOGICAL OUT,GOPARR,MASWRK,DSKWRK,PESALL,CHOOSEN
C
      CHARACTER*6 PETYP
C
      DIMENSION IMODE(NC1),COORD_ALL(NPOINT,3*NAT1),
     *          C0(3,NAT1),DX(NC1),DVEC(NZVAR,NC1),
     *          RQ(NM,NGRID),DELCOR(NC1),VEC(NC1,NC1),
     *          NCOUNT1(ISVIB),NCOUNT2(ISVIB,ISVIB),
     *          CHOOSEN(ISVIB,ISVIB),STP1(NC1),DQI(12),DQJ(12),
     *          ZMAT_CUR(NZVAR),ZMAT_OLD(NZVAR),IZMAT(NZMAT),
     *          ITYP(NZVAR),ICONNCT(NZVAR,4)
C
      COMMON /FMCOM / X(1)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /CONNEC/ IZ(MXATM,4),IATMOR(MXATM),NATM,NRATM,NDATM
C
      DATA VSCF  /8HVSCF    /
      DATA DQI / 3.0D+00, 1.0D+00, 1.0D+00, 3.0D+00, 1.0D+00, 1.0D+00,
     *          -1.0D+00,-1.0D+00,-3.0D+00,-1.0D+00,-1.0D+00,-3.0D+00/
      DATA DQJ / 1.0D+00, 1.0D+00, 3.0D+00,-1.0D+00,-1.0D+00,-3.0D+00,
     *           3.0D+00, 1.0D+00, 1.0D+00,-3.0D+00,-1.0D+00,-1.0D+00/
C
C     CALCULATE COORDINATES FOR ALL THE POINTS ON DIRECT PES
C
      RUNTYP  = VSCF
      NCOORD  = 3*NAT1
      IHALF   = NGRID/2
      OUT     = .FALSE.
      ITBMAT  = 10
      NPOINT1 = ISVIB*NGRID
      NPOINT2 = NGRID*NGRID*ISVIB*(ISVIB-1)/2
      IF(PETYP.EQ.'QFF   ') THEN
         NPOINT1 = ISVIB*6
         NPOINT2 = 12*ISVIB*(ISVIB-1)
      END IF
      ICOUNT1A = 0
      ICOUNT2A = 0
      CALL VALFM(LOADFM)
      LDEL =  1    + LOADFM
      LAST  = LDEL + NZVAR
      NEED9 = LAST  - LOADFM - 1
      CALL GETFM(NEED9)
      CALL VCLR(X(LDEL),1,NZVAR)
      CALL DAREAD(IDAF,IODA,IZMAT,NZMAT,40,0)
      IF(INTTYP.EQ.1) THEN
         CALL VALFM(LOADFM)
         LBL     = 1      + LOADFM
         LALPHA  = LBL    + NAT1
         LBETA   = LALPHA + NAT1
         LIZT    = LBETA  + NAT1
         LBETAT  = LIZT   + NAT1
         LAST    = LBETAT + NAT1
         NEED10  = LAST - LOADFM - 1
         CALL GETFM(NEED10)
         CALL SYMOFF
         ID=0
         JD=0
         IZ(2,1)=IZMAT(3)
         IF(NZMAT.GT.4) THEN
            IZ(3,1)=IZMAT(6)
            IZ(3,2)=IZMAT(10)
         END IF
         IF(NZMAT.GT.10) THEN
            J=3
            DO I=13,NZMAT,12
               J=J+1
               IZ(J,1)=IZMAT(I)
               IZ(J,2)=IZMAT(I+4)
               IZ(J,3)=IZMAT(I+9)
               IZ(J,4)=IZMAT(I+5)
            END DO
         END IF
         IF(INPUT.EQ.0)THEN
            CALL BANDBI
            CALL DAREAD(IDAF,IODA,ZMAT_CUR,NZVAR,39,0)
            CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),X(LBETA),NAT1,
     *                  NZVAR,X(LIZT),X(LBETAT))
            GOTO 1000
         END IF
      END IF
      IADD = 1
      DO N = 1, NZVAR
         ITYP(N)=IZMAT(IADD)
         IF(ITYP(N).EQ.1) THEN
            ICONNCT(N,1) = IZMAT(IADD+1)
            ICONNCT(N,2) = IZMAT(IADD+2)
            IADD=IADD+3
         ELSE IF(ITYP(N).EQ.2) THEN
            ICONNCT(N,1) = IZMAT(IADD+1)
            ICONNCT(N,2) = IZMAT(IADD+2)
            ICONNCT(N,3) = IZMAT(IADD+3)
            IADD=IADD+4
         ELSE IF(ITYP(N).EQ.3 .OR. ITYP(N).EQ.4) THEN
            ICONNCT(N,1) = IZMAT(IADD+1)
            ICONNCT(N,2) = IZMAT(IADD+2)
            ICONNCT(N,3) = IZMAT(IADD+3)
            ICONNCT(N,4) = IZMAT(IADD+4)
            IADD=IADD+5
         END IF
      END DO
      IF(PETYP.EQ.'DIRECT') THEN
C
C        --- DIAGONAL TERMS ---
C
         DO IM=1,ISVIB
            ID=NC1-IMODE(IM)+1
            ICOUNT1 = 0
            CALL VCLR(DX,1,NZVAR)
            CALL DCOPY(NCOORD,C0,1,C,1)
            CALL BANDBI
            CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
            CALL VCLR(X(LDEL),1,NZVAR)
            DO IL=IHALF,1,-1
               ICONV = 0
               IF(MASWRK) WRITE(IW,9020) ID,IL
               ID_NEW = (IM-1)*NGRID + IL
               DO N=1, NZVAR
                  IF(IL.EQ.IHALF) THEN
                     DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
                  ELSE
                     DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                         - DVEC(N,ID)*FACT*RQ(IM,IL+1)
                  END IF
               END DO
               CALL DCOPY(NZVAR,DELCOR,1,DX,1)
               IF(INTTYP.EQ.1) THEN
                  DO N=1,NZVAR
                     IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                     ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                  END DO
                  CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                             X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                  CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                      X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                  CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
               END IF
               IF(INTTYP.EQ.2) THEN
                  DO N=1,NZVAR
                     IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                     ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                  END DO
                  CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                             X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                  CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                        ICONV,RUNTYP)
                  IF(ICONV.EQ.0) THEN
                     JQ = 1
                     DO J=1,NAT1
                        C(1,J) = C(1,J) + DELCOR(JQ)
                        C(2,J) = C(2,J) + DELCOR(JQ+1)
                        C(3,J) = C(3,J) + DELCOR(JQ+2)
                        JQ = JQ + 3
                     END DO
                     CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                  END IF
               END IF
               IF(ICONV.EQ.1) THEN
                  IF(IL.EQ.IHALF) THEN
                     WRITE(IW,*) 'ERROR ON THE VERY FIRST DISPLACEMENT'
                     CALL ABRT
                  END IF
                  JQ = 0
                  DO J=1,NAT1
                     IF(IL.EQ.IHALF-1) THEN
                        DELCOR(JQ+1) = (COORD_ALL(ID_NEW+1,JQ+1)
     *                               -  C0(1,J))*TWO
                        DELCOR(JQ+2) = (COORD_ALL(ID_NEW+1,JQ+2)
     *                               -  C0(2,J))*TWO
                        DELCOR(JQ+3) = (COORD_ALL(ID_NEW+1,JQ+3)
     *                               -  C0(3,J))*TWO
                     ELSE IF(IL.LT.IHALF-1) THEN
                        DELCOR(JQ+1) = COORD_ALL(ID_NEW+1,JQ+1)
     *                               - COORD_ALL(ID_NEW+2,JQ+1)
                        DELCOR(JQ+2) = COORD_ALL(ID_NEW+1,JQ+2)
     *                               - COORD_ALL(ID_NEW+2,JQ+2)
                        DELCOR(JQ+3) = COORD_ALL(ID_NEW+1,JQ+3)
     *                               - COORD_ALL(ID_NEW+2,JQ+3)
                     END IF
                     C(1,J) = COORD_ALL(ID_NEW+1,JQ+1) + DELCOR(JQ+1)
                     C(2,J) = COORD_ALL(ID_NEW+1,JQ+2) + DELCOR(JQ+2)
                     C(3,J) = COORD_ALL(ID_NEW+1,JQ+3) + DELCOR(JQ+3)
                     JQ = JQ + 3
                  END DO
C                  CALL BANDBI
C                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  DO N=1,NZVAR
                     ZMAT_OLD(N) = ZMAT_OLD(N) + DX(N)
                  END DO
                  ICOUNT1  = ICOUNT1  + 1
                  ICOUNT1A = ICOUNT1A + 1
                  IF(MASWRK) WRITE(IW,9035)
               END IF
               JQ = 1
               DO J=1,NAT1
                  COORD_ALL(ID_NEW,JQ)   = C(1,J)
                  COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                  COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                  JQ = JQ + 3
               END DO
               IF(MASWRK) WRITE(IW,9050)
               DO IAT = 1,NAT1
                  IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                           C(1,IAT),C(2,IAT),C(3,IAT)
               ENDDO
            END DO
C
            CALL VCLR(DX,1,NZVAR)
            CALL DCOPY(NCOORD,C0,1,C,1)
            CALL BANDBI
            CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
            CALL VCLR(X(LDEL),1,NZVAR)
            DO IL=IHALF+1, NGRID
               ICONV=0
               IF(MASWRK) WRITE(IW,9020) ID,IL
               ID_NEW = (IM-1)*NGRID + IL
               DO N=1, NZVAR
                  IF(IL.EQ.IHALF+1) THEN
                     DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
                  ELSE
                     DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                         - DVEC(N,ID)*FACT*RQ(IM,IL-1)
                  END IF
               END DO
               IF(INTTYP.EQ.1) THEN
                  DO N=1,NZVAR
                     IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                     ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                  END DO
                  CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                             X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                  CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                  CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
               END IF
               IF(INTTYP.EQ.2) THEN
                  DO N=1,NZVAR
                     IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                     ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                  END DO
                  CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                             X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                  CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                        ICONV,RUNTYP)
                  IF(ICONV.EQ.0) THEN
                     JQ = 1
                     DO J=1,NAT1
                        C(1,J) = C(1,J) + DELCOR(JQ)
                        C(2,J) = C(2,J) + DELCOR(JQ+1)
                        C(3,J) = C(3,J) + DELCOR(JQ+2)
                        JQ = JQ + 3
                     END DO
                     CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                  END IF
               END IF
               IF(ICONV.EQ.1) THEN
                  IF(IL.EQ.IHALF+1) THEN
                     WRITE(IW,*) 'ERROR ON THE VERY FIRST DISPLACEMENT'
                     CALL ABRT
                  END IF
                  JQ = 0
                  DO J=1,NAT1
                     IF(IL.EQ.IHALF-1) THEN
                        DELCOR(JQ+1) = (COORD_ALL(ID_NEW-1,JQ+1)
     *                               -  C0(1,J))*TWO
                        DELCOR(JQ+2) = (COORD_ALL(ID_NEW-1,JQ+2)
     *                               -  C0(2,J))*TWO
                        DELCOR(JQ+3) = (COORD_ALL(ID_NEW-1,JQ+3)
     *                               -  C0(3,J))*TWO
                     ELSE
                        DELCOR(JQ+1) = COORD_ALL(ID_NEW-1,JQ+1)
     *                               - COORD_ALL(ID_NEW-2,JQ+1)
                        DELCOR(JQ+2) = COORD_ALL(ID_NEW-1,JQ+2)
     *                               - COORD_ALL(ID_NEW-2,JQ+2)
                        DELCOR(JQ+3) = COORD_ALL(ID_NEW-1,JQ+3)
     *                               - COORD_ALL(ID_NEW-2,JQ+3)
                     END IF
                     C(1,J) = COORD_ALL(ID_NEW-1,JQ+1) + DELCOR(JQ+1)
                     C(2,J) = COORD_ALL(ID_NEW-1,JQ+2) + DELCOR(JQ+2)
                     C(3,J) = COORD_ALL(ID_NEW-1,JQ+3) + DELCOR(JQ+3)
                     JQ = JQ + 3
                  END DO
C                  CALL BANDBI
C                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  DO N=1,NZVAR
                     ZMAT_OLD(N) = ZMAT_OLD(N) + DX(N)
                  END DO
                  ICOUNT1  = ICOUNT1  + 1
                  ICOUNT1A = ICOUNT1A + 1
                  IF(MASWRK) WRITE(IW,9035)
               END IF
               JQ = 1
               DO J=1,NAT1
                  COORD_ALL(ID_NEW,JQ)   = C(1,J)
                  COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                  COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                  JQ = JQ + 3
               END DO
               IF(MASWRK) WRITE(IW,9050)
               DO IAT = 1,NAT1
                  IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                           C(1,IAT),C(2,IAT),C(3,IAT)
               ENDDO
            END DO
            NCOUNT1(IM) = ICOUNT1
         END DO
      IF (NCOUP.LE.1) GO TO 1000
C
C        --- 2-MODE COUPLING TERMS ---
C
         DO IM=1,ISVIB-1
            ID=NC1-IMODE(IM)+1
            DO JM=IM+1,ISVIB
               JD=NC1-IMODE(JM)+1
               ICOUNT2 = 0
               IF(.NOT.PESALL .AND. .NOT.CHOOSEN(IM,JM)) GO TO 300
               DO IL=IHALF, 1, -1
                  IF(IL.EQ.IHALF) THEN
                     CALL DCOPY(NCOORD,C0,1,C,1)
                  ELSE
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_OLD = ISVIB*NGRID + NPAIR*NGRID*NGRID
     *                      + IL*NGRID + IHALF
                     JQ = 0
                     DO IATM = 1, NAT1
                        C(1,IATM) = COORD_ALL(ID_OLD,JQ+1)
                        C(2,IATM) = COORD_ALL(ID_OLD,JQ+2)
                        C(3,IATM) = COORD_ALL(ID_OLD,JQ+3)
                        JQ = JQ + 3
                     END DO
                  END IF
                  CALL VCLR(DX,1,NZVAR)
                  CALL BANDBI
                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  CALL VCLR(X(LDEL),1,NZVAR)
                  DO JL=IHALF, 1, -1
                     IF(MASWRK) WRITE(IW,9030) ID,IL,JD,JL
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_NEW = ISVIB*NGRID +
     *                        NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                     DO N=1, NZVAR
                        IF(IL.EQ.IHALF) THEN
                           IF(JL.EQ.IHALF) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  + DVEC(N,JD)*FACT*RQ(JM,JL)
                           ELSE IF(JL.NE.IHALF) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL+1)
                           END IF
                        ELSE IF(IL.NE.IHALF) THEN
                           IF(JL.EQ.IHALF) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  - DVEC(N,ID)*FACT*RQ(IM,IL+1)
                           ELSE IF(JL.NE.IHALF) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL+1)
                           END IF
                        END IF
                     END DO
                     CALL DCOPY(NZVAR,DELCOR,1,DX,1)
                     IF(INTTYP.EQ.1) THEN
                        DO N=1,NZVAR
                           IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                           ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                        END DO
                        CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,
     *                       DELCOR,X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                        CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                     END IF
                     IF(INTTYP.EQ.2) THEN
                      DO N=1,NZVAR
                         IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                         ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                      END DO
                      CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                              X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                      CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,
     *                            ITBMAT,ICONV,RUNTYP)
                      IF(ICONV.EQ.0) THEN
                         JQ = 1
                         DO J=1,NAT1
                            C(1,J) = C(1,J) + DELCOR(JQ)
                            C(2,J) = C(2,J) + DELCOR(JQ+1)
                            C(3,J) = C(3,J) + DELCOR(JQ+2)
                            JQ = JQ + 3
                         END DO
                         CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                        END IF
                     END IF
                     IF(ICONV.EQ.1) THEN
                        IF(IL.EQ.IHALF .AND. JL.EQ.IHALF) THEN
                           WRITE(IW,*)
     *                       'ERROR ON THE VERY FIRST DISPLACEMENT'
                           CALL ABRT
                        END IF
                        JQ = 0
                        DO J=1,NAT1
                           IF(JL.EQ.IHALF-1) THEN
                              DELCOR(JQ+1) = (COORD_ALL(ID_NEW+1,JQ+1)
     *                                     -  C0(1,J))*TWO
                              DELCOR(JQ+2) = (COORD_ALL(ID_NEW+1,JQ+2)
     *                                     -  C0(2,J))*TWO
                              DELCOR(JQ+3) = (COORD_ALL(ID_NEW+1,JQ+3)
     *                                     -  C0(3,J))*TWO
                           ELSE IF(JL.LT.IHALF-1) THEN
                              DELCOR(JQ+1) = COORD_ALL(ID_NEW+1,JQ+1)
     *                                     - COORD_ALL(ID_NEW+2,JQ+1)
                              DELCOR(JQ+2) = COORD_ALL(ID_NEW+1,JQ+2)
     *                                     - COORD_ALL(ID_NEW+2,JQ+2)
                              DELCOR(JQ+3) = COORD_ALL(ID_NEW+1,JQ+3)
     *                                     - COORD_ALL(ID_NEW+2,JQ+3)
                           END IF
                           C(1,J) = COORD_ALL(ID_NEW+1,JQ+1)
     *                            + DELCOR(JQ+1)
                           C(2,J) = COORD_ALL(ID_NEW+1,JQ+2)
     *                            + DELCOR(JQ+2)
                           C(3,J) = COORD_ALL(ID_NEW+1,JQ+3)
     *                            + DELCOR(JQ+3)
                           JQ = JQ + 3
                        END DO
                        CALL BANDBI
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                        ICOUNT2  = ICOUNT2  + 1
                        ICOUNT2A = ICOUNT2A + 1
                        IF(MASWRK) WRITE(IW,9035)
                     END  IF
                     JQ = 1
                     DO J=1,NAT1
                        COORD_ALL(ID_NEW,JQ)   = C(1,J)
                        COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                        COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                        JQ = JQ + 3
                     END DO
                     IF(MASWRK) WRITE(IW,9050)
                     DO IAT = 1,NAT1
                        IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                                 C(1,IAT),C(2,IAT),C(3,IAT)
                     ENDDO
                  END DO
C
                  IF(IL.EQ.IHALF) THEN
                     CALL DCOPY(NCOORD,C0,1,C,1)
                  ELSE
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_OLD = ISVIB*NGRID + NPAIR*NGRID*NGRID
     *                      + IL*NGRID + IHALF + 1
                     JQ = 0
                     DO IATM = 1, NAT1
                        C(1,IATM) = COORD_ALL(ID_OLD,JQ+1)
                        C(2,IATM) = COORD_ALL(ID_OLD,JQ+2)
                        C(3,IATM) = COORD_ALL(ID_OLD,JQ+3)
                        JQ = JQ + 3
                     END DO
                  END IF
                  CALL VCLR(DX,1,NZVAR)
                  CALL BANDBI
                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  CALL VCLR(X(LDEL),1,NZVAR)
                  DO JL=IHALF+1, NGRID
                     IF(MASWRK) WRITE(IW,9030) ID,IL,JD,JL
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_NEW = ISVIB*NGRID +
     *                        NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                     DO N=1, NZVAR
                        IF(IL.EQ.IHALF) THEN
                           IF(JL.EQ.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  + DVEC(N,JD)*FACT*RQ(JM,JL)
                           ELSE IF(JL.NE.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL-1)
                           END IF
                        ELSE IF(IL.NE.IHALF) THEN
                           IF(JL.EQ.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  - DVEC(N,ID)*FACT*RQ(IM,IL+1)
                           ELSE IF(JL.NE.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL-1)
                           END IF
                        END IF
                     END DO
                     CALL DCOPY(NZVAR,DELCOR,1,DX,1)
                     IF(INTTYP.EQ.1) THEN
                        DO N=1,NZVAR
                           IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                           ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                        END DO
                        CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,
     *                       DELCOR,X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                        CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                     END IF
                     IF(INTTYP.EQ.2) THEN
                      DO N=1,NZVAR
                         IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                         ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                      END DO
                      CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                                 X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                      CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                            ICONV,RUNTYP)
                      IF(ICONV.EQ.0) THEN
                         JQ = 1
                         DO J=1,NAT1
                            C(1,J) = C(1,J) + DELCOR(JQ)
                            C(2,J) = C(2,J) + DELCOR(JQ+1)
                            C(3,J) = C(3,J) + DELCOR(JQ+2)
                            JQ = JQ + 3
                         END DO
                         CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                      END IF
                     END IF
                     IF(ICONV.EQ.1) THEN
                        IF(IL.EQ.IHALF .AND. JL.EQ.IHALF+1) THEN
                           WRITE(IW,*)
     *                       'ERROR ON THE VERY FIRST DISPLACEMENT'
                           CALL ABRT
                        END IF
                        JQ = 0
                        DO J=1,NAT1
                           IF(JL.EQ.IHALF+2) THEN
                              DELCOR(JQ+1) = (COORD_ALL(ID_NEW-1,JQ+1)
     *                                     -  C0(1,J))*TWO
                              DELCOR(JQ+2) = (COORD_ALL(ID_NEW-1,JQ+2)
     *                                     -  C0(2,J))*TWO
                              DELCOR(JQ+3) = (COORD_ALL(ID_NEW-1,JQ+3)
     *                                     -  C0(3,J))*TWO
                           ELSE IF(JL.GT.IHALF+2) THEN
                              DELCOR(JQ+1) = COORD_ALL(ID_NEW-1,JQ+1)
     *                                     - COORD_ALL(ID_NEW-2,JQ+1)
                              DELCOR(JQ+2) = COORD_ALL(ID_NEW-1,JQ+2)
     *                                     - COORD_ALL(ID_NEW-2,JQ+2)
                              DELCOR(JQ+3) = COORD_ALL(ID_NEW-1,JQ+3)
     *                                     - COORD_ALL(ID_NEW-2,JQ+3)
                           END IF
                           C(1,J) = COORD_ALL(ID_NEW-1,JQ+1)
     *                            + DELCOR(JQ+1)
                           C(2,J) = COORD_ALL(ID_NEW-1,JQ+2)
     *                            + DELCOR(JQ+2)
                           C(3,J) = COORD_ALL(ID_NEW-1,JQ+3)
     *                            + DELCOR(JQ+3)
                           JQ = JQ + 3
                        END DO
                        CALL BANDBI
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                        ICOUNT2  = ICOUNT2  + 1
                        ICOUNT2A = ICOUNT2A + 1
                        IF(MASWRK) WRITE(IW,9035)
                     END  IF
                     JQ = 1
                     DO J=1,NAT1
                        COORD_ALL(ID_NEW,JQ)   = C(1,J)
                        COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                        COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                        JQ = JQ + 3
                     END DO
                     IF(MASWRK) WRITE(IW,9050)
                     DO IAT = 1,NAT1
                        IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                                 C(1,IAT),C(2,IAT),C(3,IAT)
                     END DO
                  END DO
               END DO
C
               DO IL = IHALF+1, NGRID
                  IF(IL.EQ.IHALF+1) THEN
                     CALL DCOPY(NCOORD,C0,1,C,1)
                  ELSE
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_OLD = ISVIB*NGRID + NPAIR*NGRID*NGRID
     *                      + (IL-2)*NGRID + IHALF
                     JQ = 0
                     DO IATM = 1, NAT1
                        C(1,IATM) = COORD_ALL(ID_OLD,JQ+1)
                        C(2,IATM) = COORD_ALL(ID_OLD,JQ+2)
                        C(3,IATM) = COORD_ALL(ID_OLD,JQ+3)
                        JQ = JQ + 3
                     END DO
                  END IF
                  CALL VCLR(DX,1,NZVAR)
                  CALL BANDBI
                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  CALL VCLR(X(LDEL),1,NZVAR)
                  DO JL=IHALF, 1, -1
                     IF(MASWRK) WRITE(IW,9030) ID,IL,JD,JL
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_NEW = ISVIB*NGRID +
     *                        NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                     DO N=1, NZVAR
                        IF(IL.EQ.IHALF+1) THEN
                           IF(JL.EQ.IHALF) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  + DVEC(N,JD)*FACT*RQ(JM,JL)
                           ELSE IF(JL.NE.IHALF) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL+1)
                           END IF
                        ELSE IF(IL.NE.IHALF+1) THEN
                           IF(JL.EQ.IHALF) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  - DVEC(N,ID)*FACT*RQ(IM,IL-1)
                           ELSE IF(JL.NE.IHALF) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL+1)
                           END IF
                        END IF
                     END DO
                     CALL DCOPY(NZVAR,DELCOR,1,DX,1)
                     IF(INTTYP.EQ.1) THEN
                        DO N=1,NZVAR
                           IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                           ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                        END DO
                        CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,
     *                       DELCOR,X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                        CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                     END IF
                     IF(INTTYP.EQ.2) THEN
                      DO N=1,NZVAR
                         IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                         ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                      END DO
                      CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                                 X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                      CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                            ICONV,RUNTYP)
                      IF(ICONV.EQ.0) THEN
                         JQ = 1
                         DO J=1,NAT1
                            C(1,J) = C(1,J) + DELCOR(JQ)
                            C(2,J) = C(2,J) + DELCOR(JQ+1)
                            C(3,J) = C(3,J) + DELCOR(JQ+2)
                            JQ = JQ + 3
                         END DO
                         CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                      END IF
                     END IF
                     IF(ICONV.EQ.1) THEN
                        IF(IL.EQ.IHALF+1 .AND. JL.EQ.IHALF) THEN
                           WRITE(IW,*)
     *                       'ERROR ON THE VERY FIRST DISPLACEMENT'
                           CALL ABRT
                        END IF
                        JQ = 0
                        DO J=1,NAT1
                           IF(JL.EQ.IHALF-1) THEN
                              DELCOR(JQ+1) = (COORD_ALL(ID_NEW+1,JQ+1)
     *                                     -  C0(1,J))*TWO
                              DELCOR(JQ+2) = (COORD_ALL(ID_NEW+1,JQ+2)
     *                                     -  C0(2,J))*TWO
                              DELCOR(JQ+3) = (COORD_ALL(ID_NEW+1,JQ+3)
     *                                     -  C0(3,J))*TWO
                           ELSE IF(JL.LT.IHALF-1) THEN
                              DELCOR(JQ+1) = COORD_ALL(ID_NEW+1,JQ+1)
     *                                     - COORD_ALL(ID_NEW+2,JQ+1)
                              DELCOR(JQ+2) = COORD_ALL(ID_NEW+1,JQ+2)
     *                                     - COORD_ALL(ID_NEW+2,JQ+2)
                              DELCOR(JQ+3) = COORD_ALL(ID_NEW+1,JQ+3)
     *                                     - COORD_ALL(ID_NEW+2,JQ+3)
                           END IF
                           C(1,J) = COORD_ALL(ID_NEW+1,JQ+1)
     *                            + DELCOR(JQ+1)
                           C(2,J) = COORD_ALL(ID_NEW+1,JQ+2)
     *                            + DELCOR(JQ+2)
                           C(3,J) = COORD_ALL(ID_NEW+1,JQ+3)
     *                            + DELCOR(JQ+3)
                           JQ = JQ + 3
                        END DO
                        CALL BANDBI
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                        ICOUNT2  = ICOUNT2  + 1
                        ICOUNT2A = ICOUNT2A + 1
                        IF(MASWRK) WRITE(IW,9035)
                     END  IF
                     JQ = 1
                     DO J=1,NAT1
                        COORD_ALL(ID_NEW,JQ)   = C(1,J)
                        COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                        COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                        JQ = JQ + 3
                     END DO
                     IF(MASWRK) WRITE(IW,9050)
                     DO IAT = 1,NAT1
                        IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                                 C(1,IAT),C(2,IAT),C(3,IAT)
                     ENDDO
                  END DO
C
                  IF(IL.EQ.IHALF+1) THEN
                     CALL DCOPY(NCOORD,C0,1,C,1)
                  ELSE
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_OLD = ISVIB*NGRID + NPAIR*NGRID*NGRID
     *                      + (IL-2)*NGRID + IHALF + 1
                     JQ = 0
                     DO IATM = 1, NAT1
                        C(1,IATM) = COORD_ALL(ID_OLD,JQ+1)
                        C(2,IATM) = COORD_ALL(ID_OLD,JQ+2)
                        C(3,IATM) = COORD_ALL(ID_OLD,JQ+3)
                        JQ = JQ + 3
                     END DO
                  END IF
                  CALL VCLR(DX,1,NZVAR)
                  CALL BANDBI
                  CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
                  CALL VCLR(X(LDEL),1,NZVAR)
                  DO JL=IHALF+1, NGRID
                     IF(MASWRK) WRITE(IW,9030) ID,IL,JD,JL
                     NPAIR = 0
                     DO IC = 1, IM-1
                        NPAIR = NPAIR + (ISVIB - IC)
                     END DO
                     NPAIR = NPAIR + (JM-IM-1)
                     ID_NEW = ISVIB*NGRID +
     *                        NPAIR*NGRID*NGRID + (IL-1)*NGRID + JL
                     DO N=1, NZVAR
                        IF(IL.EQ.IHALF+1) THEN
                           IF(JL.EQ.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  + DVEC(N,JD)*FACT*RQ(JM,JL)
                           ELSE IF(JL.NE.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL-1)
                           END IF
                        ELSE IF(IL.NE.IHALF+1) THEN
                           IF(JL.EQ.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,ID)*FACT*RQ(IM,IL)
     *                                  - DVEC(N,ID)*FACT*RQ(IM,IL-1)
                           ELSE IF(JL.NE.IHALF+1) THEN
                              DELCOR(N) = DVEC(N,JD)*FACT*RQ(JM,JL)
     *                                  - DVEC(N,JD)*FACT*RQ(JM,JL-1)
                           END IF
                        END IF
                     END DO
                     CALL DCOPY(NZVAR,DELCOR,1,DX,1)
                     IF(INTTYP.EQ.1) THEN
                        DO N=1,NZVAR
                           IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                           ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                        END DO
                        CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,
     *                       DELCOR,X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                        CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                     END IF
                     IF(INTTYP.EQ.2) THEN
                      DO N=1,NZVAR
                         IF(X(LDEL-1+N).EQ.ONE) DELCOR(N)=-DELCOR(N)
                         ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                      END DO
                      CALL CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,
     *                                 X(LDEL),NZVAR,NC1,ITYP,ICONNCT)
                      CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                            ICONV,RUNTYP)
                      IF(ICONV.EQ.0) THEN
                         JQ = 1
                         DO J=1,NAT1
                            C(1,J) = C(1,J) + DELCOR(JQ)
                            C(2,J) = C(2,J) + DELCOR(JQ+1)
                            C(3,J) = C(3,J) + DELCOR(JQ+2)
                            JQ = JQ + 3
                         END DO
                         CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                      END IF
                     END IF
                     IF(ICONV.EQ.1) THEN
                        IF(IL.EQ.IHALF+1 .AND. JL.EQ.IHALF+1) THEN
                           WRITE(IW,*)
     *                       'ERROR ON THE VERY FIRST DISPLACEMENT'
                           CALL ABRT
                        END IF
                        JQ = 0
                        DO J=1,NAT1
                           IF(JL.EQ.IHALF+2) THEN
                              DELCOR(JQ+1) = (COORD_ALL(ID_NEW-1,JQ+1)
     *                                     -  C0(1,J))*TWO
                              DELCOR(JQ+2) = (COORD_ALL(ID_NEW-1,JQ+2)
     *                                     -  C0(2,J))*TWO
                              DELCOR(JQ+3) = (COORD_ALL(ID_NEW-1,JQ+3)
     *                                     -  C0(3,J))*TWO
                           ELSE IF(JL.GT.IHALF+2) THEN
                              DELCOR(JQ+1) = COORD_ALL(ID_NEW-1,JQ+1)
     *                                     - COORD_ALL(ID_NEW-2,JQ+1)
                              DELCOR(JQ+2) = COORD_ALL(ID_NEW-1,JQ+2)
     *                                     - COORD_ALL(ID_NEW-2,JQ+2)
                              DELCOR(JQ+3) = COORD_ALL(ID_NEW-1,JQ+3)
     *                                     - COORD_ALL(ID_NEW-2,JQ+3)
                           END IF
                           C(1,J) = COORD_ALL(ID_NEW-1,JQ+1)
     *                            + DELCOR(JQ+1)
                           C(2,J) = COORD_ALL(ID_NEW-1,JQ+2)
     *                            + DELCOR(JQ+2)
                           C(3,J) = COORD_ALL(ID_NEW-1,JQ+3)
     *                            + DELCOR(JQ+3)
                           JQ = JQ + 3
                        END DO
                        CALL BANDBI
                        CALL DCOPY(NZVAR,ZMAT_CUR,1,ZMAT_OLD,1)
                        ICOUNT2  = ICOUNT2  + 1
                        ICOUNT2A = ICOUNT2A + 1
                        IF(MASWRK) WRITE(IW,9035)
                     END  IF
                     JQ = 1
                     DO J=1,NAT1
                        COORD_ALL(ID_NEW,JQ)   = C(1,J)
                        COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                        COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                        JQ = JQ + 3
                     END DO
                     IF(MASWRK) WRITE(IW,9050)
                     DO IAT = 1,NAT1
                        IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                                 C(1,IAT),C(2,IAT),C(3,IAT)
                     END DO
                  END DO
               END DO
C
               NCOUNT2(IM,JM) = ICOUNT2
  300          CONTINUE
            END DO
         END DO
C
      ELSE IF(PETYP.EQ.'QFF   ') THEN
         CALL DCOPY(NCOORD,C0,1,C,1)
         CALL BANDBI
         CALL DAREAD(IDAF,IODA,ZMAT_OLD,NZVAR,39,0)
C
C        DIAGONAL
C
         DO IM=1,ISVIB
            ID=NC1-IMODE(IM)+1
            ICOUNT1 = 0
            DO IL=1,6
               IF(IL.LT.4) THEN
                  DQ=4.0D+00 - IL
               ELSE
                  DQ=3.0D+00 - IL
               ENDIF
               IF(MASWRK) WRITE(IW,9020) ID,IL
               ID_NEW = (IM-1)*6 + IL
               DO N=1, NZVAR
                  DELCOR(N) = DVEC(N,ID)*DQ*STP1(ID)
               END DO
               IF(INTTYP.EQ.1) THEN
                  DO N=1,NZVAR
                     ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                  END DO
                  CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                        X(LBETA),NAT1,NZVAR,X(LIZT),
     *                        X(LBETAT))
               END IF
               IF(INTTYP.EQ.2) THEN
                  CALL DCOPY(NCOORD,C0,1,C,1)
                  CALL BANDBI
                  CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                      ICONV,RUNTYP)
                  IF(ICONV.EQ.1) THEN
                     ICOUNT1 = ICOUNT1 + 1
                     ICOUNT1A  = ICOUNT1A  + 1
                     IF(MASWRK) WRITE(IW,9040)
                     MN = 0
                     DO M = 1, NAT1
                       DO N = 1, 3
                          MN = MN + 1
                          DELCOR(N)= VEC(MN,ID)*DQ*STP1(ID)
                       END DO
                    END DO
                  END IF
                  JQ = 1
                  DO J=1,NAT1
                     C(1,J) = C0(1,J) + DELCOR(JQ)
                     C(2,J) = C0(2,J) + DELCOR(JQ+1)
                     C(3,J) = C0(3,J) + DELCOR(JQ+2)
                     JQ = JQ + 3
                  END DO
               END IF
               JQ = 1
               DO J=1,NAT1
                  COORD_ALL(ID_NEW,JQ)   = C(1,J)
                  COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                  COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                  JQ = JQ + 3
               END DO
               IF(MASWRK) WRITE(IW,9050)
               DO IAT = 1,NAT1
                  IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                           C(1,IAT),C(2,IAT),C(3,IAT)
               ENDDO
            END DO
            NCOUNT1(IM) = ICOUNT1
         END DO
         IF (NCOUP.LE.1) GOTO 1000
C
C        2-MODE COUPLING
C
         DO IM=1,ISVIB
            ID=NC1-IMODE(IM)+1
            DO JM=IM+1,ISVIB
               JD=NC1-IMODE(JM)+1
               ICOUNT2 = 0
               IF(.NOT.PESALL .AND. .NOT.CHOOSEN(IM,JM)) GOTO 800
               DO IL=1,12
                  IF(MASWRK) WRITE(IW,9070) ID,JD,IL
                  NPAIR = 0
                  DO IC = 1, IM-1
                     NPAIR = NPAIR + (ISVIB - IC)
                  END DO
                  NPAIR = NPAIR + (JM-IM-1)
                  ID_NEW = ISVIB*6 + NPAIR*12 + IL
                  DO N=1, NZVAR
                     DELCOR(N) = DVEC(N,ID)*DQI(IL)*STP1(ID) +
     *                           DVEC(N,JD)*DQJ(IL)*STP1(JD)
                  END DO
                  IF(INTTYP.EQ.1) THEN
                     DO N=1,NZVAR
                        ZMAT_CUR(N) = ZMAT_OLD(N) + DELCOR(N)
                     END DO
                     CALL CONVRT(ZMAT_CUR,X(LBL),X(LALPHA),
     *                           X(LBETA),NAT1,NZVAR,X(LIZT),
     *                           X(LBETAT))
                  END IF
                  IF(INTTYP.EQ.2) THEN
                     CALL DCOPY(NCOORD,C0,1,C,1)
                     CALL BANDBI
                     CALL UPDISP(DELCOR,NZVAR,NCOORD,DXMAXT,OUT,ITBMAT,
     *                           ICONV,RUNTYP)
                     IF(ICONV.EQ.1) THEN
                        ICOUNT2 = ICOUNT2 + 1
                        ICOUNT2A  = ICOUNT2A  + 1
                        IF(MASWRK) WRITE(IW,9040)
                        MN = 0
                        DO M = 1, NAT1
                           DO N = 1, 3
                              MN = MN + 1
                              DELCOR(N) = VEC(N,ID)*DQI(IL)*STP1(ID) +
     *                                    VEC(N,JD)*DQJ(IL)*STP1(JD)
                           END DO
                        END DO
                     END IF
                     JQ = 1
                     DO J=1,NAT1
                        C(1,J) = C0(1,J) + DELCOR(JQ)
                        C(2,J) = C0(2,J) + DELCOR(JQ+1)
                        C(3,J) = C0(3,J) + DELCOR(JQ+2)
                        JQ = JQ + 3
                     END DO
                  END IF
                  JQ = 1
                  DO J=1,NAT1
                     COORD_ALL(ID_NEW,JQ)   = C(1,J)
                     COORD_ALL(ID_NEW,JQ+1) = C(2,J)
                     COORD_ALL(ID_NEW,JQ+2) = C(3,J)
                     JQ = JQ + 3
                  END DO
                  IF(MASWRK) WRITE(IW,9050)
                  DO IAT = 1,NAT1
                     IF(MASWRK) WRITE(IW,9060) IAT, ZAN(IAT),
     *                                C(1,IAT),C(2,IAT),C(3,IAT)
                  ENDDO
              END DO
              NCOUNT2(IM,JM) = ICOUNT2
  800 CONTINUE
            END DO
         END DO
      END IF
C
 1000 CONTINUE
C
         IF(MASWRK) WRITE(IW,9000)
         IF(ICOUNT1A.EQ.0 .AND. ICOUNT2A.EQ.0) THEN
            IF(MASWRK) WRITE(IW,9010)
         END IF
         IF(MASWRK .AND. ICOUNT1A.NE.0) THEN
            WRITE(IW,9110) ICOUNT1A,NPOINT1
            DO IM = 1,ISVIB
               ID = NC1 - IMODE(IM) + 1
               IF(NCOUNT1(IM).NE.0) WRITE(IW,9115) ID,NCOUNT1(IM)
            END DO
         END IF
         IF(MASWRK .AND. ICOUNT2A.NE.0) THEN
            WRITE(IW,9120) ICOUNT2A,NPOINT2
            DO IM = 1,ISVIB-1
               ID = NC1 - IMODE(IM) + 1
               DO JM = IM+1,ISVIB
                  JD = NC1 - IMODE(JM) + 1
                  IF(NCOUNT2(IM,JM).NE.0) WRITE(IW,9125)
     *                                    ID,JD,NCOUNT2(IM,JM)
               END DO
            END DO
         END IF
      CALL RETFM(NEED9)
      IF(INTTYP.EQ.1) CALL RETFM(NEED10)
C
      RETURN
C
 9000 FORMAT(/20X,'*** WARNING ***'/
     *       1X,'CARTESIAN NORMAL MODE DISPLACEMENT HAS BEEN USED'/
     *       1X,'IF TRANSFORMATION FROM INTERNAL TO CARTESIAN',
     *       1X,'COORDINATES HAS FAILED'/)
 9010 FORMAT(/20X,'*** SUCCESS ***'/
     *        1X,'NORMAL MODE DISPLACEMENTS IN INTERNAL COORDINATES'/
     *        1X,'WERE USED ON ALL THE GRID POINTS'/)
 9020 FORMAT(1X,'MODE ',I5,' GRID POINT ',I5)
 9030 FORMAT(1X,'MODE ',I5,' GRID POINT ',I5,
     *       5X,'MODE ',I5,' GRID POINT ',I5)
 9035 FORMAT(10X,'WARNING: DISPLACEMENT FROM PREVIOUS POINT WAS USED')
 9040 FORMAT(10X,'WARNING: CARTESIAN NORMAL MODE DISPLACEMENT WAS USED')
 9050 FORMAT(/1X,'ATOM',6X,'ATOMIC',22X,'COORDINATES (BOHR)'/
     *         11X,'CHARGE',9X,'X',19X,'Y',19X,'Z')
 9060 FORMAT(1X,I3,6X,F5.1,F17.10,2F20.10)
 9070 FORMAT(1X,'MODE1 ',I5,' MODE2 ',I5,' GRID POINT ',I5)
 9110 FORMAT (/20X,'*** WARNING ***'/
     *        15X,'--- DIAGONAL POTENTIAL ---'/
     *        1X,'TRANSFORMATION FROM INTERNAL TO CARTESIAN COORD'/
     *        1X,'FAILED ON ',I10,' OUT OF ',I10,' DIRECT PES POINTS.'/
     *        1X,'DISPLACEMENT FROM THE PREVIOUS POINT WAS USED ON'/)
 9115 FORMAT (1X,' MODE ',I10,' NUMBER OF POINTS ',I10)
 9120 FORMAT (/20X,'*** WARNING ***'/
     *        15X,'--- 2-MODE COUPLING POTENTIAL ---'/
     *        1X,'TRANSFORMATION FROM INTERNAL TO CARTESIAN COORD'/
     *        1X,'FAILED ON ',I10,' OUT OF ',I10,' DIRECT PES POINTS.'/
     *        1X,'DISPLACEMENT FROM THE PREVIOUS POINT WAS USED ON'/)
 9125 FORMAT (1X,' MODE PAIR',I10,I10,' NUMBER OF POINTS ',I10)
C
      END
C
C*MODULE VSCF    *DECK CHECK_ANGLE
      SUBROUTINE CHECK_ANGLE(ZMAT_CUR,ZMAT_OLD,DELCOR,DEL,NZVAR,NC1,
     *                       ITYP,ICONNCT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (ONE=1.0D+00,TWO=2.0D+00,PI=3.14159265359D+00)
C
      DIMENSION ZMAT_CUR(NZVAR),ZMAT_OLD(NZVAR),DELCOR(NC1),
     *          DEL(NZVAR),ITYP(NZVAR),ICONNCT(NZVAR,4)
C
C      COMMON /CONNEC/ IZ(MXATM,4),IATMOR(MXATM),NATM,NRATM,NDATM
C
C     CHECK THE ANGLES: BENDING AND TORSION
C     IF THE BENDING ANGLE IS PASSING THROUGH THE ZERO
C     CHECK IF THAT ANGLE IS CONTAINED IN THE TORSION
C     AND TAKE CARE OF BOTH THE BEND AND THE TORSION
C
      DO M = 1, NZVAR
         IF(ITYP(M).EQ.2) THEN
            IF(ZMAT_CUR(M).GT.PI) THEN
               ZMAT_OLD(M)=TWO*PI-ZMAT_OLD(M)
               DEL(M) = ONE
               ZMAT_CUR(M) = ZMAT_OLD(M) - DELCOR(M)
               I1 = ICONNCT(M,1)
               I2 = ICONNCT(M,2)
               I3 = ICONNCT(M,3)
               DO MN = 1, NZVAR
                  IF(ITYP(MN).EQ.3) THEN
                     IF(ICONNCT(MN,3).EQ.I2) THEN
                        IF(ICONNCT(MN,2).EQ.I1 .AND.
     *                       ICONNCT(MN,4).EQ.I3) THEN
                           ZMAT_OLD(MN) = ZMAT_OLD(MN) + PI
                           ZMAT_CUR(MN) = ZMAT_OLD(MN) + DELCOR(MN)
                        END IF
                        IF(ICONNCT(MN,2).EQ.I3 .AND.
     *                       ICONNCT(MN,4).EQ.I1) THEN
                           ZMAT_OLD(MN) = ZMAT_OLD(MN) + PI
                           ZMAT_CUR(MN) = ZMAT_OLD(MN) + DELCOR(MN)
                        END IF
                     END IF
                  END IF
               END DO
            END IF
         END IF
      END DO
C
      RETURN
C
      END
C
C*MODULE VSCF    *DECK MOVEFP
      SUBROUTINE MOVEFP(MOVE,I,J,K,VEC,NAT,NC1,
     *                  RQD1I,RQD2I,RQD2J,RQD3I,RQD3J,RQD3K)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION VEC(NC1,NC1)
C
      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 /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 /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORBX(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
C
      NMST=0
      NPST=0
      NDPST=0
      NRST=0
      NDST=0
      NATST=0
      NORST=0
      NAOST=0
      II = 3*NAT + 1
C
      MXBF=0
      DO IIII=1,NFRG
         MXBF=MAX(MXBF,NPBF(IIII))
      END DO
      CALL VALFM(LOADFM)
      LPROVEC = LOADFM  + 1
      LCANVEC = LPROVEC + MXBF*NTMO
      LAST    = LCANVEC + MXBF*NTAO
      NEED4=LAST-LOADFM-1
      CALL GETFM(NEED4)
      LENPV=MXBF*NTMO
      IF (NFRG.GT.0.AND.NTMO.GT.0)
     *   CALL DAREAD(IDAF,IODA,X(LPROVEC),LENPV,267,0)
      LENCV=MXBF*NTAO
      IF (NFRG.GT.0.AND.NTAO.GT.0)
     *   CALL DAREAD(IDAF,IODA,X(LCANVEC),LENCV,269,0)
      DO 100 III=1,NFRG
C
C      DIAGONAL POTENTIAL
       IF (K.EQ.0 .AND. J.EQ.0) THEN
           XDEL   = VEC(II,I)*RQD1I
           YDEL   = VEC(II+1,I)*RQD1I
           ZDEL   = VEC(II+2,I)*RQD1I
           THETAX = VEC(II+3,I)*RQD1I
           THETAY = VEC(II+4,I)*RQD1I
           THETAZ = VEC(II+5,I)*RQD1I
C
C      2-MODE COUPLING
       ELSE IF(K.EQ.0 .AND. J.NE.0) THEN
           XDEL   = VEC(II,I)*RQD2I +
     *              VEC(II,J)*RQD2J
           YDEL   = VEC(II+1,I)*RQD2I +
     *              VEC(II+1,J)*RQD2J
           ZDEL   = VEC(II+2,I)*RQD2I +
     *              VEC(II+2,J)*RQD2J
           THETAX = VEC(II+3,I)*RQD2I +
     *              VEC(II+3,J)*RQD2J
           THETAY = VEC(II+4,I)*RQD2I +
     *              VEC(II+4,J)*RQD2J
           THETAZ = VEC(II+5,I)*RQD2I +
     *              VEC(II+5,J)*RQD2J
C
C      3-MODE COUPLING
       ELSE IF(K.NE.0. .AND. J.NE.0) THEN
           XDEL   = VEC(II,I)*RQD3I +
     *              VEC(II,J)*RQD3J +
     *              VEC(II,K)*RQD3K
           YDEL   = VEC(II+1,I)*RQD3I +
     *              VEC(II+1,J)*RQD3J +
     *              VEC(II+1,K)*RQD3K
           ZDEL   = VEC(II+2,I)*RQD3I +
     *              VEC(II+2,J)*RQD3J +
     *              VEC(II+2,K)*RQD3K
           THETAX = VEC(II+3,I)*RQD3I +
     *              VEC(II+3,J)*RQD3J +
     *              VEC(II+3,K)*RQD3K
           THETAY = VEC(II+4,I)*RQD3I +
     *              VEC(II+4,J)*RQD3J +
     *              VEC(II+4,K)*RQD3K
           THETAZ = VEC(II+5,I)*RQD3I +
     *              VEC(II+5,J)*RQD3J +
     *              VEC(II+5,K)*RQD3K
       END IF
       IF (MOVE.EQ.0) THEN
           XDEL   = - XDEL
           YDEL   = - YDEL
           ZDEL   = - ZDEL
           THETAX = - THETAX
           THETAY = - THETAY
           THETAZ = - THETAZ
       END IF
       II=II+6
C
       CALL EFDSPL(III,XDEL,YDEL,ZDEL,THETAX,THETAY,THETAZ,
     *             NMST,NPST,NDPST,NRST,NDST,NATST,NORST,
     *             X(LPROVEC),NAOST,X(LCANVEC),MXBF)
C
       NMST  = NMST  + NMPTS(III)
       NPST  = NPST  + NPPTS(III)
       NDPST = NDPST + NDPPTS(III)
       NRST  = NRST  + NRPTS(III)
       NDST  = NDST  + NDPTS(III)
       NATST = NATST + NATEF(ISET(III))
       NORST = NORST + NORBX(III)
       NAOST = NAOST + NAO(ISET(III))
  100 CONTINUE
C
      IF (NFRG.GT.0.AND.NTMO.GT.0)
     *    CALL DAWRIT(IDAF,IODA,X(LPROVEC),LENPV,267,0)
      IF (NFRG.GT.0.AND.NTAO.GT.0)
     *    CALL DAWRIT(IDAF,IODA,X(LCANVEC),LENCV,269,0)
C
      CALL RETFM(NEED4)
C
      RETURN
C
      END
C
C*MODULE VSCF    *DECK COUP_VIB
      SUBROUTINE COUP_VIB(IMODE,COUNTS,GRADES,VEC,DVEC,INTCRD,
     *                    ISVIB,NAT1,NC1,NZVAR,CUTOFF,NFRG)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL COUNTS,INTCRD,GOPARR,DSKWRK,MASWRK
C
      DIMENSION COUNTS(ISVIB,ISVIB),GRADES(ISVIB,ISVIB),
     *          VEC(NC1,NC1),DVEC(NZVAR,NC1),IMODE(NC1)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     INITIALIZE
C
      DO I=1, ISVIB
        DO J=1, ISVIB
           COUNTS(I,J)=.FALSE.
        END DO
      END DO
C
C     GO OVER NORMAL MODES ONLY ON THE TOP OF THE TRIANGLE
C
      DO IM=1,ISVIB-1
         ID=NC1-IMODE(IM)+1
         DO JM=IM+1,ISVIB
            JD=NC1-IMODE(JM)+1
             CALL DOT_PROD(GRADE,ID,JD,NAT1,VEC,DVEC,NC1,NZVAR,
     *                     INTCRD,NFRG)
             GRADES(IM,JM)=GRADE
             IF(MASWRK) WRITE(IW,9000) ID,JD,GRADES(IM,JM)
         END DO
      END DO
C
      CALL ASSIGN(GRADES,COUNTS,ISVIB,CUTOFF)
C
      RETURN
C
 9000 FORMAT(1X,' MODES ',I5,1X,I5,1X,
     *       ' COUPLING STRENGTH ',1P,E8.1,0P)
C
      END
C
C*MODULE VSCF    *DECK DOT_PROD
      SUBROUTINE DOT_PROD(GRADE,I,J,NAT1,VEC,DVEC,NC1,NZVAR,INTCRD,NFRG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL INTCRD
C
      DIMENSION VEC(NC1,NC1),DVEC(NZVAR,NC1)
C
      PARAMETER (ZERO=0.0D+00)
C
C     RETURNS THE SUM OVER THE ATOMS OF THE GIVEN NORMAL MODE
C     OF SUM_OVER_K(ABS(X(I,K)*X(J,K)+Y(I,K)*Y(J,K)+Z(I,K)*Z(J,K))
C                 WHERE K IS THE ATOM NUMBER
C            GRADE   : COUPLING STRENGHT
C            I,J     : TWO NORMAL MODES THAT ARE BEING COUPLED
C            NAT1  : THE NUMBER OF THE ATOMS IN THE SYSTEM
C            NC1     : THE NUMBER OF DEGREES OF FREEDOM
C            VEC     : NORMAL MODE DISPLACEMENT VECTORS
C
      GRADE = ZERO
      IF(NAT1.GT.0) THEN
         IF(INTCRD) THEN
            MN = 1
            DO INT=1,NZVAR
               GRADE = ABS(DVEC(MN,I)*DVEC(MN,J)) + GRADE
               MN = MN + 1
            END DO
         ELSE
            MN    = 0
            DO IATM=1,NAT1
               GRADE = ABS(VEC(MN+1,I)*VEC(MN+1,J) +
     *                 VEC(MN+2,I)*VEC(MN+2,J) +
     *                 VEC(MN+3,I)*VEC(MN+3,J)) +
     *                 GRADE
              MN = MN + 3
            END DO
         END IF
      END IF
      IF(NFRG.GT.0) THEN
         II = 3*NAT1
         DO III=1,NFRG
            GRADE = ABS(VEC(II+1,I)*VEC(II+1,J)  +
     *                  VEC(II+2,I)*VEC(II+2,J)  +
     *                  VEC(II+3,I)*VEC(II+3,J)  +
     *                  VEC(II+4,I)*VEC(II+4,J)  +
     *                  VEC(II+5,I)*VEC(II+5,J)  +
     *                  VEC(II+6,I)*VEC(II+6,J)) +
     *                  GRADE
            II = II + 6
         END DO
      END IF
C
      RETURN
C
      END
C
C*MODULE VSCF    *DECK ASSIGN
      SUBROUTINE ASSIGN(GRADES,COUNTS,ISVIB,CUTOFF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL COUNTS
      DIMENSION COUNTS(ISVIB,ISVIB),GRADES(ISVIB,ISVIB)
C
C     CUTOFF=0 BY DEFAULT - ALL MODES WILL BE COUPLED
C
C
C     COUPLING WILL BE CALCULATED ONLY IF IT IS STRONGER THEN CUTOFF
C
      DO I=1, ISVIB-1
         DO J=I+1,ISVIB
            IF (GRADES(I,J) .GE. CUTOFF) COUNTS(I,J)=.TRUE.
         END DO
      END DO
C
      RETURN
C
      END
