C 13 MAR 06 - TN  - FRGROT: SMALL FIX FOR EFP/FMO INTERFACE
C 22 FEB 06 - LVS - SYNCHRONIZE STNBUF COMMON
C 17 JAN 06 - HL  - EFINP: READ ISWF,SWFR1,SWFR2 FOR PBC/MD
C 14 NOV 05 - MWS - PAULIX: SKIP DYN.POL. OUTPUT IF NOT COMPUTED
C 19 SEP 05 - IA  - SYNCHRONIZE FRGINF COMMON
C 15 JUL 05 - MWS - EFINP: VCLR EFP2 STORAGE ONLY IF USED
C 13 JUL 05 - HL  - EFINP: ZEROING, POLMETHOD=SCF MUST HAVE AB INIT SYS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - HL  - PERIODIC BOUNDARY COND. FOR EFP
C 27 JUN 05 - IA  - PAULIX: PARALLEL MUST READ DYN.POLAR. DAF RECORD
C  1 JUN 05 - MWS - REMOVE PARALLEL MP2/EFP1 TRAP, H2OEF2->H2ORHF
C 14 MAR 05 - HL  - PAULIX: PUNCH OUT CANONICAL MO AND FOCK MATRIX
C                   RDCANV: NEW ROUTINE TO READ IN CAN. MO/FOCK
C                   FRGROT: ROTATE CAN. MO, ADD F AND G FUNCTIONS
C  7 MAR 05 - IA  - CHANGES TO READ/ROTATE DYNAMIC POLARIZABILITY
C 22 FEB 05 - MWS - EFINP: ZERO ALL POTENTIALS, KILL BUGGY PAR. RUNS
C 13 FEB 05 - HMN - EFINP: ADD DUMMY POLMETHD=SPCE TO TREAT SPCE WATERS
C                   EFINP: ADD DUMMY FRGMNT = $H2OSPC TO GET SPCE WATERS
C                   ADD SPCEWA ROUTINE TO GET STANDARD SPCE DATA
C                   EFINP: ADD KEYWORD FRAGTYP TO CHECK FOR MP2 RUN
C 13 FEB 05 - JS  - EFP MP2 CHANGES TO EFINP,FRGROT,RDGFDP, AND READING
C  9 DEC 03 - MWS - WRITE ERROR MESSAGE BEFORE -ALL- ABORT CALLS
C 26 MAR 03 - MWS - EFPX: FIX THE PULL THE PLUG ERROR MESSAGE
C 12 DEC 02 - IA  - ADD DFT WATER PARAMETERIZATION,
C           - MWS - PREFIN: ALWAYS CALLED, EXIT W/O READ IF NOT MAKEFP
C 17 AUG 02 - MWS - PRTFRG: FIX SOME PRINTING
C  7 AUG 02 - IA  - RDSTFR,FRGROT,RDSCRN: READ EXPONENTIAL CHG SCREENING
C  7 AUG 02 - HT  - USE DYNAMIC MEMORY FOR PAULI REPULSION
C  7 AUG 02 - HL,PM - PAULIX: CONTROL EFP GENERATION, NEW PREFIN
C 17 APR 02 - PND - RDPMO: TRAP ARRAY OVERFLOW
C 26 MAR 02 - KRG - USE ABRT CALLS
C 13 JUN 01 - PM,MAF - PAULIX: OVERLAPPING BUFFERS, EFPX: CHG PEN CALLS
C 28 FEB 01 - PND - RDPMO: SAVE PAULING BASIS SET SIZE IN COMMON
C 19 NOV 00 - RMM,HL - PAULIX: PAD OUT EDCMP FOR POLAPP KEYWORD
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER, VARIABLES IN BCAST CALLS
C 16 FEB 00 - VK  - EFPX: REMOVED REDUNDANT LMOINP CALL
C                   EFINP: NEW KEYWORD NBUFMO FOR QM/MM CALCULATIONS
C                   PAULIX: SKIP FROZEN QM/MM BUFFER ORBS IN POLAR PUNCH
C 27 FEB 98 - MWS - EFINP: EXIT IF NOT DOING PAULI POTENTIAL
C 20 NOV 97 - MWS - EFINP: KILL AB INITIO RUNS IF JAN'S PAULI POTENTIAL
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 16 JUL 97 - GNM - EFINP: ALLOW DEFINITION OF TIP*P MODELS
C  8 MAY 97 - PND - RDPMO: CHANGES FOR PARALLEL COMPUTATION
C  7 MAR 97 - JF  - RDFGRP: DECLARE REREAD TO BE EXTERNAL
C 20 DEC 96 - HPP - FRGROT: DECLARE ARGUMENT AS CHARACTER TYPE
C 18 DEC 96 - JHJ - NUMEROUS CHANGES RELATED TO NEW PAULI REPULSION
C 16 DEC 96 - PND - EFNP: CORRECTION FO RDFGRP'S DAREAD CLAUSE
C 30 OCT 96 - SPW - EFINP: ALLOW MCSCF+IEFP RUNS
C 17 OCT 96 - MWS - EFINP,RDFRG: BOMB MCSCF+IEFP RUNS, CHECK FOR -ZNUC-
C 29 SEP 96 - MWS - INPUT CHECKING, REMOVE FRAG-FRAG REPULSION COMMON,
C                   RDDFRL,RDFRG,RDFRG2,WATRHF: REMOVE BIEXPONENTIAL
C 14 SEP 96 - BMB - EFINP: INSERT CALL TO PREPARE ERF TABLE.
C 10 SEP 96 - JHJ - EFINP,WATRHF: STORE WATER FRAGMENT INTERNALLY.
C 10 SEP 96 - MWS - EFINP,RDDFRL: CHANGE INPUT A BIT
C 24 MAY 96 - WC  - REMOVE EFPEX IN COMMOM EFPPAR
C  9 JAN 96 - WC  - INPUT FRAGMENT ATOMIC NUMBERS TO IDENTIFY ATOMS
C 12 SEP 95 - WC  - FIXES IN FRGROT,RDSTFR, ADD RDDFRL, COMMON FRGTYP
C 18 AUG 95 - MWS - RENAME RDCRD TO RDCRDX TO AVOID NBO NAME CONFLICT
C  5 JAN 95 - PND - CHANGES FOR UNSYMMETRIC POLARIZABILITY TENSORS
C 23 NOV 94 - MWS - REMOVE ALL FTNCHEK ERRORS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C 27 NOV 91 - JHJ - PRTFRG:IMPROVE PRINTOUT.
C 28 OCT 91 - JHJ - EFINP:OPEN FILE 25.
C 30 JUL 91 - JHJ - CHANGED THE WAY MULTIPOLE INFORMATION IS READ IN.
C 11 JUL 91 - JHJ - RDREP:READ IN REPULSIVE POTENTIAL INFORMATION.
C 10 JUL 91 - JHJ - EFINP,RDFRG:USE UNIT INFORMATION FROM $CONTRL.
C  9 JUL 91 - JHJ - RDSTFR:READ IN POLARIZABILITY INFORMATION.
C                   EFINP:ADDED OPTION TO READ IN METHOD INF.
C 18 JUN 91 - JHJ - NEW MODULE-READ IN MULTIPOLE INFORMATION.
C
C*MODULE EFINP   *DECK EFINP
      SUBROUTINE EFINP(IUNTRD,IEF)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXPT=2000, MXFRG=1050, MXFGPT=12000, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      LOGICAL STOP,GOPARR,MASWRK,DSKWRK,BILTIN
      LOGICAL DSKSAV
C
      CHARACTER*8 PTNAM,TEMP,WORD2,WORD3,FRGMNT
      CHARACTER*6 FRGNAM
      CHARACTER*1 DOLLAR,BLANK
      CHARACTER*8 TYPCRD(2),TYPPOS(3),TYPPOL(5)
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),
     *                NAT(MXDFG),NUM(MXDFG),NTPATM
      COMMON /EFPBUF/ POLCHG(10),NBUFMO,LBUFF(MXAO),LBF,NAPOL,IAPOL(10)
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /EFPOTD/ METHOD,INABIO,MOVE
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /FMCOM / XX(1)
      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
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /INFOA / NATINF,ICH,MUL,NUMINF,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
C
      SAVE ICYC
C
      DATA TYPCRD/'CART    ','INT     '/
      DATA TYPPOS/'FIXED   ','OPTIMIZE','EFOPT   '/
      DATA TYPPOL/'FRGSCF  ','SCF     ','TIP3P   ','TIP4P   ',
     *             'SPCE    '/
      DATA DOLLAR,BLANK/'$',' '/
      DATA ICYC/0/
C
C   THIS ROUTINE IS THE MAIN DRIVER FOR EFFECTIVE FRAGMENT INPUT
C         WRITTEN BY JAN H. JENSEN 6/91 NDSU/CARB
C
C         ----- BY DEFAULT, SWITCH OFF ALL EFP TERMS -----
C     FIRST, ZERO THE NUMBER OF EFPS, AND THEN ALL POTENTIAL TYPES
C
      NFRG = 0
C
C                 MULTIPOLE EXPANSIONS OF THE ELECTROSTATICS
C                 CHARGE PENETRACTION SCREENING OF ELECTROSTATICS
      IEFC = 0
      IEFD = 0
      IEFQ = 0
      IEFO = 0
      ICHGP= 0
C                 DIPOLE POLARIZABILITY
      IEFP = 0
C                 2ND ORDER POLARIZABILITY CORRECTION
      IEFP2= 0
C                 FITTED REPULSIVE POTENTIAL (NAMELY WATER!) FOR EFP-1
      IREP = 0
C
C                 TERMS FOR EFP-2 POTENTIALS
C                 PAULI FORMULA REPULSIVE POTENTIAL
      NTMO = 0
      NTAO = 0
C                 DISPERSION
      IEFDP= 0
C
C        AND THEN ZAP ALL EXPANSION POINTS FOR ALL SUCH TERMS ABOVE
C
      NMTTPT = 0
      NPTTPT = 0
      NDPTTPT= 0
      NRTTPT = 0
      NDTTPT = 0
      NTPATM = 0
      DO I=1,MXFRG
         NMPTS(I) = 0
         NPPTS(I) = 0
         NDPPTS(I)= 0
         NRPTS(I) = 0
         NDPTS(I) = 0
         NORB(I)  = 0
      ENDDO
      DO I=1,MXDFG
         NAT(I)   = 0
         NUM(I)   = 0
         NAO(I)   = 0
         NOCC(I)  = 0
         NVIR(I)  = 0
      ENDDO
C
      METHOD= -1
      MOVE  = -1
      INT   = -1
      NBM   = -1
      MXMO  =  0
      MXBF  =  0
      IFGTYP= -1
C
      XBOX = 0.0D+00
      YBOX = 0.0D+00
      ZBOX = 0.0D+00
      XCUT = 1.0D+10
      YCUT = 1.0D+10
      ZCUT = 1.0D+10
      RCUT = 1.0D+10
      SWR1 = 1.0D+10
      SWR2 = 2.0D+10
      ISWF = 1
C
      CALL VCLR(XCRD,1,3*MXFRG)
      CALL VCLR(YCRD,1,3*MXFRG)
      CALL VCLR(ZCRD,1,3*MXFRG)
C
C     ----- POSITION THE INPUT TO $EFRAG -----
C     IF THIS GROUP IS ABSENT, EXIT WITH NO EFFECTIVE FRAGMENTS IN USE
C
      IERR = 0
      IEOF = 0
      CALL SEQREW(IR)
      CALL FNDGRP(IR,' $EFRAG ',IEOF)
      IF(IEOF.NE.0) THEN
         IEF = 0
         RETURN
      ELSE
         IEF=1
      END IF
C
C        SET UP ERROR FUNCTION INTERPOLATION TABLE
C
      CALL ERRT
C
C        READ MAIN $EFRAG KEYWORDS
C
      IF(NATINF.EQ.0) CALL OPNCRD(IR,-IW)
      CALL RDCARD('$EFRAG  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE LOOKING FOR $EFRAG GROUP'
         CALL ABRT
      END IF
 140  CONTINUE
      WORD2='        '
      LGSTR=-8
      CALL GSTRNG(WORD2,LGSTR)
      IF(WORD2.EQ.'        ') GO TO 145
C
      IF(WORD2.EQ.'POLMETHD') THEN
         WORD3='        '
         LGSTR=-8
         CALL GSTRNG(WORD3,LGSTR)
         METHOD=-2
         IF(WORD3.EQ.'FRGSCF  ') METHOD=2
         IF(WORD3.EQ.'SCF     ') METHOD=3
         IF(WORD3.EQ.'TIP3P   ') METHOD=4
         IF(WORD3.EQ.'TIP4P   ') METHOD=5
         IF(WORD3.EQ.'SPCE    ') METHOD=6
         IF(METHOD.EQ.-2) THEN
            IF(MASWRK) WRITE(IW,*) '$EFRAG: ILLEGAL POLMETHD=',WORD3
            CALL ABRT
         END IF
C           W/O AB INITIO SYSTEM, POLMETHOD=SCF MAKES NO SENSE AT ALL
         IF(NUMINF.EQ.0  .AND.  METHOD.EQ.3) METHOD=2
         GO TO 140
      END IF
C
      IF(WORD2.EQ.'POSITION') THEN
         WORD3='        '
         LGSTR=-8
         CALL GSTRNG(WORD3,LGSTR)
         MOVE=-2
         IF(WORD3.EQ.'FIXED   ') MOVE=0
         IF(WORD3.EQ.'OPTIMIZE') MOVE=1
         IF(WORD3.EQ.'EFOPT   ') MOVE=2
         IF(MOVE.EQ.-2) THEN
            IF(MASWRK) WRITE(IW,*) '$EFRAG: ILLEGAL POSITION=',WORD3
            CALL ABRT
         END IF
         GO TO 140
      END IF
C
      IF(WORD2.EQ.'COORD   ') THEN
         WORD3='        '
         LGSTR=-8
         CALL GSTRNG(WORD3,LGSTR)
         INT=-2
         IF(WORD3.EQ.'CART    ') INT=0
         IF(WORD3.EQ.'INT     ') INT=1
         IF(INT.EQ.-2) THEN
            IF(MASWRK) WRITE(IW,*) '$EFRAG: ILLEGAL COORD=',WORD3
            CALL ABRT
         END IF
         GO TO 140
      END IF
C
      IF(WORD2.EQ.'NBUFFMO ') THEN
        NBUFMO=-2
        NBUFMO = IFIND('NBUFMO  ',IERR)
        IF(NBM.EQ.-2) THEN
           IF(MASWRK) WRITE(IW,*) '$EFRAG: ILLEGAL NBUFFMO=',NBM
           CALL ABRT
        END IF
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'MXMO    ') THEN
        MXMO = IFIND('MXMO    ',IERR)
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'MXBF    ') THEN
        MXBF = IFIND('MXBF    ',IERR)
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'XBOX    ') THEN
        XBOX = RFIND('XBOX    ',IERR)
        XBOX = XBOX/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'YBOX    ') THEN
        YBOX = RFIND('YBOX    ',IERR)
        YBOX = YBOX/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'ZBOX    ') THEN
        ZBOX = RFIND('ZBOX    ',IERR)
        ZBOX = ZBOX/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'XCUT    ') THEN
        XCUT = RFIND('XCUT    ',IERR)
        XCUT = XCUT/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'YCUT    ') THEN
        YCUT = RFIND('YCUT    ',IERR)
        YCUT = YCUT/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'ZCUT    ') THEN
        ZCUT = RFIND('ZCUT    ',IERR)
        ZCUT = ZCUT/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'RCUT    ') THEN
        RCUT = RFIND('RCUT    ',IERR)
        RCUT = RCUT/0.52917724924D+00
        RCUT = RCUT*RCUT
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'SWR1    ') THEN
        SWR1 = RFIND('SWR1    ',IERR)
        SWR1 = SWR1/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'SWR2    ') THEN
        SWR2 = RFIND('SWR2    ',IERR)
        SWR2 = SWR2/0.52917724924D+00
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'ISWF    ') THEN
        ISWF = IFIND('ISWF    ',IERR)
        GO TO 140
      END IF
C
      IF(WORD2.EQ.'FRAGTYP') THEN
         WORD3='        '
         LGSTR=-8
         CALL GSTRNG(WORD3,LGSTR)
         IFGTYP=-2
         IF(WORD3.EQ.'MP2     ') IFGTYP=1
         IF(IFGTYP.EQ.-2) THEN
            IF(MASWRK) WRITE(6,*) '$EFRAG: ILLEGAL FRAGTYP=',WORD3
            CALL ABRT
         END IF
         GO TO 140
      END IF
C
      IF(MASWRK) WRITE (IW,*) '$EFRAG: UNRECOGNIZED KEYWORD=',WORD2
      CALL ABRT
C
C         PROVIDE DEFAULTS IF KEYWORD WAS NOT READ
C
 145  CONTINUE
      IF(INT   .EQ.-1) INT   =0
      IF(METHOD.EQ.-1) METHOD=2
      IF(MOVE  .EQ.-1) MOVE  =1
      IF(NBUFMO.EQ.-1) NBUFMO=0
      IF(IFGTYP.EQ.-1) IFGTYP=0
      IF(MASWRK) WRITE(IW,9020) TYPCRD(INT+1),TYPPOS(MOVE+1),
     *                          TYPPOL(METHOD-1),NBUFMO
C
C ---- READ IN EACH FRAGMENT AND KEEP TRACK OF HOW MANY WE READ IN ----
C
      NFRG=1
      STOP = .FALSE.
  150 CONTINUE
      IF(NFRG.GT.MXFRG) THEN
         IF(MASWRK) WRITE(IW,*) 'EXCEEDED MXFRG=',MXFRG
         CALL ABRT
      END IF
      IF(INT.EQ.0) THEN
         CALL RDFRG(IUNTRD,NFRG,STOP)
      ELSE
         CALL RDFRG2(NFRG,STOP)
      END IF
      IF(STOP) GO TO 160
      NFRG = NFRG + 1
      GO TO 150
C
  160 CONTINUE
      IF(MASWRK) WRITE(IW,9030) NFRG
C
C     ---- OBTAIN THE EFFECTIVE FRAGMENT POTENTIAL ----
C     THIS MAY BE READ FROM INPUT, OR INTERNALLY BUILT-IN
C
      NTMOF=NFRG*MXMO
      MXMO2=(MXMO*MXMO+MXMO)/2
      NTAOF=NFRG*MXBF
      CALL VALFM(LOADFM)
      LPROVEC = LOADFM  + 1
      LFOCKMA = LPROVEC + MXBF*NTMOF
      LCANVEC = LFOCKMA + MXMO2*NFRG
      LAST    = LCANVEC + MXBF*NTAOF
      NEED = LAST-LOADFM-1
      CALL GETFM(NEED)
C
C ---- WE NOW FIND THE PERTINENT INFORMATION OF EACH FRAGMENT
C
      IF(MXBF.GT.0) THEN
         CALL VCLR(XX(LPROVEC),1,MXBF*NTMOF)
         CALL VCLR(XX(LFOCKMA),1,MXMO2*NFRG)
         CALL VCLR(XX(LCANVEC),1,MXBF*NTAOF)
         CALL VCLR(CANFOK     ,1,MXAO*MXDFG)
      END IF
      I=1
  170 CONTINUE
      WRITE(UNIT=TEMP,FMT='(A1,A1,A6)') BLANK,DOLLAR,FRGNAM(I)
      READ(UNIT=TEMP,FMT='(A8)') FRGMNT
C
C ---- CHECK TO SEE IF FRAGMENT POTENTIAL IS INTERNALLY STORED,
C ---- OTHERWISE FIND $FRGNAM(ICNT) AND READ IN INFORMATION
C
      IF      (FRGMNT.EQ.' $H2ORHF') THEN
                CALL WATRHF(I)
      ELSE IF (FRGMNT.EQ.' $H2ODFT') THEN
                CALL WATDFT(I)
      ELSE IF (FRGMNT.EQ.' $H2OSPC') THEN
                CALL SPCEWA(I)
      ELSE
         IF (MASWRK) WRITE(IW,9050) FRGMNT
         CALL RDSTFR(FRGMNT,I,XX(LPROVEC),XX(LFOCKMA),XX(LCANVEC),
     *               MXBF,NTAOF,MXMO,MXMO2,NTMOF,IFGTYP)
      END IF
C
C        TRANSLATE/ROTATE THE FRAGMENT JUST READ TO ITS ACTUAL POSITION,
C        UPDATING ALL TERMS IN THE POTENTIAL FOR ITS TRUE ORIENTATION.
C
      CALL FRGROT(FRGMNT,I,XX(LPROVEC),XX(LCANVEC),MXBF,NTMOF,NTAOF)
C
C        NOTE THAT THE RUNNING TOTALS MUST BE UPDATED AFTER ORIENTATION.
C
      NMTTPT = NMTTPT + NMPTS(I)
      NPTTPT = NPTTPT + NPPTS(I)
      NDPTTPT= NDPTTPT+ NDPPTS(I)
      NRTTPT = NRTTPT + NRPTS(I)
      NDTTPT = NDTTPT + NDPTS(I)
      NTPATM = NTPATM + NAT(ISET(I))
      NTMO   = NTMO   + NORB(I)
      NTAO   = NTAO   + NAO(ISET(I))
C
C        THE NEXT TEST IS ACTUALLY A LITTLE BIT TOO LATE, AS CREATING
C        AND STORING THE LAST FRAGMENT IN THE CALLS ABOVE WOULD HAVE
C        ALREADY GONE BEYOND THE ARRAY BOUNDS.
C        THIS IS CERTAINLY A GOOD PLACE TO QUIT, IF THAT HAS HAPPENED!
C
      NPMAX = MAX(NMTTPT,NPTTPT,NRTTPT,NDTTPT)
      IF(NPMAX.GT.MXFGPT) THEN
         IF(MASWRK) WRITE(IW,9200) I,NFRG,NMTTPT,NPTTPT,NDPTTPT,
     *                               NRTTPT,NDTTPT,MXFGPT
         CALL ABRT
      END IF
      I = I + 1
      IF(I.GT.NFRG) GO TO 200
      GO TO 170
C
  200 CONTINUE
C
C ---- WRITE PROVEC & FOCKMA
C
      LENPV=MXBF*NTMO
      LENFM=MXMO2*NFRG
      CALL DAWRIT(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
      CALL DAWRIT(IDAF,IODA,XX(LFOCKMA),LENFM,268,0)
      LENCV=MXBF*NTAO
      CALL DAWRIT(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
      CALL RETFM(NEED)
C
      IF (MASWRK) THEN
         WRITE(IW,9100) NMTTPT
         WRITE(IW,9120) NPTTPT
C     IF AT MP2 LEVEL, ONE MORE EXPANSION POINT FOR
C     POLARIZABILITY AT THE CENTER OF MASS FOR
C     EACH FRAGMENT. IT WILL NOT BE CONSIDERED AT
C     HF LEVEL.
         IF(IEFP2.EQ.1) THEN
           WRITE(IW,9121) NDTTPT
         END IF
         WRITE(IW,9130) NDPTTPT
         WRITE(IW,9140) NRTTPT
         WRITE(IW,9160) NTPATM
         WRITE(IW,9170) NTMO
         WRITE(IW,9175) NTAO
      END IF
C
C         PARALLEL EXECUTION OF EFP2 IS NOT ENABLED AT THIS TIME
C
      IF(GOPARR  .AND.  NTMO.GT.0  .AND.  NATINF.GT.0) THEN
         IF(MASWRK) WRITE(IW,*)
     *       'ERROR, AI/EFP2 COMPUTATIONS CANNOT RUN IN PARALLEL YET.'
         CALL ABRT
      END IF
C
      CALL DERCHK(NDER)
      IF(NATINF.GT.0  .AND.  NTMO.GT.0  .AND.  NDER.GT.0) THEN
         IF(MASWRK) WRITE(IW,9180)
         CALL ABRT
      END IF
C
      IF (ICYC.GT.0) GO TO 800
C
C ---- READ FRAGMENT REPULSION CONSTANTS
C
      MXRPTS=0
      DO 400 IFRG=1,NFRG
         MXRPTS = MAX(NRPTS(IFRG),MXRPTS)
  400 CONTINUE
      MXRPTS=MXRPTS+1
      NDFRG2 = (NDFRG*NDFRG+NDFRG)/2
      LEN = MXRPTS*MXRPTS*NDFRG2
      CALL VALFM(LOADFM)
      LAREL = LOADFM + 1
      LCREL = LAREL  + LEN
      LAST  = LCREL  + LEN
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C        READ THE INTER-FRAGMENT REPULSIVE POTENTIAL GROUP $FRGRPL.
C        IF ONLY THE INTERNALLY STORED H2ORHF IS BEING USED, SKIP.
C
      IF (NTMO.GT.0) GO TO 500
      IF (METHOD.GE.4) GO TO 500
C
      BILTIN = FRGMNT.EQ.' $H2ORHF' .OR. FRGMNT.EQ.' $H2ODFT'
      IF (NFRG.GT.1 .AND. .NOT.BILTIN) THEN
         CALL RDFGRP(XX(LAREL),XX(LCREL),MXRPTS,NDFRG2)
         CALL DAWRIT(IDAF,IODA,XX(LAREL),2*LEN,75,0)
      ELSE IF (NFRG.GT.1) THEN
         CALL DAREAD(IDAF,IODA,XX(LAREL),2*LEN,75,0)
      END IF
C
C ---- PRINT OUT INFORMATION FOR FRAGMENT
C
  500 CONTINUE
      CALL PRTFRG(XX(LAREL),XX(LCREL),MXRPTS,NDFRG2)
      CALL RETFM(NEED)
C
      IF(IEFP2.EQ.1) THEN
C ---- READ FRAGMENT DISPERSION CONSTANTS
C
        MXDPTS=0
        DO 550 IFRG=1,NFRG
C         ATTENTION!!!!
C         TEMPORARILY NDPTS IS EQUAL TO NRPTS
C         ATTENTION!!!!
C         NDPTS(IFRG)=NRPTS(IFRG)
          MXDPTS = MAX(NDPTS(IFRG),MXDPTS)
  550   CONTINUE
        MXDPTS=MXDPTS+1
        NDFRG2 = (NDFRG*NDFRG+NDFRG)/2
        LEN = MXDPTS*MXDPTS*NDFRG2
C       **************************
C       C6 ONLY OR C6 AND C8
C       LC6=1
C       LC8=1
C       **************************
        CALL VALFM(LOADFM)
        LAREL = LOADFM + 1
        LDREL = LAREL  + LEN
        LCREL = LDREL  + LEN
C       ******************************
C       NEEDS FUTURE MODIFICATION TO
C       IDENTIFY C6 ONLY OR  LC6=1
C       C6 AND C8.           LC8=1
C       ******************************
        LAST  = LCREL  + LEN
        LBREL = LAST   + LEN
        LEREL = LBREL  + LEN
        LAST1 = LEREL  + LEN
C       ******************************
C       FOR C6 ONLY
C       IF(LC6.EQ.1)  NEED  = LAST  - LOADFM - 1
C       ******************************
C       FOR C6 AND C8
C       IF(LC8.EQ.1)  NEED  = LAST1 - LOADFM - 1
        NEED  = LAST1 - LOADFM - 1
        CALL GETFM(NEED)
C
C     READ THE INTER-FRAGMENT DISPERSION GROUP $FRGDPS.
C
C     ATTENTION: THE DATA ARE WRITTEN INTO FILE 81!!!
C
        IF (NTMO.GT.0) GO TO 600
        IF (METHOD .GE. 4) GO TO 600
C
        BILTIN = FRGMNT.EQ.' $H2ORHF' .OR. FRGMNT.EQ.' $H2ODFT'
C
C       0: FOR C6 TERM
C       1: FOR C8 TERM
C
        IF (NFRG.GT.1 .AND. .NOT.BILTIN) THEN
          CALL RDFGDP(XX(LAREL),XX(LDREL),XX(LCREL),MXDPTS,NDFRG2,0)
          CALL RDFGDP(XX(LAST), XX(LBREL),XX(LEREL),MXDPTS,NDFRG2,1)
          CALL DAWRIT(IDAF,IODA,XX(LAREL),6*LEN,81,0)
        ELSE IF (NFRG.GT.1) THEN
          CALL DAREAD(IDAF,IODA,XX(LAREL),6*LEN,81,0)
        END IF
  600   CONTINUE
C
C       0: FOR C6 TERM
C       1: FOR C8 TERM
        CALL PRTFRG1(XX(LAREL),XX(LDREL),XX(LCREL),MXDPTS,NDFRG2,0)
        CALL PRTFRG1(XX(LAST), XX(LBREL),XX(LEREL),MXDPTS,NDFRG2,1)
        CALL RETFM(NEED)
C
      END IF
C
C ---- OPEN FILE 25 IF WE HAVE POLARIZABLE POINTS
C
      IF(IEFP.EQ.1) THEN
             DSKSAV = DSKWRK
             DSKWRK = .TRUE.
             CALL SEQOPN(25,'EFPIND','UNKNOWN',.FALSE.,'UNFORMATTED')
             DSKWRK = DSKSAV
      ENDIF
C
  800 CONTINUE
      ICYC=ICYC+1
      RETURN
C
 9020 FORMAT(/1X,'READING $EFRAG GROUP'/
     *        1X,'COORD=',A8,'  POSITION=',A8,'  POLMETHD=',A8,
     *           ' NBUFFMO=',I1)
 9030 FORMAT(1X,I3,1X,'FRAGMENTS ARE USED IN THIS CALCULATION'/)
 9050 FORMAT(1X,'SEARCHING FOR FRAGMENT',A8)
 9100 FORMAT(1X,' TOTAL NUMBER OF MULTIPOLE POINTS=   ',I3)
 9120 FORMAT(1X,' TOTAL NUMBER OF POLARIZABLE POINTS= ',I3)
 9121 FORMAT(1X,' TOTAL NUMBER OF DISPERSION POINTS=  ',I3)
 9130 FORMAT(1X,' TOTAL NUMBER OF DYNAMIC POLARIZABLE POINTS= ',I3)
 9140 FORMAT(1X,' TOTAL NUMBER OF REPULSIVE POINTS=   ',I3)
 9160 FORMAT(1X,' TOTAL NUMBER OF AO CENTERS=         ',I3)
 9170 FORMAT(1X,' TOTAL NUMBER OF EFP MOS=            ',I3)
 9175 FORMAT(1X,' TOTAL NUMBER OF EFP AOS=           ', I4)
 9180 FORMAT(//1X,'*** ERROR ***'/
     *   1X,'THIS RUN WITH AB INITIO ATOMS REQUESTING A GRADIENT'/
     *   1X,'CURRENTLY WORKS ONLY WITH THE FITTED REPULSIVE POTENTIAL')
 9200 FORMAT(1X,'ONE OF THE EFP DIMENSIONS HAS JUST EXCEEDED MXGFPT.'/
     *       1X,'WHILE SETTING UP EFP NO.',I6,' OF',I6,' TOTAL EFPS.'/
     *       1X,'TOTAL EXPANSION POINTS OF EACH TYPE (SO FAR) ARE:'/
     *       1X,'          MULTIPOLE POINTS=',I8/
     *       1X,'     POLARIZABILITY POINTS=',I8/
     *       1X,'DYN. POLARIZABILITY POINTS=',I8/
     *       1X,'   FITTED REPULSIVE POINTS=',I8/
     *       1X,'         DISPERSION POINTS=',I8/
     *       1X,'   BUT PARAMETER MXFGPT WAS',I8,' AT COMPILE TIME')
      END
C
C*MODULE EFINP   *DECK PRTFRG1
      SUBROUTINE PRTFRG1(AREL,DREL,CREL,MXRPTS,NDFG2,LC)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION AREL(MXRPTS,MXRPTS,NDFG2),CREL(MXRPTS,MXRPTS,NDFG2)
      DIMENSION DREL(MXRPTS,MXRPTS,NDFG2)
C
      PARAMETER (MXDFG=5, MXPT=2000, MXFRG=1050, MXFGPT=12000)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      CHARACTER*6 FRGNAM
      CHARACTER*8 KNAME,LNAME,PTNAM,DNAME,DPSNAM
C
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
C
C     ----- WRITE INFORMATION ON DISPERSION -----
C
      IF (.NOT.MASWRK) RETURN
C
      IJ=0
      WRITE(IW,9230) NDFRG,NDFG2
      NSHFTI=0
      DO 780 I=1,NDFRG
         NSHFTJ=0
         DO 770 J=1,I
            IJ=IJ+1
            IF(LC.EQ.0) THEN
              WRITE(IW,9240) FRGNAM(NAMIDX(I)),FRGNAM(NAMIDX(J))
            ELSE IF (LC.EQ.1) THEN
              WRITE(IW,9241) FRGNAM(NAMIDX(I)),FRGNAM(NAMIDX(J))
            END IF
            KMAXR = NDPTS(NAMIDX(I))+1
            LMAXR = NDPTS(NAMIDX(J))+1
            DO 760 K=1,KMAXR
               IF(K.EQ.KMAXR) THEN
                  KNAME = 'CENTER  '
               ELSE
                  KNAME = DPSNAM(NSHFTI+K)
               END IF
               DO 750 L=1,LMAXR
                  IF(L.EQ.LMAXR) THEN
                     LNAME = 'CENTER  '
                  ELSE
                     LNAME = DPSNAM(NSHFTJ+L)
                  END IF
                  WRITE(IW,9250) KNAME,LNAME,CREL(K,L,IJ),DREL(K,L,IJ),
     *                           AREL(K,L,IJ)
  750          CONTINUE
  760       CONTINUE
            NSHFTJ=NSHFTJ+NDPTS(J)
  770    CONTINUE
         NSHFTI=NSHFTI+NDPTS(I)
  780 CONTINUE
C
      RETURN
C
 9230 FORMAT(/1X,'THERE ARE',I4,' FRAGMENT TYPES, AND',I4,
     *            ' FRAGMENT-FRAGMENT INTERACTIONS.')
 9240 FORMAT(/1X,'DISPERSION FIT FOR FRAGMENT PAIR ',A6,'-',A6,
     *           ' (C6,COEF,EXPONENT)')
 9241 FORMAT(/1X,'DISPERSION FIT FOR FRAGMENT PAIR ',A6,'-',A6,
     *           ' (C8,COEF,EXPONENT)')
 9250 FORMAT(1X,A8,'-',A8,3X,F18.8,2X,F18.8,2X,F18.8)
      END
C
C*MODULE EFINP   *DECK FRGROT
      SUBROUTINE FRGROT(FRGMNT,N,PROVEC,CANVEC,MXBF,NTMOF,NTAOF)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXDFG=5, MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXAO=8192, MXSH=5000, MXGTOT=20000, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      PARAMETER (CONST=2.0D+00/1.7320508D+00)
      PARAMETER (SQRT3=1.732050808D+00,SQRT5=2.236067978D+00)
      PARAMETER (SQRT7=2.645751311D+00)
      PARAMETER (TWO=2.0D+00,THREE=3.0D+00,FOUR=4.0D+00,SIX=6.0D+00)
      PARAMETER (TWELVE=12.0D+00)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
C
      CHARACTER*8 MNAME,PNAME,DPNAME,PTNAM,FRGNME,POLNAM,DPOLNAM,RNAME,
     *            REPNAM,DNAME,DPSNAM,FRGMNT
      CHARACTER*6 FRGNAM
C
      DIMENSION T1(3,3), T2(3,3), T3(3,3), T3T(3,3), IPT(3)
      DIMENSION TEMP(3,MXPT), TEMP2(6), TEMP3(3), TEMP4(6,3)
      DIMENSION TEMP5(6,3)
      DIMENSION TPXX(6),TPXY(6),TPYY(6),TPXZ(6),TPYZ(6),TPZZ(6)
      DIMENSION TPXX2(6),TPXY2(6),TPYY2(6),TPXZ2(6),TPYZ2(6),TPZZ2(6)
      DIMENSION DTEMP(3,MXIFRQ*MXPT)
C
      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
     *                DOOCTU(MXFGPT)
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NAT(MXDFG),NUM(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ*MXFGPT)
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
      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
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
C
      DIMENSION TEMPHF(3,MXFGPT)
C
      SAVE JDXSV
      DATA JDXSV/0/
C
      DIMENSION PROVEC(MXBF,NTMOF),CANVEC(MXBF,NTAOF)
C
      SAVE IDXSV
      DATA IDXSV/0/
C
      IF (N.EQ.1) THEN
        IDXSV = 0
        JDXSV = 0
      ENDIF
C
      NPTS = NMPTS(N)
C
C --- FIND ROTATION MATRIX CONNECTING THE FRAGMENT N TO THE
C     STANDARD FRAGMENT.
C   1.  FIND LOCAL COORD SYSTEM FOR FRAGMENT N
C
      CALL ROTMAT(XCRD(1,N),YCRD(1,N),ZCRD(1,N),
     *            XCRD(2,N),YCRD(2,N),ZCRD(2,N),
     *            XCRD(3,N),YCRD(3,N),ZCRD(3,N),T1)
C
C   2. FIND THE CORRESPONDING THREE PTS IN THE STANDARD FRAGMENT
C
      DO 100 J=1,3
        IPT(J) = 0
        DO 50 I=1,NPTS
          IF(PTNAM(J,N).EQ.MNAME(I))IPT(J)=I
   50   CONTINUE
        IF(IPT(J).EQ.0) THEN
           IF(MASWRK) WRITE(IW,9000) PTNAM(J,N),FRGMNT
           CALL ABRT
        END IF
  100 CONTINUE
C
C   3. FIND LOCAL COORD SYSTEM FOR THESE THREE POINTS
C
      CALL ROTMAT(CORD(1,IPT(1)),CORD(2,IPT(1)),CORD(3,IPT(1)),
     *            CORD(1,IPT(2)),CORD(2,IPT(2)),CORD(3,IPT(2)),
     *            CORD(1,IPT(3)),CORD(2,IPT(3)),CORD(3,IPT(3)),T2)
C
C   4. FIND ROTATION MATRIX CONNECTING THESE TWO COORDINATE SYSTEMS
C
      CALL TRPOSE(T2,T3T,3,3,1)
      CALL MRARBR(T1,3,3,3,T2,3,3,T3,3)
C
C     WRITE(6,*) 'GRAND ROTATION MATRIX'
C     DO 300 I=1,3
C       WRITE(6,FMT='(3F9.5)') (T3(I,J), J=1,3)
C 300 CONTINUE
C     CALL PRSQ(T3,3,3,3)
C
C  COMPUTE TRANSPOSE
C
      CALL TRPOSE(T3,T3T,3,3,0)
C
C   5.  ROTATE AND TRANSLATE STANDARD FRAGMENT TO COINCIDE WITH FRAG N
C
      DO 505 I=1,NPTS
        DO 504 J=1,3
          TEMP(J,I) = CORD(J,I) - CORD(J,IPT(1))
  504   CONTINUE
  505 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,NPTS,EFC(1,NMTTPT+1),3)
C
C  FEED IN INFORMATION INTO FINAL ARRAYS AFTER ROTATION
C
C     WRITE(6,*) 'ROTATED COORDINATES'
C
      IF (FRGMNT.EQ.' $H2OSPC') THEN
        DO 549 I = 1,NPTS
          EFC(1,NMTTPT+I) = EFC(1,NMTTPT+I) + XCRD(1,N)
          EFC(2,NMTTPT+I) = EFC(2,NMTTPT+I) + YCRD(1,N)
          EFC(3,NMTTPT+I) = EFC(3,NMTTPT+I) + ZCRD(1,N)
C         WRITE(6,FMT='(3F9.5)') (EFC(J,I+NMTTPT), J=1,3)
          FRGNME(NMTTPT+I)   = MNAME(I)
          EFCHG(1,NMTTPT+I)  = ACHG(1,I)
          FMASS(NMTTPT+I)    = FPMASS(I)
  549   CONTINUE
        RETURN
      ELSE
      DO 550 I = 1,NPTS
        EFC(1,NMTTPT+I) = EFC(1,NMTTPT+I) + XCRD(1,N)
        EFC(2,NMTTPT+I) = EFC(2,NMTTPT+I) + YCRD(1,N)
        EFC(3,NMTTPT+I) = EFC(3,NMTTPT+I) + ZCRD(1,N)
C       WRITE(6,FMT='(3F9.5)') (EFC(J,I+NMTTPT), J=1,3)
        FRGNME(NMTTPT+I)   = MNAME(I)
        EFCHG(1,NMTTPT+I)  = ACHG(1,I)
        EFCHG(2,NMTTPT+I)  = ACHG(2,I)
        EFATRM(NMTTPT+I)   = AMULT(I)
        EFBTRM(NMTTPT+I)   = BMULT(I)
        EFATRM2(NMTTPT+I)  = AMULT2(I)
        EFBTRM2(NMTTPT+I)  = BMULT2(I)
        DOMONO(NMTTPT+I)   = DOMTMP(I)
        DODIPO(NMTTPT+I)   = DODTMP(I)
        DOQUAD(NMTTPT+I)   = DOQTMP(I)
        DOOCTU(NMTTPT+I)   = DOOTMP(I)
        FMASS(NMTTPT+I)    = FPMASS(I)
        FGNUC(NMTTPT+I)    = FPNUC(I)
  550 CONTINUE
C
C ROTATING DIPOLE MOMENTS
C
      CALL MRARBR(T3,3,3,3,ADIP,3,NPTS,EFDIP(1,NMTTPT+1),3)
C
C ROTATING QUADRUPOLE MOMENTS
C
C     WRITE(6,*) 'ROTATED QUADRUPOLES'
      CALL VCLR(TEMP3,1,3)
      DO 600 I=1,NPTS
        TEMP2(1)=AQAD(1,I)
        TEMP2(2)=AQAD(4,I)
        TEMP2(3)=AQAD(2,I)
        TEMP2(4)=AQAD(5,I)
        TEMP2(5)=AQAD(6,I)
        TEMP2(6)=AQAD(3,I)
        CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
        EFQAD(1,NMTTPT+I)=TEMP4(1,1)
        EFQAD(4,NMTTPT+I)=TEMP4(2,1)
        EFQAD(2,NMTTPT+I)=TEMP4(3,1)
        EFQAD(5,NMTTPT+I)=TEMP4(4,1)
        EFQAD(6,NMTTPT+I)=TEMP4(5,1)
        EFQAD(3,NMTTPT+I)=TEMP4(6,1)
C       WRITE(6,FMT='(6F9.5)') (EFQAD(J,NMTTPT+I), J=1,6)
  600 CONTINUE
C
C     ROTATE HF MONOPOLE, DIPOLE, AND QUADRUPLE
C     WHEN NP2/EFP1 IS USED.
C
      IF(IEFP2.NE.1) GO TO 649
      DO 610 I = 1,NPTS
C       FRGNME(NMTTPT+I)   = MNAME(I)
        CHGHF(1,NMTTPT+I)  = ACHGHF(1,I)
        CHGHF(2,NMTTPT+I)  = ACHGHF(2,I)
        AMULTHF(NMTTPT+I)   = AMULTMP(I)
        BMULTHF(NMTTPT+I)   = BMULTMP(I)
        AMULT2HF(NMTTPT+I)  = AMULTMP2(I)
        BMULT2HF(NMTTPT+I)  = BMULTMP2(I)
C       DOMONO(NMTTPT+I)   = DOMTMP(I)
C       DODIPO(NMTTPT+I)   = DODTMP(I)
C       DOQUAD(NMTTPT+I)   = DOQTMP(I)
C       DOOCTU(NMTTPT+I)   = DOOTMP(I)
C       FMASS(I,N)         = FPMASS(I)
C       FGNUC(NMTTPT+I)    = FPNUC(I)
C       WRITE(IW,620)I
C       WRITE(IW,621)CHGHF(1,I),CHGHF(2,I)
C       WRITE(IW,624)EFCHG(1,I),EFCHG(2,I)
C       WRITE(IW,622)AMULTHF(I),BMULTHF(I)
C       WRITE(IW,623)AMULT2HF(I),BMULT2HF(I)
  610 CONTINUE
C
C  620 FORMAT('HF RESULTS WHEN MP2 IS REQUIRED,I= ',I4)
C  621 FORMAT('CHGHF(1,I),CHGHF(2,I),',2F10.6)
C 622 FORMAT('AMULTHF(I),BMULTHF(I),',2F10.6)
C 623 FORMAT('AMULT2HF(I),BMULT2HF(I),',2F10.6)
C  624 FORMAT('EFCHG(1,I),EFCHG(2,I),',2F10.6)
C ROTATING DIPOLE MOMENTS
C
C     CALL MRARBR(T3,3,3,3,ADIP,3,NPTS,EFDIP(1,NMTTPT+1),3)
C
      CALL MRARBR(T3,3,3,3,ADIPHF,3,NPTS,TEMPHF(1,NMTTPT+1),3)
C
      DO 625 I=1,NPTS
C       WRITE(IW,626)EFDIP(1,NMTTPT+I),TEMPHF(1,NMTTPT+I)
C       WRITE(IW,626)EFDIP(2,NMTTPT+I),TEMPHF(2,NMTTPT+I)
C       WRITE(IW,626)EFDIP(3,NMTTPT+I),TEMPHF(3,NMTTPT+I)
        DIPHF(1,NMTTPT+I)=TEMPHF(1,NMTTPT+I)
        DIPHF(2,NMTTPT+I)=TEMPHF(2,NMTTPT+I)
        DIPHF(3,NMTTPT+I)=TEMPHF(3,NMTTPT+I)
  625 CONTINUE
C 626 FORMAT('EFDIP,DIPHF= ',2F10.6)
C
C ROTATING QUADRUPOLE MOMENTS
C
C     WRITE(6,*) 'ROTATED QUADRUPOLES'
      CALL VCLR(TEMP3,1,3)
      DO 630 I=1,NPTS
        TEMP2(1)=AQADHF(1,I)
        TEMP2(2)=AQADHF(4,I)
        TEMP2(3)=AQADHF(2,I)
        TEMP2(4)=AQADHF(5,I)
        TEMP2(5)=AQADHF(6,I)
        TEMP2(6)=AQADHF(3,I)
        CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
        QADHF(1,NMTTPT+I)=TEMP4(1,1)
        QADHF(4,NMTTPT+I)=TEMP4(2,1)
        QADHF(2,NMTTPT+I)=TEMP4(3,1)
        QADHF(5,NMTTPT+I)=TEMP4(4,1)
        QADHF(6,NMTTPT+I)=TEMP4(5,1)
        QADHF(3,NMTTPT+I)=TEMP4(6,1)
C
  630 CONTINUE
C
C     DO 635 I=1,NPTS
C       WRITE(IW,636)EFQAD(1,NMTTPT+I),QADHF(1,NMTTPT+I)
C       WRITE(IW,636)EFQAD(2,NMTTPT+I),QADHF(2,NMTTPT+I)
C       WRITE(IW,636)EFQAD(3,NMTTPT+I),QADHF(3,NMTTPT+I)
C       WRITE(IW,636)EFQAD(4,NMTTPT+I),QADHF(4,NMTTPT+I)
C       WRITE(IW,636)EFQAD(5,NMTTPT+I),QADHF(5,NMTTPT+I)
C       WRITE(IW,636)EFQAD(6,NMTTPT+I),QADHF(6,NMTTPT+I)
C 635 CONTINUE
C 636 FORMAT('EFQAD,QADHF = ',2F10.6)
C
  649 CONTINUE
C
C ROTATING OCTUPOLE MOMENTS
C
C     WRITE(6,*) 'ROTATED OCTUPOLES'
      DO 650 I=1,NPTS
        TEMP2(1) = AOCT(1,I)
        TEMP2(2) = AOCT(4,I)
        TEMP2(3) = AOCT(6,I)
        TEMP2(4) = AOCT(5,I)
        TEMP2(5) = AOCT(10,I)
        TEMP2(6) = AOCT(8,I)
        CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
        TEMP2(1)=AOCT(4,I)
        TEMP2(2)=AOCT(6,I)
        TEMP2(3)=AOCT(2,I)
        TEMP2(4)=AOCT(10,I)
        TEMP2(5)=AOCT(7,I)
        TEMP2(6)=AOCT(9,I)
        CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
        TEMP2(1)=AOCT(5,I)
        TEMP2(2)=AOCT(10,I)
        TEMP2(3)=AOCT(7,I)
        TEMP2(4)=AOCT(8,I)
        TEMP2(5)=AOCT(9,I)
        TEMP2(6)=AOCT(3,I)
        CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
        CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
        EFOCT(1,NMTTPT+I)=TEMP5(1,1)
        EFOCT(2,NMTTPT+I)=TEMP5(3,2)
        EFOCT(3,NMTTPT+I)=TEMP5(6,3)
        EFOCT(4,NMTTPT+I)=TEMP5(2,1)
        EFOCT(5,NMTTPT+I)=TEMP5(4,1)
        EFOCT(6,NMTTPT+I)=TEMP5(3,1)
        EFOCT(7,NMTTPT+I)=TEMP5(5,2)
        EFOCT(8,NMTTPT+I)=TEMP5(6,1)
        EFOCT(9,NMTTPT+I)=TEMP5(6,2)
        EFOCT(10,NMTTPT+I)=TEMP5(5,1)
C       WRITE(6,FMT='(10F9.5)') (EFOCT(J,NMTTPT+I), J=1,10)
  650 CONTINUE
C
C  ROTATING POLARIZABILITY-COORDINATES AND TENSOR
C
      IPPTS=NPPTS(N)
      DO 670 I=1,IPPTS
         DO 660 J=1,3
            TEMP(J,I) = PCORD(J,I) - CORD(J,IPT(1))
  660    CONTINUE
  670 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,IPPTS,EFP(1,NPTTPT+1),3)
C
      DO 680 I = 1,IPPTS
         EFP(1,I+NPTTPT) = EFP(1,I+NPTTPT) + XCRD(1,N)
         EFP(2,I+NPTTPT) = EFP(2,I+NPTTPT) + YCRD(1,N)
         EFP(3,I+NPTTPT) = EFP(3,I+NPTTPT) + ZCRD(1,N)
         POLNAM(I+NPTTPT) = PNAME(I)
  680 CONTINUE
C
      DO 690 I=1,IPPTS
        T1(1,1) = POLT(1,I)
        T1(1,2) = POLT(4,I)
        T1(1,3) = POLT(5,I)
        T1(2,1) = POLT(7,I)
        T1(2,2) = POLT(2,I)
        T1(2,3) = POLT(6,I)
        T1(3,1) = POLT(8,I)
        T1(3,2) = POLT(9,I)
        T1(3,3) = POLT(3,I)
        CALL MRARBR(T3,3,3,3,T1,3,3,T2,3)
        CALL MRARBR(T2,3,3,3,T3T,3,3,T1,3)
C
C       FOR MP2 POLARIZATION, THE LAST IS THE 2ND ORDER POLARIZABILITY
C       NOTE THAT THIS ONLY ALLOWS FOR ONE SUCH TENSOR TO BE USED.
C
        IF ((IEFP2.EQ.1).AND.(I.EQ.IPPTS)) THEN
          EFPOL2(1,N) = T1(1,1)
          EFPOL2(4,N) = T1(1,2)
          EFPOL2(5,N) = T1(1,3)
          EFPOL2(7,N) = T1(2,1)
          EFPOL2(2,N) = T1(2,2)
          EFPOL2(6,N) = T1(2,3)
          EFPOL2(8,N) = T1(3,1)
          EFPOL2(9,N) = T1(3,2)
          EFPOL2(3,N) = T1(3,3)
        ELSE
          EFPOL(1,NPTTPT+I) = T1(1,1)
          EFPOL(4,NPTTPT+I) = T1(1,2)
          EFPOL(5,NPTTPT+I) = T1(1,3)
          EFPOL(7,NPTTPT+I) = T1(2,1)
          EFPOL(2,NPTTPT+I) = T1(2,2)
          EFPOL(6,NPTTPT+I) = T1(2,3)
          EFPOL(8,NPTTPT+I) = T1(3,1)
          EFPOL(9,NPTTPT+I) = T1(3,2)
          EFPOL(3,NPTTPT+I) = T1(3,3)
        END IF
  690 CONTINUE
C
C         ROTATION OF REPULSIVE POTENTIAL
C
      IRPTS = NRPTS(N)
      DO 720 I=1,IRPTS
        DO 710 J=1,3
          TEMP(J,I) = RCORD(J,I) - CORD(J,IPT(1))
  710   CONTINUE
  720 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,IRPTS,CREP(1,NRTTPT+1),3)
C
      DO 740 I = 1,IRPTS
        CREP(1,I+NRTTPT) = CREP(1,I+NRTTPT) + XCRD(1,N)
        CREP(2,I+NRTTPT) = CREP(2,I+NRTTPT) + YCRD(1,N)
        CREP(3,I+NRTTPT) = CREP(3,I+NRTTPT) + ZCRD(1,N)
        REPNAM(I+NRTTPT) = RNAME(I)
        KFR(I+NRTTPT) = IKFR(I)+IDXSV
        KLR(I+NRTTPT) = IKLR(I)+IDXSV
        IFF = IKFR(I)
        ISS = IKLR(I)
        DO 730 II=IFF,ISS
          CLPR(II+IDXSV) = TCLPR(II)
          NLPR(II+IDXSV) = INLPR(II)
          ZLPR(II+IDXSV) = TZLPR(II)
  730   CONTINUE
  740 CONTINUE
C
      IDXSV=KLR(IRPTS+NRTTPT)
C
C     --- FOR DISPERSION ---
C
      IDPTS = NDPTS(N)
      DO 820 I=1,IDPTS
        DO 810 J=1,3
          TEMP(J,I) = DCORD(J,I) - CORD(J,IPT(1))
  810   CONTINUE
  820 CONTINUE
C
      CALL MRARBR(T3,3,3,3,TEMP,3,IDPTS,CDIS(1,NDTTPT+1),3)
C
      DO 840 I = 1,IRPTS
        CDIS(1,I+NDTTPT) = CDIS(1,I+NDTTPT) + XCRD(1,N)
        CDIS(2,I+NDTTPT) = CDIS(2,I+NDTTPT) + YCRD(1,N)
        CDIS(3,I+NDTTPT) = CDIS(3,I+NDTTPT) + ZCRD(1,N)
        DPSNAM(I+NDTTPT) = DNAME(I)
        KFD(I+NRTTPT) = JKFR(I)+JDXSV
        KLD(I+NRTTPT) = JKLR(I)+JDXSV
        IFF = JKFR(I)
        ISS = JKLR(I)
        DO 830 II=IFF,ISS
          CLPD(II+JDXSV) = TCLPD(II)
          NLPD(II+JDXSV) = JNLPR(II)
          ZLPD(II+JDXSV) = TZLPD(II)
  830   CONTINUE
  840 CONTINUE
C
      JDXSV=KLD(IDPTS+NDTTPT)
C
C  PAULI REPULSION INFORMATION
C
      INAT = NAT(ISET(N))
      IF(INAT.EQ.0) RETURN
      DO I=1,INAT
         DO J=1,3
            TEMP(J,I) = PRCORD(J,I+NTPATM) - CORD(J,IPT(1))
         END DO
      END DO
      CALL MRARBR(T3,3,3,3,TEMP,3,INAT,PRCORD(1,NTPATM+1),3)
      DO I=1,INAT
         PRCORD(1,I+NTPATM) = PRCORD(1,I+NTPATM) + XCRD(1,N)
         PRCORD(2,I+NTPATM) = PRCORD(2,I+NTPATM) + YCRD(1,N)
         PRCORD(3,I+NTPATM) = PRCORD(3,I+NTPATM) + ZCRD(1,N)
      END DO
C
      IMO = NORB(N)
      DO NSHL = 1,NSHELL(ISET(N))
         ITYP = KMAX(NSHL,ISET(N)) - KMIN(NSHL,ISET(N)) + 1
         LOC = KLOC(NSHL,ISET(N))
C
C  S: DO NOTHING
C
C  P:
C
         IF(ITYP.EQ.3) THEN
            DO I = 1,IMO
               TEMP3(1) = PROVEC(LOC,NTMO+I)
               TEMP3(2) = PROVEC(LOC+1,NTMO+I)
               TEMP3(3) = PROVEC(LOC+2,NTMO+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               PROVEC(LOC,NTMO+I) = TEMP4(1,1)
               PROVEC(LOC+1,NTMO+I) = TEMP4(2,1)
               PROVEC(LOC+2,NTMO+I) = TEMP4(3,1)
            END DO
         END IF
C  L:
         IF(ITYP.EQ.4) THEN
            DO I = 1,IMO
               TEMP3(1) = PROVEC(LOC+1,NTMO+I)
               TEMP3(2) = PROVEC(LOC+2,NTMO+I)
               TEMP3(3) = PROVEC(LOC+3,NTMO+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               PROVEC(LOC+1,NTMO+I) = TEMP4(1,1)
               PROVEC(LOC+2,NTMO+I) = TEMP4(2,1)
               PROVEC(LOC+3,NTMO+I) = TEMP4(3,1)
            END DO
         END IF
C  D:
C              THE NORMALIZATION FOR XY,XZ,YZ GAUSSIANS IS SQRT(3)
C              LARGER THAN XX,YY,ZZ. FACTOR OF TWO ALLOWS SUMMATION
C              OVER ALL INDICES RATHER THAN I,J<=I
C
         IF(ITYP.EQ.6) THEN
            DO I = 1,IMO
               TEMP2(1) = PROVEC(LOC,NTMO+I)
               TEMP2(2) = PROVEC(LOC+3,NTMO+I)/CONST
               TEMP2(3) = PROVEC(LOC+1,NTMO+I)
               TEMP2(4) = PROVEC(LOC+4,NTMO+I)/CONST
               TEMP2(5) = PROVEC(LOC+5,NTMO+I)/CONST
               TEMP2(6) = PROVEC(LOC+2,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               PROVEC(LOC,NTMO+I) = TEMP4(1,1)
               PROVEC(LOC+3,NTMO+I) = TEMP4(2,1)*CONST
               PROVEC(LOC+1,NTMO+I) = TEMP4(3,1)
               PROVEC(LOC+4,NTMO+I) = TEMP4(4,1)*CONST
               PROVEC(LOC+5,NTMO+I) = TEMP4(5,1)*CONST
               PROVEC(LOC+2,NTMO+I) = TEMP4(6,1)
            END DO
         END IF
C  F:
         IF(ITYP.EQ.10) THEN
            DO I = 1,IMO
               PROVEC(LOC+3,NTMO+I) = PROVEC(LOC+3,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+4,NTMO+I) = PROVEC(LOC+4,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+5,NTMO+I) = PROVEC(LOC+5,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+6,NTMO+I) = PROVEC(LOC+6,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+7,NTMO+I) = PROVEC(LOC+7,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+8,NTMO+I) = PROVEC(LOC+8,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+9,NTMO+I) = PROVEC(LOC+9,NTMO+I)*SQRT5/THREE
               PROVEC(LOC+9,NTMO+I) = PROVEC(LOC+9,NTMO+I)*SQRT3/TWO
C
               TEMP2(1) = PROVEC(LOC  ,NTMO+I)
               TEMP2(2) = PROVEC(LOC+3,NTMO+I)
               TEMP2(3) = PROVEC(LOC+5,NTMO+I)
               TEMP2(4) = PROVEC(LOC+4,NTMO+I)
               TEMP2(5) = PROVEC(LOC+9,NTMO+I)
               TEMP2(6) = PROVEC(LOC+7,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = PROVEC(LOC+3,NTMO+I)
               TEMP2(2) = PROVEC(LOC+5,NTMO+I)
               TEMP2(3) = PROVEC(LOC+1,NTMO+I)
               TEMP2(4) = PROVEC(LOC+9,NTMO+I)
               TEMP2(5) = PROVEC(LOC+6,NTMO+I)
               TEMP2(6) = PROVEC(LOC+8,NTMO+I)
               CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = PROVEC(LOC+4,NTMO+I)
               TEMP2(2) = PROVEC(LOC+9,NTMO+I)
               TEMP2(3) = PROVEC(LOC+6,NTMO+I)
               TEMP2(4) = PROVEC(LOC+7,NTMO+I)
               TEMP2(5) = PROVEC(LOC+8,NTMO+I)
               TEMP2(6) = PROVEC(LOC+2,NTMO+I)
               CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
               CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
C
               PROVEC(LOC  ,NTMO+I) = TEMP5(1,1)
               PROVEC(LOC+1,NTMO+I) = TEMP5(3,2)
               PROVEC(LOC+2,NTMO+I) = TEMP5(6,3)
               PROVEC(LOC+3,NTMO+I) = TEMP5(2,1)/SQRT5*THREE
               PROVEC(LOC+4,NTMO+I) = TEMP5(4,1)/SQRT5*THREE
               PROVEC(LOC+5,NTMO+I) = TEMP5(3,1)/SQRT5*THREE
               PROVEC(LOC+6,NTMO+I) = TEMP5(5,2)/SQRT5*THREE
               PROVEC(LOC+7,NTMO+I) = TEMP5(6,1)/SQRT5*THREE
               PROVEC(LOC+8,NTMO+I) = TEMP5(6,2)/SQRT5*THREE
               PROVEC(LOC+9,NTMO+I) = TEMP5(5,1)/SQRT5*THREE/SQRT3*TWO
C
            END DO
         END IF
C
C  G:
C
         IF(ITYP.EQ.15) THEN
            DO I = 1,IMO
               PROVEC(LOC+ 3,NTMO+I) = PROVEC(LOC+ 3,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 4,NTMO+I) = PROVEC(LOC+ 4,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 5,NTMO+I) = PROVEC(LOC+ 5,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 6,NTMO+I) = PROVEC(LOC+ 6,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 7,NTMO+I) = PROVEC(LOC+ 7,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 8,NTMO+I) = PROVEC(LOC+ 8,NTMO+I)*SQRT7/FOUR
               PROVEC(LOC+ 9,NTMO+I) = PROVEC(LOC+ 9,NTMO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               PROVEC(LOC+10,NTMO+I) = PROVEC(LOC+10,NTMO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               PROVEC(LOC+11,NTMO+I) = PROVEC(LOC+11,NTMO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               PROVEC(LOC+12,NTMO+I) = PROVEC(LOC+12,NTMO+I)*SQRT7*
     *                                 SQRT5/TWELVE
               PROVEC(LOC+13,NTMO+I) = PROVEC(LOC+13,NTMO+I)*SQRT7*
     *                                 SQRT5/TWELVE
               PROVEC(LOC+14,NTMO+I) = PROVEC(LOC+14,NTMO+I)*SQRT7*
     *                                 SQRT5/TWELVE
C
C              PERFORM THE FIRST AND SECOND ROTATION
C
               TEMP2(1) = PROVEC(LOC   ,NTMO+I)
               TEMP2(2) = PROVEC(LOC+ 3,NTMO+I)
               TEMP2(3) = PROVEC(LOC+ 9,NTMO+I)
               TEMP2(4) = PROVEC(LOC+ 4,NTMO+I)
               TEMP2(5) = PROVEC(LOC+12,NTMO+I)
               TEMP2(6) = PROVEC(LOC+10,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX(1) = TEMP4(1,1)
               TPXX(2) = TEMP4(2,1)
               TPXX(3) = TEMP4(3,1)
               TPXX(4) = TEMP4(4,1)
               TPXX(5) = TEMP4(5,1)
               TPXX(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 3,NTMO+I)
               TEMP2(2) = PROVEC(LOC+ 9,NTMO+I)
               TEMP2(3) = PROVEC(LOC+ 5,NTMO+I)
               TEMP2(4) = PROVEC(LOC+12,NTMO+I)
               TEMP2(5) = PROVEC(LOC+13,NTMO+I)
               TEMP2(6) = PROVEC(LOC+14,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY(1) = TEMP4(1,1)
               TPXY(2) = TEMP4(2,1)
               TPXY(3) = TEMP4(3,1)
               TPXY(4) = TEMP4(4,1)
               TPXY(5) = TEMP4(5,1)
               TPXY(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 9,NTMO+I)
               TEMP2(2) = PROVEC(LOC+ 5,NTMO+I)
               TEMP2(3) = PROVEC(LOC+ 1,NTMO+I)
               TEMP2(4) = PROVEC(LOC+13,NTMO+I)
               TEMP2(5) = PROVEC(LOC+ 6,NTMO+I)
               TEMP2(6) = PROVEC(LOC+11,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY(1) = TEMP4(1,1)
               TPYY(2) = TEMP4(2,1)
               TPYY(3) = TEMP4(3,1)
               TPYY(4) = TEMP4(4,1)
               TPYY(5) = TEMP4(5,1)
               TPYY(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+ 4,NTMO+I)
               TEMP2(2) = PROVEC(LOC+12,NTMO+I)
               TEMP2(3) = PROVEC(LOC+13,NTMO+I)
               TEMP2(4) = PROVEC(LOC+10,NTMO+I)
               TEMP2(5) = PROVEC(LOC+14,NTMO+I)
               TEMP2(6) = PROVEC(LOC+ 7,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ(1) = TEMP4(1,1)
               TPXZ(2) = TEMP4(2,1)
               TPXZ(3) = TEMP4(3,1)
               TPXZ(4) = TEMP4(4,1)
               TPXZ(5) = TEMP4(5,1)
               TPXZ(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+12,NTMO+I)
               TEMP2(2) = PROVEC(LOC+13,NTMO+I)
               TEMP2(3) = PROVEC(LOC+ 6,NTMO+I)
               TEMP2(4) = PROVEC(LOC+14,NTMO+I)
               TEMP2(5) = PROVEC(LOC+11,NTMO+I)
               TEMP2(6) = PROVEC(LOC+ 8,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ(1) = TEMP4(1,1)
               TPYZ(2) = TEMP4(2,1)
               TPYZ(3) = TEMP4(3,1)
               TPYZ(4) = TEMP4(4,1)
               TPYZ(5) = TEMP4(5,1)
               TPYZ(6) = TEMP4(6,1)
C
               TEMP2(1) = PROVEC(LOC+10,NTMO+I)
               TEMP2(2) = PROVEC(LOC+14,NTMO+I)
               TEMP2(3) = PROVEC(LOC+11,NTMO+I)
               TEMP2(4) = PROVEC(LOC+ 7,NTMO+I)
               TEMP2(5) = PROVEC(LOC+ 8,NTMO+I)
               TEMP2(6) = PROVEC(LOC+ 2,NTMO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ(1) = TEMP4(1,1)
               TPZZ(2) = TEMP4(2,1)
               TPZZ(3) = TEMP4(3,1)
               TPZZ(4) = TEMP4(4,1)
               TPZZ(5) = TEMP4(5,1)
               TPZZ(6) = TEMP4(6,1)
C
C              PERFORM THE THIRD AND FOURTH ROTATION
C
               TEMP2(1) = TPXX(1)
               TEMP2(2) = TPXY(1)
               TEMP2(3) = TPYY(1)
               TEMP2(4) = TPXZ(1)
               TEMP2(5) = TPYZ(1)
               TEMP2(6) = TPZZ(1)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX2(1) = TEMP4(1,1)
               TPXX2(2) = TEMP4(2,1)
               TPXX2(3) = TEMP4(3,1)
               TPXX2(4) = TEMP4(4,1)
               TPXX2(5) = TEMP4(5,1)
               TPXX2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(2)
               TEMP2(2) = TPXY(2)
               TEMP2(3) = TPYY(2)
               TEMP2(4) = TPXZ(2)
               TEMP2(5) = TPYZ(2)
               TEMP2(6) = TPZZ(2)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY2(1) = TEMP4(1,1)
               TPXY2(2) = TEMP4(2,1)
               TPXY2(3) = TEMP4(3,1)
               TPXY2(4) = TEMP4(4,1)
               TPXY2(5) = TEMP4(5,1)
               TPXY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(3)
               TEMP2(2) = TPXY(3)
               TEMP2(3) = TPYY(3)
               TEMP2(4) = TPXZ(3)
               TEMP2(5) = TPYZ(3)
               TEMP2(6) = TPZZ(3)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY2(1) = TEMP4(1,1)
               TPYY2(2) = TEMP4(2,1)
               TPYY2(3) = TEMP4(3,1)
               TPYY2(4) = TEMP4(4,1)
               TPYY2(5) = TEMP4(5,1)
               TPYY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(4)
               TEMP2(2) = TPXY(4)
               TEMP2(3) = TPYY(4)
               TEMP2(4) = TPXZ(4)
               TEMP2(5) = TPYZ(4)
               TEMP2(6) = TPZZ(4)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ2(1) = TEMP4(1,1)
               TPXZ2(2) = TEMP4(2,1)
               TPXZ2(3) = TEMP4(3,1)
               TPXZ2(4) = TEMP4(4,1)
               TPXZ2(5) = TEMP4(5,1)
               TPXZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(5)
               TEMP2(2) = TPXY(5)
               TEMP2(3) = TPYY(5)
               TEMP2(4) = TPXZ(5)
               TEMP2(5) = TPYZ(5)
               TEMP2(6) = TPZZ(5)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ2(1) = TEMP4(1,1)
               TPYZ2(2) = TEMP4(2,1)
               TPYZ2(3) = TEMP4(3,1)
               TPYZ2(4) = TEMP4(4,1)
               TPYZ2(5) = TEMP4(5,1)
               TPYZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(6)
               TEMP2(2) = TPXY(6)
               TEMP2(3) = TPYY(6)
               TEMP2(4) = TPXZ(6)
               TEMP2(5) = TPYZ(6)
               TEMP2(6) = TPZZ(6)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ2(1) = TEMP4(1,1)
               TPZZ2(2) = TEMP4(2,1)
               TPZZ2(3) = TEMP4(3,1)
               TPZZ2(4) = TEMP4(4,1)
               TPZZ2(5) = TEMP4(5,1)
               TPZZ2(6) = TEMP4(6,1)
C
               PROVEC(LOC   ,NTMO+I) = TPXX2(1)
               PROVEC(LOC+ 1,NTMO+I) = TPYY2(3)
               PROVEC(LOC+ 2,NTMO+I) = TPZZ2(6)
               PROVEC(LOC+ 3,NTMO+I) = TPXY2(1)/SQRT7*FOUR
               PROVEC(LOC+ 4,NTMO+I) = TPXZ2(1)/SQRT7*FOUR
               PROVEC(LOC+ 5,NTMO+I) = TPYY2(2)/SQRT7*FOUR
               PROVEC(LOC+ 6,NTMO+I) = TPYZ2(3)/SQRT7*FOUR
               PROVEC(LOC+ 7,NTMO+I) = TPXZ2(6)/SQRT7*FOUR
               PROVEC(LOC+ 8,NTMO+I) = TPYZ2(6)/SQRT7*FOUR
               PROVEC(LOC+ 9,NTMO+I) = TPYY2(1)/SQRT7/SQRT5*SQRT3*SIX
               PROVEC(LOC+10,NTMO+I) = TPZZ2(1)/SQRT7/SQRT5*SQRT3*SIX
               PROVEC(LOC+11,NTMO+I) = TPZZ2(3)/SQRT7/SQRT5*SQRT3*SIX
               PROVEC(LOC+12,NTMO+I) = TPYZ2(1)/SQRT7/SQRT5*TWELVE
               PROVEC(LOC+13,NTMO+I) = TPYZ2(2)/SQRT7/SQRT5*TWELVE
               PROVEC(LOC+14,NTMO+I) = TPZZ2(2)/SQRT7/SQRT5*TWELVE
            END DO
         END IF
      END DO
C
      DO I=1,IMO
         DO J=1,3
            TEMP(J,I) = CENTCD(J,I+NTMO) - CORD(J,IPT(1))
         END DO
      END DO
      CALL MRARBR(T3,3,3,3,TEMP,3,IMO,CENTCD(1,NTMO+1),3)
      DO I=1,IMO
         CENTCD(1,I+NTMO) = CENTCD(1,I+NTMO) + XCRD(1,N)
         CENTCD(2,I+NTMO) = CENTCD(2,I+NTMO) + YCRD(1,N)
         CENTCD(3,I+NTMO) = CENTCD(3,I+NTMO) + ZCRD(1,N)
      END DO
C
C
C  ROTATE CANONICAL VEC
C
      IAO = NPBF(N)
      DO NSHL = 1,NSHELL(ISET(N))
         ITYP = KMAX(NSHL,ISET(N)) - KMIN(NSHL,ISET(N)) + 1
         LOC = KLOC(NSHL,ISET(N))
C
C  S: DO NOTHING
C
C  P:
C
         IF(ITYP.EQ.3) THEN
            DO I = 1,IAO
               TEMP3(1) = CANVEC(LOC,NTAO+I)
               TEMP3(2) = CANVEC(LOC+1,NTAO+I)
               TEMP3(3) = CANVEC(LOC+2,NTAO+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               CANVEC(LOC,NTAO+I) = TEMP4(1,1)
               CANVEC(LOC+1,NTAO+I) = TEMP4(2,1)
               CANVEC(LOC+2,NTAO+I) = TEMP4(3,1)
            END DO
         END IF
C  L:
         IF(ITYP.EQ.4) THEN
            DO I = 1,IAO
               TEMP3(1) = CANVEC(LOC+1,NTAO+I)
               TEMP3(2) = CANVEC(LOC+2,NTAO+I)
               TEMP3(3) = CANVEC(LOC+3,NTAO+I)
               CALL MRARBR(T3,3,3,3,TEMP3,3,1,TEMP4(1,1),3)
               CANVEC(LOC+1,NTAO+I) = TEMP4(1,1)
               CANVEC(LOC+2,NTAO+I) = TEMP4(2,1)
               CANVEC(LOC+3,NTAO+I) = TEMP4(3,1)
            END DO
         END IF
C  D:
C              THE NORMALIZATION FOR XY,XZ,YZ GAUSSIANS IS SQRT(3)
C              LARGER THAN XX,YY,ZZ. FACTOR OF TWO ALLOWS SUMMATION
C              OVER ALL INDICES RATHER THAN I,J<=I
C
         IF(ITYP.EQ.6) THEN
            DO I = 1,IAO
               TEMP2(1) = CANVEC(LOC,NTAO+I)
               TEMP2(2) = CANVEC(LOC+3,NTAO+I)/CONST
               TEMP2(3) = CANVEC(LOC+1,NTAO+I)
               TEMP2(4) = CANVEC(LOC+4,NTAO+I)/CONST
               TEMP2(5) = CANVEC(LOC+5,NTAO+I)/CONST
               TEMP2(6) = CANVEC(LOC+2,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               CANVEC(LOC,NTAO+I) = TEMP4(1,1)
               CANVEC(LOC+3,NTAO+I) = TEMP4(2,1)*CONST
               CANVEC(LOC+1,NTAO+I) = TEMP4(3,1)
               CANVEC(LOC+4,NTAO+I) = TEMP4(4,1)*CONST
               CANVEC(LOC+5,NTAO+I) = TEMP4(5,1)*CONST
               CANVEC(LOC+2,NTAO+I) = TEMP4(6,1)
            END DO
         END IF
C
C  F:
C
         IF(ITYP.EQ.10) THEN
            DO I = 1,IAO
               CANVEC(LOC+3,NTAO+I) = CANVEC(LOC+3,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+4,NTAO+I) = CANVEC(LOC+4,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+5,NTAO+I) = CANVEC(LOC+5,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+6,NTAO+I) = CANVEC(LOC+6,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+7,NTAO+I) = CANVEC(LOC+7,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+8,NTAO+I) = CANVEC(LOC+8,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+9,NTAO+I) = CANVEC(LOC+9,NTAO+I)*SQRT5/THREE
               CANVEC(LOC+9,NTAO+I) = CANVEC(LOC+9,NTAO+I)*SQRT3/TWO
C
               TEMP2(1) = CANVEC(LOC  ,NTAO+I)
               TEMP2(2) = CANVEC(LOC+3,NTAO+I)
               TEMP2(3) = CANVEC(LOC+5,NTAO+I)
               TEMP2(4) = CANVEC(LOC+4,NTAO+I)
               TEMP2(5) = CANVEC(LOC+9,NTAO+I)
               TEMP2(6) = CANVEC(LOC+7,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = CANVEC(LOC+3,NTAO+I)
               TEMP2(2) = CANVEC(LOC+5,NTAO+I)
               TEMP2(3) = CANVEC(LOC+1,NTAO+I)
               TEMP2(4) = CANVEC(LOC+9,NTAO+I)
               TEMP2(5) = CANVEC(LOC+6,NTAO+I)
               TEMP2(6) = CANVEC(LOC+8,NTAO+I)
               CALL TFTRI(TEMP4(1,2),TEMP2,T3T,TEMP3,3,3,3)
C
               TEMP2(1) = CANVEC(LOC+4,NTAO+I)
               TEMP2(2) = CANVEC(LOC+9,NTAO+I)
               TEMP2(3) = CANVEC(LOC+6,NTAO+I)
               TEMP2(4) = CANVEC(LOC+7,NTAO+I)
               TEMP2(5) = CANVEC(LOC+8,NTAO+I)
               TEMP2(6) = CANVEC(LOC+2,NTAO+I)
               CALL TFTRI(TEMP4(1,3),TEMP2,T3T,TEMP3,3,3,3)
C
               CALL MRARBR(TEMP4,6,6,3,T3T,3,3,TEMP5,6)
C
               CANVEC(LOC  ,NTAO+I) = TEMP5(1,1)
               CANVEC(LOC+1,NTAO+I) = TEMP5(3,2)
               CANVEC(LOC+2,NTAO+I) = TEMP5(6,3)
               CANVEC(LOC+3,NTAO+I) = TEMP5(2,1)/SQRT5*THREE
               CANVEC(LOC+4,NTAO+I) = TEMP5(4,1)/SQRT5*THREE
               CANVEC(LOC+5,NTAO+I) = TEMP5(3,1)/SQRT5*THREE
               CANVEC(LOC+6,NTAO+I) = TEMP5(5,2)/SQRT5*THREE
               CANVEC(LOC+7,NTAO+I) = TEMP5(6,1)/SQRT5*THREE
               CANVEC(LOC+8,NTAO+I) = TEMP5(6,2)/SQRT5*THREE
               CANVEC(LOC+9,NTAO+I) = TEMP5(5,1)/SQRT5*THREE/SQRT3*TWO
            END DO
         END IF
C
C  G:
C
         IF(ITYP.EQ.15) THEN
            DO I = 1,IAO
               CANVEC(LOC+ 3,NTAO+I) = CANVEC(LOC+ 3,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 4,NTAO+I) = CANVEC(LOC+ 4,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 5,NTAO+I) = CANVEC(LOC+ 5,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 6,NTAO+I) = CANVEC(LOC+ 6,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 7,NTAO+I) = CANVEC(LOC+ 7,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 8,NTAO+I) = CANVEC(LOC+ 8,NTAO+I)*SQRT7/FOUR
               CANVEC(LOC+ 9,NTAO+I) = CANVEC(LOC+ 9,NTAO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               CANVEC(LOC+10,NTAO+I) = CANVEC(LOC+10,NTAO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               CANVEC(LOC+11,NTAO+I) = CANVEC(LOC+11,NTAO+I)*SQRT7*
     *                                 SQRT5/SQRT3/SIX
               CANVEC(LOC+12,NTAO+I) = CANVEC(LOC+12,NTAO+I)*SQRT7*
     *                                 SQRT5/TWELVE
               CANVEC(LOC+13,NTAO+I) = CANVEC(LOC+13,NTAO+I)*SQRT7*
     *                                 SQRT5/TWELVE
               CANVEC(LOC+14,NTAO+I) = CANVEC(LOC+14,NTAO+I)*SQRT7*
     *                                 SQRT5/TWELVE
C
C              PERFORM THE FIRST AND SECOND ROTATION
C
               TEMP2(1) = CANVEC(LOC   ,NTAO+I)
               TEMP2(2) = CANVEC(LOC+ 3,NTAO+I)
               TEMP2(3) = CANVEC(LOC+ 9,NTAO+I)
               TEMP2(4) = CANVEC(LOC+ 4,NTAO+I)
               TEMP2(5) = CANVEC(LOC+12,NTAO+I)
               TEMP2(6) = CANVEC(LOC+10,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX(1) = TEMP4(1,1)
               TPXX(2) = TEMP4(2,1)
               TPXX(3) = TEMP4(3,1)
               TPXX(4) = TEMP4(4,1)
               TPXX(5) = TEMP4(5,1)
               TPXX(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 3,NTAO+I)
               TEMP2(2) = CANVEC(LOC+ 9,NTAO+I)
               TEMP2(3) = CANVEC(LOC+ 5,NTAO+I)
               TEMP2(4) = CANVEC(LOC+12,NTAO+I)
               TEMP2(5) = CANVEC(LOC+13,NTAO+I)
               TEMP2(6) = CANVEC(LOC+14,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY(1) = TEMP4(1,1)
               TPXY(2) = TEMP4(2,1)
               TPXY(3) = TEMP4(3,1)
               TPXY(4) = TEMP4(4,1)
               TPXY(5) = TEMP4(5,1)
               TPXY(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 9,NTAO+I)
               TEMP2(2) = CANVEC(LOC+ 5,NTAO+I)
               TEMP2(3) = CANVEC(LOC+ 1,NTAO+I)
               TEMP2(4) = CANVEC(LOC+13,NTAO+I)
               TEMP2(5) = CANVEC(LOC+ 6,NTAO+I)
               TEMP2(6) = CANVEC(LOC+11,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY(1) = TEMP4(1,1)
               TPYY(2) = TEMP4(2,1)
               TPYY(3) = TEMP4(3,1)
               TPYY(4) = TEMP4(4,1)
               TPYY(5) = TEMP4(5,1)
               TPYY(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+ 4,NTAO+I)
               TEMP2(2) = CANVEC(LOC+12,NTAO+I)
               TEMP2(3) = CANVEC(LOC+13,NTAO+I)
               TEMP2(4) = CANVEC(LOC+10,NTAO+I)
               TEMP2(5) = CANVEC(LOC+14,NTAO+I)
               TEMP2(6) = CANVEC(LOC+ 7,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ(1) = TEMP4(1,1)
               TPXZ(2) = TEMP4(2,1)
               TPXZ(3) = TEMP4(3,1)
               TPXZ(4) = TEMP4(4,1)
               TPXZ(5) = TEMP4(5,1)
               TPXZ(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+12,NTAO+I)
               TEMP2(2) = CANVEC(LOC+13,NTAO+I)
               TEMP2(3) = CANVEC(LOC+ 6,NTAO+I)
               TEMP2(4) = CANVEC(LOC+14,NTAO+I)
               TEMP2(5) = CANVEC(LOC+11,NTAO+I)
               TEMP2(6) = CANVEC(LOC+ 8,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ(1) = TEMP4(1,1)
               TPYZ(2) = TEMP4(2,1)
               TPYZ(3) = TEMP4(3,1)
               TPYZ(4) = TEMP4(4,1)
               TPYZ(5) = TEMP4(5,1)
               TPYZ(6) = TEMP4(6,1)
C
               TEMP2(1) = CANVEC(LOC+10,NTAO+I)
               TEMP2(2) = CANVEC(LOC+14,NTAO+I)
               TEMP2(3) = CANVEC(LOC+11,NTAO+I)
               TEMP2(4) = CANVEC(LOC+ 7,NTAO+I)
               TEMP2(5) = CANVEC(LOC+ 8,NTAO+I)
               TEMP2(6) = CANVEC(LOC+ 2,NTAO+I)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ(1) = TEMP4(1,1)
               TPZZ(2) = TEMP4(2,1)
               TPZZ(3) = TEMP4(3,1)
               TPZZ(4) = TEMP4(4,1)
               TPZZ(5) = TEMP4(5,1)
               TPZZ(6) = TEMP4(6,1)
C
C              PERFORM THE THIRD AND FOURTH ROTATION
C
               TEMP2(1) = TPXX(1)
               TEMP2(2) = TPXY(1)
               TEMP2(3) = TPYY(1)
               TEMP2(4) = TPXZ(1)
               TEMP2(5) = TPYZ(1)
               TEMP2(6) = TPZZ(1)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXX2(1) = TEMP4(1,1)
               TPXX2(2) = TEMP4(2,1)
               TPXX2(3) = TEMP4(3,1)
               TPXX2(4) = TEMP4(4,1)
               TPXX2(5) = TEMP4(5,1)
               TPXX2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(2)
               TEMP2(2) = TPXY(2)
               TEMP2(3) = TPYY(2)
               TEMP2(4) = TPXZ(2)
               TEMP2(5) = TPYZ(2)
               TEMP2(6) = TPZZ(2)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXY2(1) = TEMP4(1,1)
               TPXY2(2) = TEMP4(2,1)
               TPXY2(3) = TEMP4(3,1)
               TPXY2(4) = TEMP4(4,1)
               TPXY2(5) = TEMP4(5,1)
               TPXY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(3)
               TEMP2(2) = TPXY(3)
               TEMP2(3) = TPYY(3)
               TEMP2(4) = TPXZ(3)
               TEMP2(5) = TPYZ(3)
               TEMP2(6) = TPZZ(3)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYY2(1) = TEMP4(1,1)
               TPYY2(2) = TEMP4(2,1)
               TPYY2(3) = TEMP4(3,1)
               TPYY2(4) = TEMP4(4,1)
               TPYY2(5) = TEMP4(5,1)
               TPYY2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(4)
               TEMP2(2) = TPXY(4)
               TEMP2(3) = TPYY(4)
               TEMP2(4) = TPXZ(4)
               TEMP2(5) = TPYZ(4)
               TEMP2(6) = TPZZ(4)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPXZ2(1) = TEMP4(1,1)
               TPXZ2(2) = TEMP4(2,1)
               TPXZ2(3) = TEMP4(3,1)
               TPXZ2(4) = TEMP4(4,1)
               TPXZ2(5) = TEMP4(5,1)
               TPXZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(5)
               TEMP2(2) = TPXY(5)
               TEMP2(3) = TPYY(5)
               TEMP2(4) = TPXZ(5)
               TEMP2(5) = TPYZ(5)
               TEMP2(6) = TPZZ(5)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPYZ2(1) = TEMP4(1,1)
               TPYZ2(2) = TEMP4(2,1)
               TPYZ2(3) = TEMP4(3,1)
               TPYZ2(4) = TEMP4(4,1)
               TPYZ2(5) = TEMP4(5,1)
               TPYZ2(6) = TEMP4(6,1)
C
               TEMP2(1) = TPXX(6)
               TEMP2(2) = TPXY(6)
               TEMP2(3) = TPYY(6)
               TEMP2(4) = TPXZ(6)
               TEMP2(5) = TPYZ(6)
               TEMP2(6) = TPZZ(6)
               CALL TFTRI(TEMP4(1,1),TEMP2,T3T,TEMP3,3,3,3)
               TPZZ2(1) = TEMP4(1,1)
               TPZZ2(2) = TEMP4(2,1)
               TPZZ2(3) = TEMP4(3,1)
               TPZZ2(4) = TEMP4(4,1)
               TPZZ2(5) = TEMP4(5,1)
               TPZZ2(6) = TEMP4(6,1)
C
               CANVEC(LOC   ,NTAO+I) = TPXX2(1)
               CANVEC(LOC+ 1,NTAO+I) = TPYY2(3)
               CANVEC(LOC+ 2,NTAO+I) = TPZZ2(6)
               CANVEC(LOC+ 3,NTAO+I) = TPXY2(1)/SQRT7*FOUR
               CANVEC(LOC+ 4,NTAO+I) = TPXZ2(1)/SQRT7*FOUR
               CANVEC(LOC+ 5,NTAO+I) = TPYY2(2)/SQRT7*FOUR
               CANVEC(LOC+ 6,NTAO+I) = TPYZ2(3)/SQRT7*FOUR
               CANVEC(LOC+ 7,NTAO+I) = TPXZ2(6)/SQRT7*FOUR
               CANVEC(LOC+ 8,NTAO+I) = TPYZ2(6)/SQRT7*FOUR
               CANVEC(LOC+ 9,NTAO+I) = TPYY2(1)/SQRT7/SQRT5*SQRT3*SIX
               CANVEC(LOC+10,NTAO+I) = TPZZ2(1)/SQRT7/SQRT5*SQRT3*SIX
               CANVEC(LOC+11,NTAO+I) = TPZZ2(3)/SQRT7/SQRT5*SQRT3*SIX
               CANVEC(LOC+12,NTAO+I) = TPYZ2(1)/SQRT7/SQRT5*TWELVE
               CANVEC(LOC+13,NTAO+I) = TPYZ2(2)/SQRT7/SQRT5*TWELVE
               CANVEC(LOC+14,NTAO+I) = TPZZ2(2)/SQRT7/SQRT5*TWELVE
            END DO
         END IF
      END DO
C
C
C
C  ROTATING DYNAMIC POLARIZABILITY-COORDINATES AND TENSOR
C
      IDPPTS=NDPPTS(N)
      DO 771 I=1,IDPPTS
        DO 761 J=1,3
          DTEMP(J,I) = DPCORD(J,I) - CORD(J,IPT(1))
  761   CONTINUE
  771 CONTINUE
C
      CALL MRARBR(T3,3,3,3,DTEMP,3,IDPPTS,EFDP(1,NDPTTPT+1),3)
C
      DO 781 I = 1,IDPPTS
C
        EFDP(1,I+NDPTTPT) = EFDP(1,I+NDPTTPT) + XCRD(1,N)
        EFDP(2,I+NDPTTPT) = EFDP(2,I+NDPTTPT) + YCRD(1,N)
        EFDP(3,I+NDPTTPT) = EFDP(3,I+NDPTTPT) + ZCRD(1,N)
C
        DPOLNAM(I+NDPTTPT) = DPNAME(I)
  781 CONTINUE
C
      CALL VCLR(TEMP3,1,3)
      CALL VCLR(T2,1,9)
      DO 791 I=1,IDPPTS
        T1(1,1) = DPOLT(1,I)
        T1(1,2) = DPOLT(4,I)
        T1(1,3) = DPOLT(5,I)
        T1(2,1) = DPOLT(7,I)
        T1(2,2) = DPOLT(2,I)
        T1(2,3) = DPOLT(6,I)
        T1(3,1) = DPOLT(8,I)
        T1(3,2) = DPOLT(9,I)
        T1(3,3) = DPOLT(3,I)
        CALL MRARBR(T3,3,3,3,T1,3,3,T2,3)
        CALL VCLR(T1,1,9)
        CALL MRARBR(T2,3,3,3,T3T,3,3,T1,3)
        EFDPOL(1,NDPTTPT+I) = T1(1,1)
        EFDPOL(4,NDPTTPT+I) = T1(1,2)
        EFDPOL(5,NDPTTPT+I) = T1(1,3)
        EFDPOL(7,NDPTTPT+I) = T1(2,1)
        EFDPOL(2,NDPTTPT+I) = T1(2,2)
        EFDPOL(6,NDPTTPT+I) = T1(2,3)
        EFDPOL(8,NDPTTPT+I) = T1(3,1)
        EFDPOL(9,NDPTTPT+I) = T1(3,2)
        EFDPOL(3,NDPTTPT+I) = T1(3,3)
  791 CONTINUE
C
      RETURN
      ENDIF
C
 9000 FORMAT(1X,'****',A8,' NOT FOUND IN ',A8,'****')
      END
C*MODULE EFINP   *DECK PRTFRG
      SUBROUTINE PRTFRG(AREL,CREL,MXRPTS,NDFG2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION AREL(MXRPTS,MXRPTS,NDFG2),CREL(MXRPTS,MXRPTS,NDFG2)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL DODIP,DOQUA,DOOCT
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXSH=5000, MXGTOT=20000,
     *           MXDFG=5, MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*6 FRGNAM
      CHARACTER*8 PTNAM,FRGNME,POLNAM,DPOLNAM,REPNAM,KNAME,LNAME
C
      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
     *                DOOCTU(MXFGPT)
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NAT(MXDFG),NUM(MXDFG),NTPATM
      COMMON /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ*MXFGPT)
      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
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
C     ----- WRITE INFORMATION DEFINING ALL FRAGMENTS -----
C
      IF (.NOT.MASWRK) RETURN
C
      WRITE(IW,9040)
      WRITE(IW,9042)
      DO I=1,NMTTPT
         WRITE(IW,9043) FRGNME(I),(EFC(J,I), J=1,3),EFCHG(1,I),
     *                  EFCHG(2,I)
      ENDDO
C
      WRITE(IW,9045) ICHGP
      WRITE(IW,9046)
      DO I=1,NMTTPT
         WRITE(IW,9047) FRGNME(I),EFBTRM(I),EFATRM(I),
     *                           EFBTRM2(I),EFATRM2(I)
      ENDDO
C
      DODIP = .FALSE.
      DOQUA = .FALSE.
      DOOCT = .FALSE.
      DO I=1,NMTTPT
         DODIP = DODIP .OR. DODIPO(I)
         DOQUA = DOQUA .OR. DOQUAD(I)
         DOOCT = DOOCT .OR. DOOCTU(I)
      ENDDO
C
      IF (DODIP .OR. DOQUA) THEN
         WRITE(IW,9060)
         WRITE(IW,9065)
      END IF
      DO 610 I=1,NMTTPT
         IF(DODIPO(I) .AND. DOQUAD(I)) THEN
         WRITE(IW,9070) FRGNME(I),(EFDIP(J,I),J=1,3),(EFQAD(J,I),J=1,6)
         ELSE IF(DODIPO(I) .AND. .NOT.DOQUAD(I)) THEN
            WRITE(IW,9073) FRGNME(I),(EFDIP(J,I),J=1,3)
         ELSE IF(.NOT.DODIPO(I) .AND. DOQUAD(I)) THEN
            WRITE(IW,9075) FRGNME(I),(EFQAD(J,I),J=1,6)
         END IF
  610 CONTINUE
C
      IF (DOOCT) THEN
         WRITE(IW,9080)
         WRITE(IW,9085)
      END IF
      DO 620 I=1,NMTTPT
         IF(DOOCTU(I)) WRITE(IW,9090) FRGNME(I), (EFOCT(J,I),J=1,10)
  620 CONTINUE
C
C  PRINT OUT POLARIZABLE POINT-INFORMATION
C
      IF (NPTTPT.GT.0) THEN
         WRITE(IW,9100)
         WRITE(IW,9105)
      END IF
      DO 630 I=1,NPTTPT
         WRITE(IW,9110) POLNAM(I),(EFP(J,I),J=1,3),(EFPOL(J,I),J=1,9)
  630 CONTINUE
C
C  PRINT OUT DYNAMIC POLARIZABLE POINT-INFORMATION
C
      IF (NDPTTPT.GT.0) THEN
         WRITE(IW,9101)
         WRITE(IW,9105)
      END IF
      DO 631 I=1,NDPTTPT
         WRITE(IW,9110) DPOLNAM(I),(EFDP(J,I),J=1,3),(EFDPOL(J,I),J=1,9)
  631 CONTINUE
C
C         AB INITIO-FRAGMENT REPULSION TERM
C
      IF (NRTTPT.GT.0) THEN
         WRITE(IW,9130)
         WRITE(IW,9140)
      END IF
      DO 650 I=1,NRTTPT
         IFF = KFR(I)
         ISS = KLR(I)
        WRITE(IW,9150) REPNAM(I),(CREP(L,I),L=1,3),(CLPR(II),NLPR(II)-2,
     *                  ZLPR(II), II=IFF,ISS)
  650 CONTINUE
C
C       NEW PAULI REPULSION PARAMETERS
C
      IF (NTMO.GT.0) WRITE(IW,9400)
      IF (NTMO.GT.0) WRITE(IW,9410)
      NMAX = MAX(NTMO,NTPATM)
      NMIN = MIN(NTMO,NTPATM)
      DO I = 1,NMAX
         IF (I.LE.NMIN) THEN
            WRITE(IW,9420) PRNAME(I),(PRCORD(J,I),J=1,3),CENTNM(I),
     *                     (CENTCD(J,I),J=1,3)
         ELSEIF (I.GT.NTPATM) THEN
            WRITE(IW,9430) CENTNM(I),(CENTCD(J,I),J=1,3)
         ELSEIF (I.GT.NTMO) THEN
            WRITE(IW,9440) PRNAME(I),(PRCORD(J,I),J=1,3)
         END IF
      END DO
C
C         FRAGMENT-FRAGMENT REPULSION TERM
C
      IF(NFRG.EQ.1 .OR. NTMO.GT.0) RETURN
C
      IJ=0
      WRITE(IW,9200) NDFRG,NDFG2
      NSHFTI=0
      DO 740 I=1,NDFRG
         NSHFTJ=0
         DO 730 J=1,I
            IJ=IJ+1
            WRITE(IW,9210) FRGNAM(NAMIDX(I)),FRGNAM(NAMIDX(J))
            KMAXR = NRPTS(NAMIDX(I))+1
            LMAXR = NRPTS(NAMIDX(J))+1
            DO 720 K=1,KMAXR
               IF(K.EQ.KMAXR) THEN
                  KNAME = 'CENTER  '
               ELSE
                  KNAME = REPNAM(NSHFTI+K)
               END IF
               DO 710 L=1,LMAXR
                  IF(L.EQ.LMAXR) THEN
                     LNAME = 'CENTER  '
                  ELSE
                     LNAME = REPNAM(NSHFTJ+L)
                  END IF
                  WRITE(IW,9220) KNAME,LNAME,CREL(K,L,IJ),AREL(K,L,IJ)
C-BIEXP- WRITE(IW,*) KNAME,LNAME,CREL(K,L,IJ+NDFRG2),AREL(K,L,IJ+NDFRG2)
  710          CONTINUE
  720       CONTINUE
            NSHFTJ=NSHFTJ+NRPTS(J)
  730    CONTINUE
         NSHFTI=NSHFTI+NRPTS(I)
  740 CONTINUE
C
      RETURN
C
 9040 FORMAT(/12X,'MULTIPOLE COORDINATES, ELECTRONIC AND NUCLEAR',
     *            ' CHARGES')
 9042 FORMAT(/18X,'X',14X,'Y',14X,'Z',10X,' ELEC. ',2X,'NUC.')
 9043 FORMAT(1X,A8,3F15.10,F11.5,F7.1)
 9045 FORMAT(/3X,'CHARGE SCREENING PARAMETERS (COEF AND ZETA),',
     *           ' ICHGP=',I4)
 9046 FORMAT(/13X,'GAUSSIAN DAMPING',4X,'EXPONENTIAL DAMPING')
 9047 FORMAT(1X,A8,2F10.5,3X,2F10.5)
 9060 FORMAT(/18X,'DIPOLE MOMENTS AND THE SECOND MOMENT TENSOR')
 9065 FORMAT(/18X,'X',8X,'Y',8X,'Z',11X,'XX/XY',4X,'YY/XZ',4X,'ZZ/YZ')
 9070 FORMAT(1X,A8,4X,3F9.5,4X,3F9.5/44X,3F9.5)
 9073 FORMAT(1X,A8,4X,3F9.5)
 9075 FORMAT(1X,A8,35X,6F9.5)
 9080 FORMAT(/18X,'THE THIRD MOMENT TENSOR')
 9085 FORMAT(/15X,'XXX/XYY',2X,'YYY/YYZ',2X,'ZZZ/XZZ',2X,'XXY/YZZ',
     *         2X,'XXZ/XYZ')
 9090 FORMAT(1X,A8,4X,5F9.5/13X,5F9.5)
 9100 FORMAT(/18X,'POLARIZABLE POINTS AND THE POLARIZABILITY TENSOR')
 9101 FORMAT(/18X,'DYNAMIC POLARIZABLE POINTS AND DYNAMIC TENSOR')
 9105 FORMAT(/14X,'X',7X,'Y',7X,'Z',7X,'XX/YZ',4X,'YY/YX',4X,
     *                                 'ZZ/ZX',4X,'XY/ZY',5X,'XZ')
 9110 FORMAT(1X,A8,3F8.4,1X,5F9.5/34X,4F9.5)
 9130 FORMAT(/20X,14(1H-),21X,18(1H-)/
     *        20X,'  REP POINTS  ',21X,'  REP PARAMETERS  '/
     *        20X,14(1H-),21X,18(1H-))
 9140 FORMAT(/16X,'X',9X,'Y',9X,'Z',15X,'COEF',7X,'N',10X,'ZETA'/)
 9150 FORMAT(2X,A8,3(1X,F9.5),5X,2X,F9.5,6X,I2,5X,F9.5,
     1                        (/47X,F9.5,6X,I2,5X,F9.5))
 9200 FORMAT(/1X,'THERE ARE',I4,' FRAGMENT TYPES, AND',I4,
     *            ' FRAGMENT-FRAGMENT INTERACTIONS.')
 9210 FORMAT(/1X,'REPULSIVE FIT FOR FRAGMENT PAIR ',A6,'-',A6,
     *           ' (COEF,EXPONENT)')
 9220 FORMAT(1X,A8,'-',A8,3X,F12.8,2X,F12.8)
 9400 FORMAT(/1X,18X,' AO EXPANSION POINTS',29X,'LMO CENTROIDS')
 9410 FORMAT(/,10X,6X,'X',10X,'Y',10X,'Z',25X,'X',10X,'Y',
     1        10X,'Z'/)
 9420 FORMAT(2X,A8,3(2X,F9.5),5X,2X,A8,3(2X,F9.5))
 9430 FORMAT(50X,A8,3(2X,F9.5))
 9440 FORMAT(2X,A8,3(2X,F9.5))
      END
C*MODULE EFINP   *DECK RDCRDX
      SUBROUTINE RDCRDX(CORD,EX1,EX2,NAME,NPTS,IFRAG)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000)
C
      CHARACTER*8 NAME
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION CORD(3,MXPT), NAME(MXPT), EX1(MXPT), EX2(MXPT)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IERR = 0
      IEOF = 0
      NPTS = 0
  100 CONTINUE
      I = NPTS+1
      IF(I.GT.MXPT) THEN
         IF(MASWRK) WRITE(IW,9000) IFRAG,MXPT
         CALL ABRT
      END IF
C
      CALL RDCARD('RDCRDX  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING FRAGMENT COORDS'
         CALL ABRT
      END IF
C
      NAME(I)='        '
      LGSTR=-8
      CALL GSTRNG(NAME(I),LGSTR)
      IF(NAME(I).EQ.'STOP    ') GO TO 200
C
      CORD(1,I) = RFIND('XCORD   ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDCRDX: ERROR READING X COORD'
         CALL ABRT
      END IF
C
      CORD(2,I) = RFIND('YCORD   ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDCRDX: ERROR READING Y COORD'
         CALL ABRT
      END IF
C
      CORD(3,I) = RFIND('ZCORD   ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDCRDX: ERROR READING Z COORD'
         CALL ABRT
      END IF
C
      EX1(I) = RFIND('EX1     ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDCRDX: ERROR READING EX1'
         CALL ABRT
      END IF
C
      EX2(I) = RFIND('EX2     ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDCRDX: ERROR READING EX2'
         CALL ABRT
      END IF
C
      NPTS = NPTS + 1
      GO TO 100
C
  200 CONTINUE
      RETURN
 9000 FORMAT(1X,'ERROR IN READING COORDINATES OF FRAGMENT',I4,
     *          ' EXCEEDED MXPT=',I5)
      END
C*MODULE EFINP   *DECK RDFGRP
      SUBROUTINE RDFGRP(AREL,CREL,MXRPTS,NDFRG2)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION AREL(MXRPTS,MXRPTS,NDFRG2),CREL(MXRPTS,MXRPTS,NDFRG2)
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 WORD,PTNAM,NAME1,NAME2,CENTER,CHAR,REPNAM
      CHARACTER*6 FRGNAM,FRG1,FRG2
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
      EXTERNAL REREAD
C
C         --- READ INTERFRAGMENT REPULSIVE POTENTIAL FIT ---
C
      IF (NFRG.EQ.1) RETURN
C
      LEN=MXRPTS*MXRPTS*NDFRG2
      CALL VCLR(AREL,1,LEN)
      CALL VCLR(CREL,1,LEN)
C
C     READ IN $FRGRPL
C
      CALL SEQREW(IR)
      IF(MASWRK) WRITE(IW,9000)
      CALL FNDGRP(IR,' $FRGRPL',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR: UNABLE TO FIND $FRGRPL GROUP'
         CALL ABRT
      END IF
      CENTER='CENTER  '
      IERR=0
C
   90 CALL RDCARD('$FRGRPL1',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING $FRGRPL GROUP'
         CALL ABRT
      END IF
C
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
      IF(WORD.EQ.'$END    ') GO TO 900
C
C     READ IN NAMES OF PAIRED FRAGMENTS
C
      FRG1='      '
      FRG2='      '
      LGSTR=-6
      CALL GSTRNG(FRG1,LGSTR)
      CALL GSTRNG(FRG2,LGSTR)
      DO 100 I=1,NDFRG
         IF (FRG1.EQ.FRGNAM(NAMIDX(I))) THEN
            INDX1=I
            GO TO 110
         END IF
  100 CONTINUE
      IF(MASWRK) WRITE(IW,9010) FRG1
      CALL ABRT
C
  110 DO 120 I=1,NDFRG
         IF (FRG2.EQ.FRGNAM(NAMIDX(I))) THEN
            INDX2=I
            GO TO 130
         END IF
  120 CONTINUE
      IF(MASWRK) WRITE(IW,9010) FRG2
      CALL ABRT
C
  130 CONTINUE
      IF (INDX2.LE.INDX1) THEN
         NFIDX=(INDX1-1)*INDX1/2+INDX2
      ELSE
         NFIDX=(INDX2-1)*INDX2/2+INDX1
      END IF
      NSHFT1=0
      DO 140 I=1,INDX1-1
         NSHFT1=NSHFT1+NRPTS(I)
  140 CONTINUE
      NSHFT2=0
      DO 150 I=1,INDX2-1
         NSHFT2=NSHFT2+NRPTS(I)
  150 CONTINUE
C
C        LOOP OVER READING REPULSION BETWEEN A PAIR OF REPULSIVE PTS
C
  155 CONTINUE
      CALL RDCARD('$FRGRPL2',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*)
     *      'END OF FILE READING FRAGMENT PAIR REPULSIONS'
         CALL ABRT
      END IF
      NAME1='        '
      NAME2='        '
      LGSTR=-8
      CALL GSTRNG(NAME1,LGSTR)
      IF(NAME1.EQ.'STOP    ') GO TO 90
      CALL GSTRNG(NAME2,LGSTR)
C
      DO 160 I=1,NRPTS(INDX1)
         IF (NAME1.EQ.REPNAM(NSHFT1+I)) THEN
            IDXN1=I
            GO TO 170
         END IF
  160 CONTINUE
      IF (NAME1.EQ.CENTER) THEN
         IDXN1=NRPTS(INDX1)+1
         GO TO 170
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME1,FRG1
      CALL ABRT
C
  170 CONTINUE
      DO 180 I=1,NRPTS(INDX2)
         IF (NAME2.EQ.REPNAM(NSHFT2+I)) THEN
            IDXN2=I
            GO TO 190
         END IF
  180 CONTINUE
      IF (NAME2.EQ.CENTER) THEN
         IDXN2=NRPTS(INDX2)+1
         GO TO 190
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME2,FRG2
      CALL ABRT
C
C         THE CODE PERMITS USE OF A BIEXPONENTIAL EXPANSION
C         OF THE INTER-FRAGMENT REPULSION, BUT THE EFPS IN
C         USE READ IN ONLY A SINGLE EXPONENTIAL.  THEREFORE
C         ONLY THE FIRST EXPONENTIAL IS DOCUMENTED, AND THE
C         CODE FOR THE 2ND EXPONENTIAL IS COMMENTED OUT.
C
C         THE ERROR CHECK SHOULD NEVER FAIL, HOPEFULLY.
C
  190 CONTINUE
      IF(IDXN1.GT.MXRPTS .OR. IDXN2.GT.MXRPTS) THEN
         IF(MASWRK) WRITE(IW,9030) IDXN1,IDXN2,MXRPTS
         CALL ABRT
      END IF
C
      CHAR='        '
      LENGTH=0
      CALL GSTRNG(CHAR,LENGTH)
      IF(LENGTH.GT.0) GO TO 200
C
      CALL REREAD
      IF (INDX1.GE.INDX2) THEN
         CREL(IDXN1,IDXN2,NFIDX)=RFIND('CREL    ',IERR)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'RDFGRP: ERROR READING CREL'
            CALL ABRT
         END IF
         AREL(IDXN1,IDXN2,NFIDX)=RFIND('AREL    ',IERR)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'RDFGRP: ERROR READING AREL'
            CALL ABRT
         END IF
C-BIEXP- CREL(IDXN1,IDXN2,NFIDX+NDFRG2)=RFIND('CREL    ',IERR)
C-BIEXP- IF(IERR.NE.0) CALL ABRT
C-BIEXP- AREL(IDXN1,IDXN2,NFIDX+NDFRG2)=RFIND('AREL    ',IERR)
C-BIEXP- IF(IERR.NE.0) CALL ABRT
      ELSE
         CREL(IDXN2,IDXN1,NFIDX)=RFIND('CREL    ',IERR)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'RDFGRP: ERROR READING CREL'
            CALL ABRT
         END IF
         AREL(IDXN2,IDXN1,NFIDX)=RFIND('AREL    ',IERR)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'RDFGRP: ERROR READING AREL'
            CALL ABRT
         END IF
C-BIEXP- CREL(IDXN2,IDXN1,NFIDX+NDFRG2)=RFIND('CREL    ',IERR)
C-BIEXP- IF(IERR.NE.0) CALL ABRT
C-BIEXP- AREL(IDXN2,IDXN1,NFIDX+NDFRG2)=RFIND('AREL    ',IERR)
C-BIEXP- IF(IERR.NE.0) CALL ABRT
      END IF
      GO TO 155
C
  200 CONTINUE
      NAME1='        '
      NAME2='        '
      LGSTR=-8
      CALL GSTRNG(NAME1,LGSTR)
      CALL GSTRNG(NAME2,LGSTR)
      DO 210 I=1,NRPTS(INDX1)
         IF (NAME1.EQ.REPNAM(NSHFT1+I)) THEN
            IDXN3=I
            GO TO 220
         END IF
  210 CONTINUE
      IF (NAME1.EQ.CENTER) THEN
         IDXN3=NRPTS(INDX1)+1
         GO TO 220
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME1,FRG1
C
  220 DO 230 I=1,NRPTS(INDX1)
         IF (NAME2.EQ.REPNAM(NSHFT2+I)) THEN
            IDXN4=I
            GO TO 240
         END IF
  230 CONTINUE
      IF (NAME2.EQ.CENTER) THEN
         IDXN4=NRPTS(INDX2)+1
         GO TO 240
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME2,FRG2
      IF(IERR.NE.0) CALL ABRT
C
  240 IF (INDX1.GE.INDX2) THEN
         CREL(IDXN1,IDXN2,NFIDX)=CREL(IDXN3,IDXN4,NFIDX)
         AREL(IDXN1,IDXN2,NFIDX)=AREL(IDXN3,IDXN4,NFIDX)
C-BIEXP- CREL(IDXN1,IDXN2,NFIDX+NDFRG2)=CREL(IDXN3,IDXN4,NFIDX+NDFRG2)
C-BIEXP- AREL(IDXN1,IDXN2,NFIDX+NDFRG2)=AREL(IDXN3,IDXN4,NFIDX+NDFRG2)
      ELSE
         CREL(IDXN2,IDXN1,NFIDX)=CREL(IDXN4,IDXN3,NFIDX)
         AREL(IDXN2,IDXN1,NFIDX)=AREL(IDXN4,IDXN3,NFIDX)
C-BIEXP- CREL(IDXN2,IDXN1,NFIDX+NDFRG2)=CREL(IDXN4,IDXN3,NFIDX+NDFRG2)
C-BIEXP- AREL(IDXN2,IDXN1,NFIDX+NDFRG2)=AREL(IDXN4,IDXN3,NFIDX+NDFRG2)
      END IF
      GO TO 155
C
  900 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'READING INTER-FRAGMENT REPULSION $FRGRPL...')
 9010 FORMAT(1X,'ERROR...FRAGMENT NAME USED IN $FRGRPL=',A6/
     *       1X,'DOES NOT MATCH ANY KNOWN FRAGMENT NAME.')
 9020 FORMAT(1X,'ERROR...REPULSIVE POINT USED IN $FRGRPL=',A8/
     *   1X,'DOES NOT MATCH ANY REPULSIVE POINT NAME IN FRAGMENT ',A8)
 9030 FORMAT(1X,'CONFUSION IN RDFGRP: IDXN1,IDXN2=',2I5,
     *          ' EXCEEDS MXRPTS=',I5)
      END
C
C*MODULE EFINP   *DECK RDFGDP
      SUBROUTINE RDFGDP(AREL,DREL,CREL,MXDPTS,NDFRG2,LC)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION AREL(MXDPTS,MXDPTS,NDFRG2),CREL(MXDPTS,MXDPTS,NDFRG2)
      DIMENSION DREL(MXDPTS,MXDPTS,NDFRG2)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 WORD,PTNAM,NAME1,NAME2,CENTER,CHAR,DNAME,DPSNAM
      CHARACTER*6 FRGNAM,FRG1,FRG2
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
C
      EXTERNAL REREAD
C
C         --- READ INTERFRAGMENT DISPERSION POTENTIAL FIT ---
C
      IF (NFRG.EQ.1) RETURN
C
      LEN=MXDPTS*MXDPTS*NDFRG2
C
C     C6*(1-A*E^(-B*R))/R^6
C
C     CREL: C6 OR C8
C     DREL: A
C     AREL: B
C
      CALL VCLR(AREL,1,LEN)
      CALL VCLR(CREL,1,LEN)
      CALL VCLR(DREL,1,LEN)
C
C     READ IN $FRGDPS
C
      CALL SEQREW(IR)
      IF(LC.EQ.0) THEN
        IF(MASWRK) WRITE(IW,9000) '$FRGDPS'
        CALL FNDGRP(IR,' $FRGDPS',IEOF)
        IF(IEOF.EQ.1) THEN
          IF(MASWRK) WRITE(IW,*) 'ERROR: UNABLE TO FIND $FRGDPS GROUP'
          CALL ABRT
        END IF
      END IF
      IF(LC.EQ.1) THEN
        IF(MASWRK) WRITE(IW,9000) '$FRGDP8'
        CALL FNDGRP(IR,' $FRGDP8',IEOF)
        IF(IEOF.EQ.1) THEN
          IF(MASWRK) WRITE(IW,*) 'ERROR: UNABLE TO FIND $FRGDP8 GROUP'
          CALL ABRT
        END IF
      END IF
      CENTER='CENTER  '
      IERR=0
C
   90 CALL RDCARD('$FRGDPS1',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
C
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
      IF(WORD.EQ.'$END    ') GO TO 900
C
C     READ IN NAMES OF PAIRED FRAGMENTS
C
      FRG1='      '
      FRG2='      '
      LGSTR=-6
      CALL GSTRNG(FRG1,LGSTR)
      CALL GSTRNG(FRG2,LGSTR)
      DO 100 I=1,NDFRG
         IF (FRG1.EQ.FRGNAM(NAMIDX(I))) THEN
            INDX1=I
            GO TO 110
         END IF
  100 CONTINUE
      IF(MASWRK) WRITE(IW,9010) FRG1
      CALL ABRT
C
  110 DO 120 I=1,NDFRG
         IF (FRG2.EQ.FRGNAM(NAMIDX(I))) THEN
            INDX2=I
            GO TO 130
         END IF
  120 CONTINUE
      IF(MASWRK) WRITE(IW,9010) FRG2
      CALL ABRT
C
  130 CONTINUE
      IF (INDX2.LE.INDX1) THEN
         NFIDX=(INDX1-1)*INDX1/2+INDX2
      ELSE
         NFIDX=(INDX2-1)*INDX2/2+INDX1
      END IF
      NSHFT1=0
      DO 140 I=1,INDX1-1
         NSHFT1=NSHFT1+NDPTS(I)
  140 CONTINUE
      NSHFT2=0
      DO 150 I=1,INDX2-1
         NSHFT2=NSHFT2+NDPTS(I)
  150 CONTINUE
C
C        LOOP OVER READING DISPERSION BETWEEN A PAIR OF DISP PTS
C
  155 CONTINUE
      CALL RDCARD('$FRGDPS2',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      NAME1='        '
      NAME2='        '
      LGSTR=-8
      CALL GSTRNG(NAME1,LGSTR)
      IF(NAME1.EQ.'STOP    ') GO TO 90
      CALL GSTRNG(NAME2,LGSTR)
C
      DO 160 I=1,NDPTS(INDX1)
        IF (NAME1.EQ.DPSNAM(NSHFT1+I)) THEN
           IDXN1=I
           GO TO 170
        END IF
  160 CONTINUE
      IF (NAME1.EQ.CENTER) THEN
         IDXN1=NDPTS(INDX1)+1
         GO TO 170
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME1,FRG1
      CALL ABRT
C
  170 CONTINUE
      DO 180 I=1,NDPTS(INDX2)
         IF (NAME2.EQ.DPSNAM(NSHFT2+I)) THEN
            IDXN2=I
            GO TO 190
         END IF
  180 CONTINUE
      IF (NAME2.EQ.CENTER) THEN
         IDXN2=NDPTS(INDX2)+1
         GO TO 190
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME2,FRG2
      CALL ABRT
C
C         THE CODE PERMITS USE OF A BIEXPONENTIAL EXPANSION
C         OF THE INTER-FRAGMENT DISPERSION, BUT THE EFPS IN
C         USE READ IN ONLY A SINGLE EXPONENTIAL.  THEREFORE
C         ONLY THE FIRST EXPONENTIAL IS DOCUMENTED, AND THE
C         CODE FOR THE 2ND EXPONENTIAL IS COMMENTED OUT.
C
C         THE ERROR CHECK SHOULD NEVER FAIL, HOPEFULLY.
C
  190 CONTINUE
      IF(IDXN1.GT.MXDPTS .OR. IDXN2.GT.MXDPTS) THEN
         IF(MASWRK) WRITE(IW,9030) IDXN1,IDXN2,MXDPTS
         CALL ABRT
      END IF
C
      CHAR='        '
      LENGTH=0
      CALL GSTRNG(CHAR,LENGTH)
      IF(LENGTH.GT.0) GO TO 200
C
      CALL REREAD
      IF (INDX1.GE.INDX2) THEN
         CREL(IDXN1,IDXN2,NFIDX)=RFIND('CREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
         DREL(IDXN1,IDXN2,NFIDX)=RFIND('DREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
         AREL(IDXN1,IDXN2,NFIDX)=RFIND('AREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
      ELSE
         CREL(IDXN2,IDXN1,NFIDX)=RFIND('CREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
         DREL(IDXN2,IDXN1,NFIDX)=RFIND('DREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
         AREL(IDXN2,IDXN1,NFIDX)=RFIND('AREL    ',IERR)
         IF(IERR.NE.0) CALL ABRT
      END IF
      GO TO 155
C
  200 CONTINUE
      NAME1='        '
      NAME2='        '
      LGSTR=-8
      CALL GSTRNG(NAME1,LGSTR)
      CALL GSTRNG(NAME2,LGSTR)
      DO 210 I=1,NDPTS(INDX1)
         IF (NAME1.EQ.DPSNAM(NSHFT1+I)) THEN
            IDXN3=I
            GO TO 220
         END IF
  210 CONTINUE
      IF (NAME1.EQ.CENTER) THEN
         IDXN3=NDPTS(INDX1)+1
         GO TO 220
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME1,FRG1
C
  220 DO 230 I=1,NDPTS(INDX1)
         IF (NAME2.EQ.DPSNAM(NSHFT2+I)) THEN
            IDXN4=I
            GO TO 240
         END IF
  230 CONTINUE
      IF (NAME2.EQ.CENTER) THEN
         IDXN4=NDPTS(INDX2)+1
         GO TO 240
      END IF
      IF(MASWRK) WRITE(IW,9020) NAME2,FRG2
      IF(IERR.NE.0) CALL ABRT
C
  240 IF (INDX1.GE.INDX2) THEN
         CREL(IDXN1,IDXN2,NFIDX)=CREL(IDXN3,IDXN4,NFIDX)
         DREL(IDXN1,IDXN2,NFIDX)=DREL(IDXN3,IDXN4,NFIDX)
         AREL(IDXN1,IDXN2,NFIDX)=AREL(IDXN3,IDXN4,NFIDX)
      ELSE
         CREL(IDXN2,IDXN1,NFIDX)=CREL(IDXN4,IDXN3,NFIDX)
         DREL(IDXN1,IDXN2,NFIDX)=DREL(IDXN3,IDXN4,NFIDX)
         AREL(IDXN2,IDXN1,NFIDX)=AREL(IDXN4,IDXN3,NFIDX)
      END IF
      GO TO 155
C
  900 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'READING INTER-FRAGMENT DISPERSION ',A7,'...')
 9010 FORMAT(1X,'ERROR...FRAGMENT NAME USED IN $FRGDPS=',A6/
     *       1X,'DOES NOT MATCH ANY KNOWN FRAGMENT NAME.')
 9020 FORMAT(1X,'ERROR...DISPERSION POINT USED IN $FRGDPS=',A8/
     *   1X,'DOES NOT MATCH ANY DISPERSION POINT NAME IN FRAGMENT ',A8)
 9030 FORMAT(1X,'CONFUSION IN RDFGDP: IDXN1,IDXN2=',2I5,
     *          ' EXCEEDS MXDPTS=',I5)
      END
C
C*MODULE EFINP   *DECK RDFRG
      SUBROUTINE RDFRG(IUNTRD,IFRG,STOP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL STOP
C
      PARAMETER (MXFRG=1050, MXDFG=5)
C
      PARAMETER (ONE=1.00D+00, UNITS=ONE/0.52917724924D+00)
C
      CHARACTER*8 WORD,PTNAM
      CHARACTER*6 FRGNAM
C
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      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)
C
C         ---- READ FRAGMENT LOCATIONS USING CARTESIAN COORDINATES -----
C
      IF (IFRG.EQ.1) NDFRG=0
      FACT = ONE
C IUNTRD=1: UNITS=ANGS
      IF(IUNTRD.EQ.1) FACT=UNITS
      IERR=0
      IEOF=0
      CALL RDCARD('$EFRAG 1',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*)
     *   'END OF FILE READING FRAGMENT CARTESIAN COORDINATES IN $EFRAG'
         CALL ABRT
      END IF
C
C          H2OEF2 WAS THE 2ND RHF PARAMETERIZATION TO BE MADE,
C          IN OTHER WORDS, THAT 2 HAS NOTHING TO DO WITH THE
C          SECOND GENERATION POTENTIAL, KNOWN AS EFP2.
C          CHANGE H2OEF2 TO THE DOCUMENTED CURRENT NAME H2ORHF,
C          SO THE REST OF THIS CODE CAN TEST ONLY ONE NAME.
C
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
      IF(WORD.EQ.'$END    ') THEN
         STOP=.TRUE.
         IFRG = IFRG - 1
         RETURN
      END IF
      IF(WORD.NE.'FRAGNAME') THEN
         IF(MASWRK) WRITE(IW,9010) IFRG,WORD
         CALL ABRT
      END IF
      FRGNAM(IFRG)='      '
      LGSTR=-6
      CALL GSTRNG(FRGNAM(IFRG),LGSTR)
      IF(FRGNAM(IFRG).EQ.'H2OEF2') FRGNAM(IFRG)='H2ORHF'
      IF(MASWRK) WRITE(IW,9020) IFRG,FRGNAM(IFRG)
C
      DO 100 I=1,IFRG-1
         IF (FRGNAM(IFRG).EQ.FRGNAM(I)) THEN
            ISET(IFRG)=ISET(I)
            GO TO 120
         END IF
  100 CONTINUE
      NDFRG=NDFRG+1
      IF(NDFRG.GT.MXDFG) THEN
         IF(MASWRK) WRITE(IW,9030) MXDFG
         CALL ABRT
      END IF
      ISET(IFRG)=NDFRG
      NAMIDX(NDFRG)=IFRG
C
  120 DO 110 I=1,3
        CALL RDCARD('$EFRAG 2',IEOF)
        PTNAM(I,IFRG)='        '
        LGSTR=-8
        CALL GSTRNG(PTNAM(I,IFRG),LGSTR)
        XCRD(I,IFRG)=RFIND('XCRD    ',IERR)*FACT
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING X COORD'
           CALL ABRT
        END IF
        YCRD(I,IFRG)=RFIND('YCRD    ',IERR)*FACT
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING Y COORD'
           CALL ABRT
        END IF
        ZCRD(I,IFRG)=RFIND('ZCRD    ',IERR)*FACT
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING Z COORD'
           CALL ABRT
        END IF
        TEST        =RFIND('TEST    ',IERR)
        IF(TEST.NE.ZERO) THEN
           IF(MASWRK) WRITE(IW,9040) PTNAM(I,IFRG),FRGNAM(IFRG)
           CALL ABRT
        END IF
  110 CONTINUE
      RETURN
C
 9010 FORMAT(/1X,'ERROR...READING FRAGMENT',I4/
     *       1X,'EXPECTED KEYWORD "FRAGNAME", FOUND "',A8,'".')
 9020 FORMAT(1X,'READING COORDINATES OF FRAGMENT',I4,' NAMED ',A8)
 9030 FORMAT(1X,'ERROR...THERE ARE TOO MANY FRAGMENT TYPES IN USE'/
     *       1X,'INCREASE MAXIMUM FRAGMENT TYPE -MXDFG- FROM',I4)
 9040 FORMAT(/1X,'*** ERROR ***'/
     *        1X,'FOUND 4 COORDINATES FOR POINT ',A,' IN FRAGMENT ',A/
     *        1X,'CHECK TO SEE IF -ZNUC- WAS ACCIDENTALLY GIVEN.')
      END
C*MODULE EFINP   *DECK RDFRG2
      SUBROUTINE RDFRG2(IFRG,STOP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL STOP
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXDFG=5)
C
      PARAMETER (ONE=1.00D+00, UNITS=ONE/0.52917724924D+00)
      PARAMETER (PI=3.14159265359D+00, ONE80=180.0D+00)
C
      CHARACTER*8 WORD, PTNAM
      CHARACTER*6 FRGNAM
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C         ---- READ FRAGMENT LOCATIONS USING INTERNAL COORDINATES -----
C
      DIMENSION BL(3), ALPHA(3), BETA(3), V1(3), V2(3),
     *          VP(3), VJ(3), AL1(3), AL2(3), AL3(3), AL4(3), IZ(3,3)
C
      IF (IFRG.EQ.1) NDFRG=0
      IERR = 0
      IEOF = 0
      NATOMS = NAT
      CALL RDCARD('$EFRAG 1',IEOF)
      IF (IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING $EFRAG GROUP'
         CALL ABRT
      END IF
C
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
      IF (WORD.EQ.'$END   ') THEN
         STOP = .TRUE.
         IFRG = IFRG - 1
         RETURN
      END IF
      IF(WORD.NE.'FRAGNAME') THEN
         IF(MASWRK) WRITE(IW,9010) IFRG,WORD
         CALL ABRT
      END IF
      FRGNAM(IFRG)='      '
      LGSTR=-6
      CALL GSTRNG(FRGNAM(IFRG),LGSTR)
      IF(FRGNAM(IFRG).EQ.'H2OEF2') FRGNAM(IFRG)='H2ORHF'
      IF(MASWRK) WRITE(IW,9020) IFRG,FRGNAM(IFRG)
C
      DO 100 I=1,IFRG-1
         IF (FRGNAM(IFRG).EQ.FRGNAM(I)) THEN
            ISET(IFRG)=ISET(I)
            GO TO 120
         END IF
  100 CONTINUE
      NDFRG=NDFRG+1
      IF(NDFRG.GT.MXDFG) THEN
         IF(MASWRK) WRITE(IW,9030) MXDFG
         CALL ABRT
      END IF
      ISET(IFRG)=NDFRG
      NAMIDX(NDFRG)=IFRG
C
  120 DO 110 J = 1,3
         CALL RDCARD('$EFRAG 2',IEOF)
         PTNAM(J,IFRG)='        '
         LGSTR=-8
         CALL GSTRNG(PTNAM(J,IFRG),LGSTR)
         IZ(J,1) = IFIND('IZ     ',IERR)
         BL(J) = RFIND('BL      ',IERR)*UNITS
         IZ(J,2) = IFIND('IZ     ',IERR)
         ALPHA(J) = RFIND('ALPHA   ',IERR)*PI/ONE80
         IZ(J,3) = IFIND('IZ     ',IERR)
         BETA(J) = RFIND('BETA    ',IERR)*PI/ONE80
C
C                  ****** USE DIHEDRAL ANGLE *****
C
         CALL RELVC2(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 RELVC2(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
  320 CONTINUE
      ITEMP = IZ(J,1)
      IF (ITEMP.LE.NATOMS) THEN
         XCRD(J,IFRG) = VJ(1) + C(1,ITEMP)
         YCRD(J,IFRG) = VJ(2) + C(2,ITEMP)
         ZCRD(J,IFRG) = VJ(3) + C(3,ITEMP)
      ELSE
        NFRG = (ITEMP-NATOMS)/3
        I123 = MOD(ITEMP-NATOMS,3)
        IF (I123.GT.0) THEN
           NFRG = NFRG + 1
        ELSE
           I123 = 3
        END IF
        XCRD(J,IFRG) = VJ(1) + XCRD(I123,NFRG)
        YCRD(J,IFRG) = VJ(2) + YCRD(I123,NFRG)
        ZCRD(J,IFRG) = VJ(3) + ZCRD(I123,NFRG)
      END IF
  110 CONTINUE
      RETURN
C
 9010 FORMAT(/1X,'ERROR...READING FRAGMENT',I4/
     *       1X,'EXPECTED KEYWORD "FRAGNAME", FOUND "',A8,'".')
 9020 FORMAT(1X,'OBTAINING COORDINATES FOR FRAGMENT',I4,' NAMED ',A8)
 9030 FORMAT(1X,'ERROR...THERE ARE TOO MANY FRAGMENT TYPES IN USE'/
     *       1X,'INCREASE MAXIMUM FRAGMENT TYPE -MXDFG- FROM',I4)
      END
C*MODULE EFINP   *DECK RDMONO
      SUBROUTINE RDMONO(N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      CHARACTER*8 MNAME,PNAME,DUMY,RNAME,DPNAME
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      IERR = 0
      IEOF = 0
      NPTS = NMPTS(N)
  100 CONTINUE
      CALL RDCARD('RDMONO  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING FRAGMENT MONOPOLE'
         CALL ABRT
      END IF
      DUMY='        '
      LGSTR=-8
      CALL GSTRNG(DUMY,LGSTR)
      IF(DUMY.EQ.'STOP    ') GO TO 400
      DO 200 J=1,NPTS
        IF(DUMY.EQ.MNAME(J)) THEN
          I=J
          DOMTMP(J) = .TRUE.
          GO TO 300
        END IF
  200 CONTINUE
      IF (MASWRK) WRITE(IW,9000) DUMY
      CALL ABRT
  300 CONTINUE
C
      IF((IEFP2.EQ.1).AND.(IEFMON.EQ.1)) THEN
        ACHGHF(1,I) = RFIND('ACHG1   ',IERR)
        IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR READING ACHGHF-1'
         CALL ABRT
        ENDIF
      ELSE
        ACHG(1,I) = RFIND('ACHG1   ',IERR)
        IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR READING ACHG-1'
         CALL ABRT
        END IF
      END IF
C
      IF((IEFP2.EQ.1).AND.(IEFMON.EQ.1)) THEN
        ACHGHF(2,I) = RFIND('ACHG2   ',IERR)
        IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR READING ACHGHF-2'
         CALL ABRT
        END IF
      ELSE
        ACHG(2,I) = RFIND('ACHG2   ',IERR)
        IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR READING ACHG-2'
         CALL ABRT
        END IF
      END IF
C
      GO TO 100
C
  400 CONTINUE
      RETURN
 9000 FORMAT(1X,'POINT ',A8,' HAS NOT BEEN GIVEN COORDINATES')
      END
C*MODULE EFINP   *DECK RDDIPO
      SUBROUTINE RDDIPO(N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,DUMY,RNAME,DPNAME
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      IERR = 0
      IEOF = 0
      NPTS = NMPTS(N)
  100 CONTINUE
      CALL RDCARD('RDDIPO  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING FRAGMENT DIPOLE'
         CALL ABRT
      END IF
      DUMY='        '
      LGSTR=-8
      CALL GSTRNG(DUMY,LGSTR)
      IF(DUMY.EQ.'STOP    ') GO TO 600
      DO 200 J=1,NPTS
        IF(DUMY.EQ.MNAME(J)) THEN
          I=J
          DODTMP(J) = .TRUE.
          GO TO 300
        END IF
  200 CONTINUE
      IF (MASWRK) WRITE(IW,9000) DUMY
      CALL ABRT
  300 CONTINUE
      DO 500 L=1,3
C
        IF((IEFP2.EQ.1).AND.(IEFDIP.EQ.1)) THEN
          ADIPHF(L,I) = RFIND('ADIPHF  ',IERR)
          IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING ADIPHF-',L
           CALL ABRT
          END IF
        ELSE
          ADIP(L,I) = RFIND('ADIP    ',IERR)
          IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING ADIP-',L
           CALL ABRT
          END IF
        END IF
C
  500 CONTINUE
      GO TO 100
C
  600 CONTINUE
      RETURN
 9000 FORMAT(1X,'POINT ',A8,' HAS NOT BEEN GIVEN COORDINATES')
      END
C*MODULE EFINP   *DECK RDOCTU
      SUBROUTINE RDOCTU(N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,DUMY,RNAME,DPNAME
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IERR = 0
      IEOF = 0
      NPTS = NMPTS(N)
  100 CONTINUE
      CALL RDCARD('RDOCTU  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING FRAGMENT OCTUPOLE'
         CALL ABRT
      END IF
      DUMY='        '
      LGSTR=-8
      CALL GSTRNG(DUMY,LGSTR)
      IF(DUMY.EQ.'STOP    ') GO TO 600
      DO 200 J=1,NPTS
        IF(DUMY.EQ.MNAME(J)) THEN
          I=J
          DOOTMP(J) = .TRUE.
          GO TO 300
        END IF
  200 CONTINUE
      IF (MASWRK) WRITE(IW,9000)DUMY
      CALL ABRT
  300 CONTINUE
      DO 500 L=1,10
        AOCT(L,I) = RFIND('AOCT    ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING OCTUPOLE-',L
           CALL ABRT
        END IF
  500 CONTINUE
      GO TO 100
C
  600 CONTINUE
      RETURN
 9000 FORMAT(1X,'POINT ',A8,' HAS NOT BEEN GIVEN COORDINATES')
      END
C*MODULE EFINP   *DECK RDQUAD
      SUBROUTINE RDQUAD(N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      CHARACTER*8 MNAME,PNAME,DUMY,RNAME,DPNAME
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      IERR = 0
      IEOF = 0
      NPTS = NMPTS(N)
  100 CONTINUE
      CALL RDCARD('RDQUAD  ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*)
     *        'END OF FILE READING FRAGMENT QUADRUPOLE'
         CALL ABRT
      END IF
      DUMY='        '
      LGSTR=-8
      CALL GSTRNG(DUMY,LGSTR)
      IF(DUMY.EQ.'STOP    ') GO TO 600
      DO 200 J=1,NPTS
        IF(DUMY.EQ.MNAME(J)) THEN
          I=J
          DOQTMP(J) = .TRUE.
          GO TO 300
        END IF
  200 CONTINUE
      IF (MASWRK) WRITE(IW,9000)DUMY
      CALL ABRT
  300 CONTINUE
      DO 500 L=1,6
C
        IF((IEFP2.EQ.1).AND.(IEFQUD.EQ.1)) THEN
          AQADHF(L,I) = RFIND('AQADHF  ',IERR)
          IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING HF QUADRUPOLE-',L
           CALL ABRT
          END IF
        ELSE
          AQAD(L,I) = RFIND('AQAD    ',IERR)
          IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'ERROR READING QUADRUPOLE-',L
           CALL ABRT
          END IF
        END IF
C
  500 CONTINUE
      GO TO 100
C
  600 CONTINUE
      RETURN
 9000 FORMAT(1X,'POINT ',A8,' HAS NOT BEEN GIVEN COORDINATES')
      END
C*MODULE EFINP   *DECK RDPAO
      SUBROUTINE RDPAO(M)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION LABEL(28)
C
      PARAMETER (MXSH=5000, MXGTOT=20000,
     *           MXDFG=5, MXFRG=1050, MXFGPT=12000)
      PARAMETER (ZERO=0.0D+00)
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),
     *                NAT(MXDFG),NUM(MXDFG),NTPATM
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DIMENSION NBFS(27), MINF(27), MAXF(27), NANGM(27)
C
      CHARACTER*8 CNAME
C
      DATA BLANK/8H        /
      DATA LABEL/8HS       ,8HP       ,8HD       ,8HF       ,
     *           8HG       ,8HL       ,8HM       ,8HN       ,
     *           8H1S      ,8H2S      ,8H2P      ,8H2SP     ,
     *           8H3S      ,8H3P      ,8H3D      ,8H3SP     ,8H3SPD    ,
     *           8H4S      ,8H4P      ,8H4D      ,8H4SP     ,8H4SPD    ,
     *           8H5S      ,8H5P      ,8H5D      ,8H5SP     ,8H5SPD    ,
     *           8HSV      /
C
      DATA NBFS/ 1, 3, 6,10,15,     4,10,20,
     *           1, 1, 3, 4,        1, 3, 6, 4,10,
     *           1, 3, 6, 4,10,     1, 3, 6, 4,10/
      DATA MINF/ 1, 2, 5,11,21,     1, 1, 1,
     *           1, 1, 2, 1,        1, 2, 5, 1, 1,
     *           1, 2, 5, 1, 1,     1, 2, 5, 1, 1/
      DATA MAXF/ 1, 4,10,20,35,     4,10,20,
     *           1, 1, 4, 4,        1, 4,10, 4,10,
     *           1, 4,10, 4,10,     1, 4,10, 4,10/
      DATA NANGM/1, 2, 3, 4, 5,     2, 3, 4,
     *           1, 1, 2, 2,        1, 2, 3, 2, 3,
     *           1, 2, 3, 2, 3,     1, 2, 3, 2, 3/
C
      N=ISET(M)
      NAT0 = 0
      NSHEL0 = 0
      LOC = 0
      NGAUS0 = 0
  100 CONTINUE
C
C  --- READ POINT NAME AND COODINATES ----
C
      IEOF = 0
      IERR = 0
      CALL RDCARD('PROJECT1',IEOF)
      CNAME='        '
      LGSTR=-8
      CALL GSTRNG(CNAME,LGSTR)
      IF(CNAME.EQ.'STOP    ') GO TO 999
      NAT0 = NAT0 + 1
      READ(UNIT=CNAME,FMT='(A8)') PRNAME(NAT0+NTPATM)
      DO J = 1,3
         PRCORD(J,NAT0+NTPATM) = RFIND('PRCORD  ',IERR)
      END DO
      EFZNUC(NAT0+NTPATM) = RFIND('EFZNUC  ',IERR)
  150 CONTINUE
C
C  --- READ BASIS FUNCTION ---
C
      IEOF = 0
      IERR = 0
      CALL RDCARD('PROJECT2',IEOF)
      CNAME='        '
      LGSTR=-8
      CALL GSTRNG(CNAME,LGSTR)
      READ(UNIT=CNAME,FMT='(A8)') BASIS
      IGAUSS = IFIND('NGAUSS  ',IERR)
C
      IF(BASIS.EQ.BLANK) GO TO 100
C
C  --- DETERMINE THE KIND OF BASIS FUNCTION ---
C        (ONLY S,P,D, AND L SO FAR)
C
      ITYP = 0
      IF(BASIS.EQ.LABEL(1)) ITYP=1
      IF(BASIS.EQ.LABEL(2)) ITYP=2
      IF(BASIS.EQ.LABEL(3)) ITYP=3
      IF(BASIS.EQ.LABEL(4)) ITYP=4
      IF(BASIS.EQ.LABEL(5)) ITYP=5
      IF(BASIS.EQ.LABEL(6)) ITYP=6
      IF(ITYP.EQ.0) THEN
         WRITE(IW,*) 'UNRECOGNIZED BASIS FUNCTION'
         CALL ABRT
      END IF
C
C  --- READ IN BASIS FUNCTION ---
C
      NSHEL0 = NSHEL0 + 1
      KMIN(NSHEL0,N) = MINF(ITYP)
      KMAX(NSHEL0,N) = MAXF(ITYP)
      KSTART(NSHEL0,N) = NGAUS0+1
      KATOM(NSHEL0,N) = NAT0
      KTYPE(NSHEL0,N) = NANGM(ITYP)
      KNG(NSHEL0,N) = IGAUSS
      KLOC(NSHEL0,N) = LOC+1
      NGAUS0 = NGAUS0+IGAUSS
      LOC = LOC+NBFS(ITYP)
      K1 = KSTART(NSHEL0,N)
      K2 = K1+KNG(NSHEL0,N)-1
C
      DO 200 I = K1,K2
         C1 = ZERO
         CALL RDCARD('PROJECT3',IEOF)
         IDUM = IFIND('IDUM    ',IERR)
         EX(I,N) = RFIND('ZETA    ',IERR)
         C1    = RFIND('C1      ',IERR)
         C2    = RFIND('C2      ',IERR)
         IF(ITYP.EQ.1) CS(I,N) = C1
         IF(ITYP.EQ.2) CP(I,N) = C1
         IF(ITYP.EQ.3) CD(I,N) = C1
         IF(ITYP.EQ.4) CF(I,N) = C1
         IF(ITYP.EQ.5) CG(I,N) = C1
         IF(ITYP.EQ.6) CS(I,N) = C1
         IF(ITYP.EQ.6) CP(I,N) = C2
  200 CONTINUE
C THIS GETS RID OF FTNCHECK WARNING
      IDUM = IDUM+1
      GO TO 150
C
  999 CONTINUE
      NUM(N) = LOC
      NAT(N) = NAT0
      NSHELL(N) = NSHEL0
      NGAUSS(N) = NGAUS0
      RETURN
      END
C*MODULE EFINP   *DECK RDPMO
      SUBROUTINE RDPMO(N,NMOS,NAOS,PROVEC,FOCKMA,
     *                 MXBF,MXMO,MXMO2,NFRG,NTMOF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXFRG=1050, MXFGPT=12000)
C
      CHARACTER*8 PTNAM
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
C
      DIMENSION PROVEC(MXBF,NTMOF),FOCKMA(MXMO2,NFRG)
C
      IZERO = 0
      IONE  = 1
      ITWO  = 2
C
      IF(NMOS.GT.MXMO  .OR.  NAOS.GT.MXBF) THEN
         IF(MASWRK) WRITE(IW,9010) NMOS,NAOS,MXMO,MXBF
         CALL ABRT
      END IF
C
      NORB(N) = NMOS
      NPBF(N) = NAOS
      IF (MASWRK) THEN
      DO 280 J = 1,NMOS
         IMAX = 0
         IC = 0
  240    CONTINUE
            IMIN = IMAX+1
            IMAX = IMAX+5
            IC = IC+1
            IF(IMAX .GT. NAOS) IMAX = NAOS
            READ(IR,9040,END=300,ERR=300) JJ,ICC,
     *                                    (PROVEC(I,J+NTMO),I=IMIN,IMAX)
            MODJ=MOD(J,100)
            IF(JJ.EQ.MODJ . AND.  ICC.EQ.IC) GO TO 260
               WRITE(IW,9060) J,IC,JJ,ICC
               IF (GOPARR) CALL DDI_BCAST(352,'I',ITWO,1,MASTER)
               CALL ABRT
  260       CONTINUE
         IF(IMAX .LT. NPBF(N)) GO TO 240
  280 CONTINUE
      IF (GOPARR) CALL DDI_BCAST(352,'I',IZERO,1,MASTER)
C
C SLAVE WORK.  IEND=0,1,2 MEANS OK DATA, INCOMPLETE DATA, SCRAMBLED DATA
C
      ELSE
         IF (GOPARR) CALL DDI_BCAST(352,'I',IEND,1,MASTER)
         IF (IEND.EQ.IONE) GO TO 300
         IF (IEND.EQ.ITWO) CALL ABRT
      END IF
C
C  GIVE VECTORS TO ALL PROCESSES
C
      IF (GOPARR) CALL DDI_BCAST(353,'F',PROVEC,NMOS*NAOS,MASTER)
C
      IEOF = 0
      CALL RDCARD('MO1     ',IEOF)
      CALL RDCARD('MO2     ',IEOF)
      DO  I = 1,(NMOS*NMOS+NMOS)/2
         FOCKMA(I,N) = RFIND('MO2     ',IEOF)
      END DO
      CALL RDCARD('MO3     ',IEOF)
      DO I = 1,NMOS
         CALL RDCARD('MO4     ',IEOF)
         PTNAM='        '
         LGSTR=-8
         CALL GSTRNG(PTNAM,LGSTR)
         READ(UNIT=PTNAM,FMT='(A8)') CENTNM(I+NTMO)
         CENTCD(1,I+NTMO) = RFIND('MO4     ',IEOF)
         CENTCD(2,I+NTMO) = RFIND('MO4     ',IEOF)
         CENTCD(3,I+NTMO) = RFIND('MO4     ',IEOF)
      END DO
C
      CALL RDCARD('STOP    ',IEOF)
      RETURN
C
C        PREMATURE END OF $VEC INPUT ENCOUNTERED
C
  300 CONTINUE
      IF (MASWRK) THEN
         IF (GOPARR) CALL DDI_BCAST(352,'I',IONE,1,MASTER)
         WRITE(IW,9100) J,IC
      ENDIF
      CALL ABRT
      RETURN
C
 9010 FORMAT(/1X,'* * * ERROR * * *'/
     *       1X,'NUMBER OF MO''S IN THIS FRAGMENT =',I5,' OR'/
     *       1X,'NUMBER OF AO''S IN THIS FRAGMENT =',I5,' EXCEEDS THE'/
     *       1X,'MAXIMUM NO. OF MO''S AND AO''S GIVEN IN $EFRAG=',2I5/
     *       1X,'PLEASE GIVE CORRECT -MXMO- AND -MXBF- KEYWORDS',
     *       1X,' ON THE FIRST $EFRAG CARD.'/)
 9040 FORMAT(I2,I3,5E15.8)
 9060 FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
 9100 FORMAT(' *** ERROR: PREMATURE END OF ORBITAL INPUT ENCOUNTERED'/
     *       '            LOOKING FOR ORBITAL',I4,' ELEMENT',I4)
      END
C*MODULE EFINP   *DECK RDPTEN
      SUBROUTINE RDPTEN(NPTS,N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IERR = 0
      IEOF = 0
      NPTS = 0
  100 CONTINUE
      K = NPTS + 1
      IF(K.GT.MXPT) THEN
         IF(MASWRK) WRITE(IW,9000) N,MXPT
         CALL ABRT
      END IF
      CALL RDCARD('RDPTEN1 ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING POLARIZATION INFO'
         CALL ABRT
      END IF
      PNAME(K) = '        '
      LGSTR=-8
      CALL GSTRNG(PNAME(K),LGSTR)
      IF(PNAME(K).EQ.'STOP    ') GO TO 600
      DO 120 L = 1,NMPTS(N)
        IF(PNAME(K).EQ.MNAME(L)) GO TO 130
  120 CONTINUE
      GO TO 140
  130 CONTINUE
      PCORD(1,K) = CORD(1,L)
      PCORD(2,K) = CORD(2,L)
      PCORD(3,K) = CORD(3,L)
      GO TO 200
  140 CONTINUE
      DO 150 J=1,3
        PCORD(J,K) = RFIND('PCORD   ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'RDPTEN: ERROR READING PCORD'
           CALL ABRT
        END IF
  150 CONTINUE
  200 CONTINUE
      CALL RDCARD('RDPTEN2 ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING POLARIZATION INFO2'
         CALL ABRT
      END IF
      DO 500 L=1,9
        POLT(L,K) = RFIND('POLT    ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'RDPTEN: ERROR READING POLT'
           CALL ABRT
        END IF
  500 CONTINUE
      NPTS = NPTS + 1
      GO TO 100
C
  600 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'ERROR IN READING POLARIZABLE POINTS FOR FRAGMENT',I4,
     *          ' EXCEEDED MXPT=',I5)
      END
C*MODULE EFINP   *DECK RDPTN2
      SUBROUTINE RDPTN2(NPTS,N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12,MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      IERR = 0
      IEOF = 0
      NPTS2= 0
C
C         THIS ROUTINE READS THE "POLARIZ2" TENSOR IN, INTO THE
C         SAME ARRAY AS THE NORMAL DISTRIBUTED POLARIZABILITIES.
C         NPTS2 COUNTS THE NEW ONES, AND NPTS COUNTS BOTH TYPES!
C
C     N=IFRAG, NMPTS--# OF EXPANSION POINTS
C
  10  CONTINUE
      K=NPPTS(N)+NPTS2+1
      CALL RDCARD('RDPTN21 ',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      PNAME(K) = '        '
      LGSTR=-8
      CALL GSTRNG(PNAME(K),LGSTR)
      IF(PNAME(K).EQ.'STOP    ') GO TO 600
C
      L=NMPTS(N)
C
C     LET'S SAVE THE COORDINATE FOR CMASS
C     IN PCORD AS WELL
C     BUT NOT IN POLT IN THAT CASE, IT WILL NOT
C     SCREW UP HF EPOL CALCULATION SINCE
C     IT MAY INCREASE THE COORD  BY ONE WITH
C     ALL ZERO POL TENSOR.
C
      IF(PNAME(K).EQ.MNAME(L)) GO TO 30
      GO TO 40
  30  CONTINUE
      PCORD(1,K) = CORD(1,L)
      PCORD(2,K) = CORD(2,L)
      PCORD(3,K) = CORD(3,L)
      GO TO 80
  40  CONTINUE
      DO 50 J=1,3
        PCORD(J,K) = RFIND('PCORD2  ',IERR)
        IF(IERR.NE.0) CALL ABRT
  50  CONTINUE
  80  CONTINUE
C
      CALL RDCARD('RDPTN22 ',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      DO 90 L=1,9
        POLT2(L) = RFIND('POLT2   ',IERR)
        IF(IERR.NE.0) CALL ABRT
        POLT(L,K) = POLT2(L)
  90  CONTINUE
      NPTS  = NPTS  + 1
      NPTS2 = NPTS2 + 1
C
C     WRITE(IW,92)NPTS
C     WRITE(IW,101)CORD(1,NMPTS(N)),CORD(2,NMPTS(N)),
C    *             CORD(3,NMPTS(N))
C     WRITE(IW,97)PCORD(1,K),PCORD(2,K),PCORD(3,K)
C     WRITE(IW,98)PCORD2(1),PCORD2(2),PCORD2(3)
C     WRITE(IW,99)POLT(1,K),POLT(2,K),POLT(3,K),POLT(4,K),
C    *       POLT(5,K),POLT(6,K),POLT(7,K),POLT(8,K),POLT(9,K)
C     WRITE(IW,100)POLT2(1),POLT2(2),POLT2(3),POLT2(4),POLT2(5),
C    *              POLT2(6),POLT2(7),POLT2(8),POLT2(9)
C 92  FORMAT('NPPTS() = ',I4)
C 97  FORMAT('PCORD = ',3F10.6)
C 98  FORMAT('PCORD2= ',3F10.6)
C 99  FORMAT('POLT  = ',9F10.6)
C100  FORMAT('POLT2 = ',9F10.6)
C101  FORMAT('CORD  = ',3F10.6)
C
      GO TO 10
C
C        EVEN THOUGH THIS CODE APPEARS TO BE WILLING TO LOOP TO
C        READ MORE THAN ONE SUCH TENSOR, THE CODE CLEARLY USES
C        ONLY ONE SUCH TENSOR PER FRAGMENT.  CHECK THE DIMENSION,
C        AND THE USAGE IN -FRGTROT- AND -EFDSPL- ABOUT THIS.
C
 600  CONTINUE
      IF(NPTS2.GT.1) THEN
         IF(MASWRK) WRITE(IW,*)
     *         'ONLY ONE POLARIZ2 POINT PER FRAGMENT ALLOWED'
         CALL ABRT
      END IF
      RETURN
      END
C
C*MODULE EFINP   *DECK RDREP
      SUBROUTINE RDREP(NPTS,N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA ZERO/0.0D+00/
C
      IERR = 0
      IEOF = 0
      NPTS = 0
      IKFR(1) = 1
  100 CONTINUE
      K = NPTS+1
      IF(K.GT.MXPT) THEN
         IF(MASWRK) WRITE(IW,9000) N,MXPT
         CALL ABRT
      END IF
      CALL RDCARD('RDREP   ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*)
     *     'END OF FILE READING FRAGMENT REPULSION DATA'
         CALL ABRT
      END IF
      RNAME(K) = '        '
      LGSTR=-8
      CALL GSTRNG(RNAME(K),LGSTR)
      IF(RNAME(K).EQ.'STOP    ') GO TO 400
      DO 120 L = 1,NMPTS(N)
        IF(RNAME(K).EQ.MNAME(L)) GO TO 130
  120 CONTINUE
      GO TO 140
  130 CONTINUE
      RCORD(1,K) = CORD(1,L)
      RCORD(2,K) = CORD(2,L)
      RCORD(3,K) = CORD(3,L)
      GO TO 200
  140 CONTINUE
      DO 150 J=1,3
        RCORD(J,K) = RFIND('RCORD   ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'RDREP: ERROR READING RCORD-',J
           CALL ABRT
        END IF
  150 CONTINUE
C
C         -INLPR- IS AN UNDOCUMENTED OPTION TO ADD A POWER OF R
C         TO THE POTENTIAL, R**(INLPR+2).  THE CURRENT EFPS ALL
C         USE INLPR=0, HENCE IT IS NOT DOCUMENTED.
C
  200 CONTINUE
      NTERMS = IFIND('NTERM   ',IERR)
      IF(IERR.NE.0) THEN
         IF(MASWRK) WRITE(IW,*) 'RDREP: ERROR READING NTERMS'
         CALL ABRT
      END IF
      IF(K.NE.1) IKFR(K) = IKLR(K-1) + 1
      IKLR(K) = IKFR(K) + NTERMS - 1
      IFF = IKFR(K)
      ISS = IKLR(K)
      DO 300 II = IFF,ISS
        CALL RDCARD('RDREP2  ',IEOF)
        IF(IEOF.EQ.1) THEN
           IF(MASWRK) WRITE(IW,*) 'END OF FILE READING REPULSION 2'
           CALL ABRT
        END IF
C
        TCLPR(II) = RFIND('TCLPR   ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'RDREP: ERORR READING TCLPR'
           CALL ABRT
        END IF
C
        TZLPR(II) = RFIND('TZLPR   ',IERR)
        IF(IERR.NE.0) THEN
           IF(MASWRK) WRITE(IW,*) 'RDREP: ERORR READING TZLPR'
           CALL ABRT
        END IF
        IF(TZLPR(II).EQ.ZERO) THEN
           IF(MASWRK) WRITE(IW,*) 'POWER PRECEEDS ZETA IN REP.POT.'
           CALL ABRT
        END IF
        INLPR(II) = IFIND('INLPR   ',IERR) + 2
  300 CONTINUE
      NPTS = NPTS + 1
      GO TO 100
C
  400 CONTINUE
      RETURN
 9000 FORMAT(1X,'ERROR IN READING REPULSIVE POINTS FOR FRAGMENT',I4,
     *          ' EXCEEDED MXPT=',I5)
      END
C*MODULE EFINP   *DECK RDDIS
      SUBROUTINE RDDIS(NPTS,N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000, MXIFRQ=12,MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME,DNAME,DPSNAM
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
C
      DATA ZERO/0.0D+00/
C
      IERR = 0
      IEOF = 0
      NPTS = 0
      JKFR(1) = 1
  100 CONTINUE
      K = NPTS+1
      IF(K.GT.MXPT) THEN
         IF(MASWRK) WRITE(IW,9000) N,MXPT
         CALL ABRT
      END IF
      CALL RDCARD('RDDIS   ',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      DNAME(K) = '        '
      LGSTR=-8
      CALL GSTRNG(DNAME(K),LGSTR)
      IF(DNAME(K).EQ.'STOP    ') GO TO 400
      DO 120 L = 1,NMPTS(N)
        IF(DNAME(K).EQ.MNAME(L)) GO TO 130
  120 CONTINUE
      GO TO 140
  130 CONTINUE
      DCORD(1,K) = CORD(1,L)
      DCORD(2,K) = CORD(2,L)
      DCORD(3,K) = CORD(3,L)
      GO TO 200
  140 CONTINUE
      DO 150 J=1,3
        DCORD(J,K) = RFIND('DCORD   ',IERR)
        IF(IERR.NE.0) CALL ABRT
  150 CONTINUE
C
C         -INLPR- IS AN UNDOCUMENTED OPTION TO ADD A POWER OF R
C         TO THE POTENTIAL, R**(INLPR+2).  THE CURRENT EFPS ALL
C         USE INLPR=0, HENCE IT IS NOT DOCUMENTED.
C
  200 CONTINUE
      NTERMS = IFIND('NTERM   ',IERR)
      IF(IERR.NE.0) CALL ABRT
      IF(K.NE.1) JKFR(K) = JKLR(K-1) + 1
      JKLR(K) = JKFR(K) + NTERMS - 1
      IFF = JKFR(K)
      ISS = JKLR(K)
      DO 300 II = IFF,ISS
        CALL RDCARD('RDDIS2  ',IEOF)
        IF(IEOF.EQ.1) CALL ABRT
        TCLPD(II) = RFIND('TCLPD   ',IERR)
        IF(IERR.NE.0) CALL ABRT
        TZLPD(II) = RFIND('TZLPD   ',IERR)
        IF(IERR.NE.0) CALL ABRT
        IF(TZLPD(II).EQ.ZERO) THEN
           IF(MASWRK) WRITE(IW,*) 'POWER PRECEEDS ZETA IN DIS.POT.'
           CALL ABRT
        END IF
        JNLPR(II) = IFIND('JNLPR   ',IERR) + 2
  300 CONTINUE
      NPTS = NPTS + 1
      GO TO 100
C
  400 CONTINUE
      RETURN
 9000 FORMAT(1X,'ERROR IN READING DISPERSION POINTS FOR FRAGMENT',I4,
     *          ' EXCEEDED MXPT=',I5)
      END
C
C*MODULE EFINP   *DECK RDSCRN
      SUBROUTINE RDSCRN(N,MODE)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12, MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME,DUMY
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      IERR = 0
      IEOF = 0
      NPTS = NMPTS(N)
  100 CONTINUE
      IF(MODE.EQ.1) THEN
         CALL RDCARD('RDSCRN  ',IEOF)
      ELSE
         CALL RDCARD('RDSCRN2 ',IEOF)
      ENDIF
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) 'END OF FILE READING SCREENING INPUT'
         CALL ABRT
      END IF
C
      DUMY='        '
      LGSTR=-8
      CALL GSTRNG(DUMY,LGSTR)
      IF(DUMY.EQ.'STOP    ') GO TO 400
      DO 200 J=1,NPTS
        IF(DUMY.EQ.MNAME(J)) THEN
          I=J
          GO TO 300
        END IF
  200 CONTINUE
      IF (MASWRK) WRITE(IW,9000) DUMY
      CALL ABRT
  300 CONTINUE
C
C         MODE=1 READS THE GAUSSIAN SCREENING FIT, QUANTUM/FRAGMENT,
C         MODE=2 READS THE EXPONENTIAL SCREENING, BETWEEN FRAGMENTS
C
      IF(MODE.EQ.1) THEN
         IF((IEFP2.EQ.1).AND.((IEFSCR.EQ.1).OR.(IEFSCR2.EQ.1))) THEN
           BMULTMP(I) = RFIND('AMULT   ',IERR)
           IF(IERR.NE.0) CALL ABRT
           AMULTMP(I) = RFIND('BMULT   ',IERR)
           IF(IERR.NE.0) CALL ABRT
         ELSE
           BMULT(I) = RFIND('AMULT   ',IERR)
           IF(IERR.NE.0) CALL ABRT
           AMULT(I) = RFIND('BMULT   ',IERR)
           IF(IERR.NE.0) CALL ABRT
         END IF
      ELSE
         IF((IEFP2.EQ.1).AND.((IEFSCR.EQ.1).OR.(IEFSCR2.EQ.1))) THEN
           BMULTMP2(I) = RFIND('AMULT2  ',IERR)
           IF(IERR.NE.0) CALL ABRT
           AMULTMP2(I) = RFIND('BMULT2  ',IERR)
           IF(IERR.NE.0) CALL ABRT
         ELSE
           BMULT2(I) = RFIND('AMULT2  ',IERR)
           IF(IERR.NE.0) CALL ABRT
           AMULT2(I) = RFIND('BMULT2  ',IERR)
           IF(IERR.NE.0) CALL ABRT
         END IF
      END IF
C
      GO TO 100
C
  400 CONTINUE
      RETURN
 9000 FORMAT(1X,'POINT ',A8,' HAS NOT BEEN GIVEN COORDINATES')
      END
C*MODULE EFINP   *DECK RDSTFR
      SUBROUTINE RDSTFR(FRGMNT,IFRAG,PROVEC,FOCKMA,CANVEC,
     *                  MXBF,NTAOF,MXMO,MXMO2,NTMOF,IFGTYP)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      PARAMETER (MXDFG=5, MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXAO=8192, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 FRGMNT
      CHARACTER*8 WORD,MNAME,PNAME,RNAME,DPNAME
      CHARACTER*80 TITLE
C
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      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
      DIMENSION PROVEC(MXBF,NTMOF),FOCKMA(MXMO2,NFRG),CANVEC(MXBF,NTAOF)
C
      NMPTS(IFRAG)=0
      NPPTS(IFRAG)=0
      NDPPTS(IFRAG)=0
      NRPTS(IFRAG)=0
      NDPTS(IFRAG)=0
C
C     INITIALIZE LOCAL COMMON BLOCK FRGSTD
C
      CALL VCLR(CORD(1,1),1,50*MXPT)
      DO 10 I=1,MXPT
         INLPR(4*(I-1)+1)=0
         INLPR(4*(I-1)+2)=0
         INLPR(4*(I-1)+3)=0
         INLPR(4*(I-1)+4)=0
         IKFR(I)=0
         IKLR(I)=0
         MNAME(I)='        '
         PNAME(I)='        '
         RNAME(I)='        '
   10 CONTINUE
C
      MXPTD=MXPT*MXIFRQ
      DO 11 I=1,MXPTD
         DPNAME(I)='        '
   11 CONTINUE
C
      IEOF=0
      CALL SEQREW(IR)
      CALL FNDGRP(IR,FRGMNT,IEOF)
      IF(IEOF.NE.0) THEN
         IF (MASWRK) WRITE(IW,9010) FRGMNT
         CALL ABRT
         RETURN
      END IF
C
      CALL RDCARD('$FRAG 1 ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,9011) FRGMNT
         CALL ABRT
      END IF
      TITLE=' '
      LGSTR=+80
      CALL GSTRNG(TITLE,LGSTR)
C
C ----- READ IN FRAGMENT INFORMATION -----
C
  200 CONTINUE
      CALL RDCARD('$FRAG 3 ',IEOF)
      IF(IEOF.EQ.1) THEN
         IF(MASWRK) WRITE(IW,9011) FRGMNT
         CALL ABRT
      END IF
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
C
      IF(WORD.NE.'COORDINA') GO TO 220
      CALL RDCRDX(CORD,FPMASS,FPNUC,MNAME,NMPTS(IFRAG),IFRAG)
      GO TO 200
C
  220 CONTINUE
      IF(WORD.NE.'MONOPOLE') GO TO 240
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDMONO(IFRAG)
      IEFC=1
      GO TO 200
C
  240 CONTINUE
      IF(WORD.NE.'SCREEN  ') GO TO 260
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDSCRN(IFRAG,1)
      ICHGP=1
      GO TO 200
C
  260 CONTINUE
      IF(WORD.NE.'SCREEN2  ') GO TO 270
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDSCRN(IFRAG,2)
      ICHGP=3
      GO TO 200
C
  270 CONTINUE
      IF(WORD.NE.'DIPOLES ') GO TO 280
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDDIPO(IFRAG)
      IEFD=1
      GO TO 200
C
  280 CONTINUE
      IF(WORD.NE.'QUADRUPO') GO TO 300
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDQUAD(IFRAG)
      IEFQ=1
      GO TO 200
C
  300 CONTINUE
      IF(WORD.NE.'OCTUPOLE') GO TO 320
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      CALL RDOCTU(IFRAG)
      IEFO=1
      GO TO 200
C
  320 CONTINUE
      IF(WORD.NE.'POLARIZA') GO TO 360
      CALL RDPTEN(NPPTS(IFRAG),IFRAG)
      IEFP=1
      GO TO 200
C
  360 CONTINUE
      IF(WORD.NE.'DYNAMIC ') GO TO 370
      CALL RDDPTEN(NDPPTS(IFRAG),IFRAG)
      IEFDP=1
      GO TO 200
C
C     READ THE POL. TENSOR DIFF. BETWEEN HF AND MP2 AT CENTER OF MASS
C     IEFP2: FLAG FOR MP2/EFP1
C
  370 CONTINUE
      IF(IFGTYP.EQ.1) THEN
       IEFP2=1
      ELSE
       IEFP2=0
      ENDIF
C
      IF(IEFP2.NE.1) GO TO 399
C
C     THE FOLLOWING WILL BE READ WHEN MP2/EFP1
C     IS RUNNING. EITHER HF/EFP1 OR DFT/EFP1
C     DOES NOT NEED IT.
C
      IF(WORD.NE.'POLARIZ2') GO TO 380
      CALL RDPTN2(NPPTS(IFRAG),IFRAG)
      GO TO 200
  380 CONTINUE
C
C     THE FOLLOWING PART WILL BE READ FROM
C     HF RESULTS SINCE THEY ARE REQUIRED TO
C     CALCULATE AND HF FIELD AND THE EPOL(HF)
C
      IF(WORD.NE.'MONOHF  ') GO TO 382
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      IEFMON=1
      CALL RDMONO(IFRAG)
      IEFMON=0
      IEFC=1
      GO TO 200
  382 CONTINUE
C
      IF(WORD.NE.'SCRHF   ') GO TO 384
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      IEFSCR=1
      CALL RDSCRN(IFRAG,1)
      IEFSCR=0
      ICHGP=1
      GO TO 200
  384 CONTINUE
C
      IF(WORD.NE.'SCRHF2  ') GO TO 386
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      IEFSCR2=1
      CALL RDSCRN(IFRAG,2)
      IEFSCR2=0
      ICHGP=3
      GO TO 200
  386 CONTINUE
C
      IF(WORD.NE.'DIPHF   ') GO TO 388
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      IEFDIP=1
      CALL RDDIPO(IFRAG)
      IEFDIP=0
      IEFD=1
      GO TO 200
  388 CONTINUE
C
      IF(WORD.NE.'QUADHF  ') GO TO 390
      IF(NMPTS(IFRAG).LE.0) GO TO 999
      IEFQUD=1
      CALL RDQUAD(IFRAG)
      IEFQUD=0
      IEFQ=1
      GO TO 200
  390 CONTINUE
C
      IF(WORD.NE.'DISPERSI') GO TO 392
      CALL RDDIS(NDPTS(IFRAG),IFRAG)
      GO TO 200
  392 CONTINUE
C
  399 CONTINUE
      IF(WORD.NE.'REPULSIV') GO TO 400
      CALL RDREP(NRPTS(IFRAG),IFRAG)
      IREP = 1
      GO TO 200
C
  400 CONTINUE
      IF(WORD.NE.'PROJECTI') GO TO 410
      WORD='        '
      LGSTR=-8
      CALL GSTRNG(WORD,LGSTR)
      IF(WORD.EQ.'BASIS   ')CALL RDPAO(IFRAG)
      IERR = 0
      IF(WORD.EQ.'WAVEFUNC') THEN
        NMOS = IFIND('NMOS    ',IERR)
        NAOS = IFIND('NAOS    ',IERR)
        CALL RDPMO(IFRAG,NMOS,NAOS,PROVEC,FOCKMA,
     *             MXBF,MXMO,MXMO2,NFRG,NTMOF)
      END IF
      GO TO 200
C
  410 CONTINUE
      IF(WORD.NE.'CANONVEC') GO TO 420
      NOCC(ISET(IFRAG)) = IFIND('NOCC    ',IERR)
      NAO(ISET(IFRAG))  = IFIND('NAOS    ',IERR)
      NVIR(ISET(IFRAG)) = NAO(ISET(IFRAG)) - NOCC(ISET(IFRAG))
      CALL RDCANV(IFRAG,CANVEC,MXBF,NTAOF)
      GO TO 200
C
  420 CONTINUE
      IF(WORD.EQ.'$END    ') RETURN
C
C     WE SHOULD NEVER GET HERE, ERROR
C
      IF (MASWRK) WRITE(IW,9020) WORD
      CALL ABRT
C
  999 CONTINUE
      IF (MASWRK) WRITE(IW,9100)
      CALL ABRT
C
      RETURN
 9010 FORMAT(1X,A8,'NOT FOUND, PLEASE CHECK FOR ERRORS')
 9011 FORMAT(1X,'ERROR, END OF FILE READING',A8,' INPUT GROUP')
 9020 FORMAT(1X,A8,' IS AN UNRECOGNIZED KEYWORD')
 9100 FORMAT(1X,'YOU MUST GIVE THE NUMBER OF POINTS TO BE READ IN BEFORE
     *       GIVING THE PERTINENT POINTS')
C
      END
C*MODULE EFINP   *DECK ROTMAT
      SUBROUTINE ROTMAT(A1,A2,A3,B1,B2,B3,C1,C2,C3,T)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.00D+00, ZERO = 0.00D+00)
C
      DIMENSION A(3), B(3), C(3), T(3,3)
C
      A(1)=A1
      A(2)=A2
      A(3)=A3
      B(1)=B1
      B(2)=B2
      B(3)=B3
      C(1)=C1
      C(2)=C2
      C(3)=C3
C
      T1NORM = ZERO
      T2NORM = ZERO
      DO 100 I=1,3
        T(I,1) = B(I) - A(I)
        T1NORM = T1NORM + T(I,1)*T(I,1)
        T(I,2) = C(I) - A(I)
        T2NORM = T2NORM + T(I,2)*T(I,2)
  100 CONTINUE
C
      T1NORM = ONE/SQRT(T1NORM)
      T2NORM = ONE/SQRT(T2NORM)
C
      DO 150 I = 1,3
        T(I,1) = T1NORM*T(I,1)
        T(I,2) = T2NORM*T(I,2)
  150 CONTINUE
C
      DOTPRD = T(1,1)*T(1,2) + T(2,1)*T(2,2) + T(3,1)*T(3,2)
      T(1,2) = T(1,2) - DOTPRD*T(1,1)
      T(2,2) = T(2,2) - DOTPRD*T(2,1)
      T(3,2) = T(3,2) - DOTPRD*T(3,1)
C
      T(1,3) = T(2,1)*T(3,2) - T(3,1)*T(2,2)
      T(2,3) = T(3,1)*T(1,2) - T(1,1)*T(3,2)
      T(3,3) = T(1,1)*T(2,2) - T(2,1)*T(1,2)
C
      DO 300 J = 1,3
        VECSQR = ZERO
        DO 200 I = 1,3
          VECSQR = VECSQR + T(I,J)*T(I,J)
  200   CONTINUE
        VECSQR = SQRT(VECSQR)
        DO 250 I = 1,3
          T(I,J) = T(I,J) / VECSQR
  250   CONTINUE
  300 CONTINUE
C
      RETURN
      END
C*MODULE EFINP   *DECK RELVC2
      SUBROUTINE RELVC2(R,J,K)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXATM=2000)
      PARAMETER (MXFRG=1050)
      DIMENSION R(3),XYZ1(3),XYZ2(3)
C
      CHARACTER*8 PTNAM
      CHARACTER*6 FRGNAM
C
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
      NATOMS = NAT
      IF (J.GT.NATOMS) THEN
         NFRG = (J-NATOMS)/3
         I123 = MOD(J-NATOMS,3)
         IF (I123.GT.0) THEN
            NFRG = NFRG + 1
         ELSE
            I123 = 3
         END IF
         XYZ1(1) = XCRD(I123,NFRG)
         XYZ1(2) = YCRD(I123,NFRG)
         XYZ1(3) = ZCRD(I123,NFRG)
      ELSE
         DO 20 I = 1,3
           XYZ1(I) = C(I,J)
  20     CONTINUE
      END IF
C
      IF (K.GT.NATOMS) THEN
        NFRG = (K-NATOMS)/3
        I123 = MOD(K-NATOMS,3)
        IF (I123.GT.0) THEN
           NFRG = NFRG + 1
        ELSE
           I123 = 3
        END IF
        XYZ2(1) = XCRD(I123,NFRG)
        XYZ2(2) = YCRD(I123,NFRG)
        XYZ2(3) = ZCRD(I123,NFRG)
      ELSE
        DO 40 I = 1,3
           XYZ2(I) = C(I,K)
   40   CONTINUE
      END IF
C
C     R IS THE RELATIVE VECTOR FROM ATOM K TO ATOM J
C
C---      WRITE(6,*) 'XYZ1',(XYZ1(JJ),JJ=1,3)
C---      WRITE(6,*) 'XYZ2',(XYZ2(JJ),JJ=1,3)
      DO 10 I=1,3
         R(I)=XYZ1(I)-XYZ2(I)
   10 CONTINUE
      RETURN
      END
C*MODULE EFINP   *DECK SPCEWA
      SUBROUTINE SPCEWA(IFRAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      PARAMETER (ZERO=0.0D+00,TWO=2.0D+00,
     *           ONE=1.00D+00, UNITS=ONE/0.52917724924D+00)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ,MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      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
      Q2AU = SQRT(ONE/1.11265D-10/4.3598D-18*1.602177D-19*
     *             1.602177D-19*UNITS/1.0D-10)
C
      IEFC = 1
      IEFD = 0
      IEFQ = 0
      IEFO = 0
      IEFP = 0
      IREP = 0
      NMPTS(IFRAG)=3
      NPPTS(IFRAG)=0
      NRPTS(IFRAG)=0
      NDPTS(IFRAG)=0
C
C     INITIALIZE LOCAL COMMON BLOCK FRGSTD
C
      CALL VCLR(CORD(1,1),1,50*MXPT)
      DO 10 I=1,MXPT
         INLPR(4*(I-1)+1)=0
         INLPR(4*(I-1)+2)=0
         INLPR(4*(I-1)+3)=0
         INLPR(4*(I-1)+4)=0
         IKFR(I)=0
         IKLR(I)=0
         MNAME(I)='        '
   10 CONTINUE
C
C COORDINATES (CHANGE TO AU WITH 'UNITS')
C
      MNAME(1) = 'ZO1     '
      FPMASS(1) = 15.9949146D+00
      MNAME(2) = 'ZH2     '
      FPMASS(2) = 1.007825D+00
      MNAME(3) = 'ZH3     '
      FPMASS(3) = 1.007825D+00
      TOTMA = FPMASS(1) + TWO*FPMASS(2)
      TOTMAI = 1.0D+00 / TOTMA
      ANG = ACOS(-1.0D+00/3.0D+00)
      ANG2 = ANG*0.5D+00
      RCMZ = 2.0D+00 * FPMASS(2) * COS(ANG2) * TOTMAI
C CHANGE COORDINATES TO BOHR (VS. ANG.)
      RHZ = (COS(ANG2) - RCMZ)*UNITS
      RHY = SIN(ANG2)*UNITS
      ROZ = RCMZ*UNITS
      CORD(1,1) = ZERO
      CORD(2,1) = ZERO
      CORD(3,1) = ROZ
      CORD(1,2) = ZERO
      CORD(2,2) = -RHY
      CORD(3,2) = -RHZ
      CORD(1,3) = ZERO
      CORD(2,3) = RHY
      CORD(3,3) = -RHZ
C CHARGES (ELECTRONIC UNITS)
C CHANGE CHARGE TO COULOMBS AND MULTIPLY IN SQRT(COULOMB FACTOR)
C IN AU
C THEREFORE, ACHG*ACHG UNITS = AU * BOHR
      ACHG(1,1) = -0.8476D+00*Q2AU
      ACHG(1,2) = 0.4238D+00*Q2AU
      ACHG(1,3) = 0.4238D+00*Q2AU
      RETURN
      END
C
C*MODULE EFINP   *DECK WATRHF
      SUBROUTINE WATRHF(IFRAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
C
      DIMENSION AREL(4,4,2),CREL(4,4,1)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO=0.0D+00)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ,MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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
      EQUIVALENCE (AREL(1,1,2),CREL(1,1,1))
C
C        STANDARD PARAMETERIZATION FOR WATER RHF EFP
C        THIS WAS OBTAINED LONG BEFORE RUNTY=MAKEFP, DOING STEP BY
C        STEP CALCULATIONS.  HENCE, THE POLARIZABITY DATA BELOW WERE
C        OBTAINED BY LOCAL=BOYS WITH $LOCAL POLNUM=.TRUE.  TODAY,
C        RUEDENBERG LOCALIZATION WITH ANALYTIC POLARIZABILITY DATA
C        GIVEN BY A QUICK RUNTYP=MAKEFP WOULD BE A BIT DIFFERENT.
C
      IEFC = 1
      IEFD = 1
      IEFQ = 1
      IEFO = 1
      IEFP = 1
      IREP = 1
      ICHGP= 1
      NMPTS(IFRAG)=8
      NPPTS(IFRAG)=5
      NRPTS(IFRAG)=3
      NDPTS(IFRAG)=0
C
C     INITIALIZE LOCAL COMMON BLOCK FRGSTD
C
      CALL VCLR(CORD(1,1),1,50*MXPT)
      DO 10 I=1,MXPT
         INLPR(4*(I-1)+1)=0
         INLPR(4*(I-1)+2)=0
         INLPR(4*(I-1)+3)=0
         INLPR(4*(I-1)+4)=0
         IKFR(I)=0
         IKLR(I)=0
         MNAME(I)='        '
         PNAME(I)='        '
         RNAME(I)='        '
         DOMTMP(I) =  .FALSE.
         DODTMP(I) =  .FALSE.
         DOQTMP(I) =  .FALSE.
         DOOTMP(I) =  .FALSE.
   10 CONTINUE
C
C COORDINATES
C
      MNAME(1) = 'ZO1     '
      CORD(1,1) = ZERO
      CORD(2,1) = ZERO
      CORD(3,1) = -.119151D+00
      FPMASS(1) = 15.99491D+00
      FPNUC(1) = 8.0D+00
      MNAME(2) = 'ZH2     '
      CORD(1,2) = -1.431042D+00
      CORD(2,2) = ZERO
      CORD(3,2) = .945510D+00
      FPMASS(2) = 1.007825D+00
      FPNUC(2) = 1.0D+00
      MNAME(3) = 'ZH3     '
      CORD(1,3) = 1.431042D+00
      CORD(2,3) = ZERO
      CORD(3,3) = .945510D+00
      FPMASS(3) = 1.007825D+00
      FPNUC(3) = 1.0D+00
      MNAME(4) = 'O1      '
      CORD(1,4) = ZERO
      CORD(2,4) = ZERO
      CORD(3,4) = -.119151D+00
      FPMASS(4) = ZERO
      FPNUC(4) = ZERO
      MNAME(5) = 'H2      '
      CORD(1,5) = -1.431042D+00
      CORD(2,5) = ZERO
      CORD(3,5) = .945510D+00
      FPMASS(5) = ZERO
      FPNUC(5) = ZERO
      MNAME(6) = 'H3      '
      CORD(1,6) = 1.431042D+00
      CORD(2,6) = ZERO
      CORD(3,6) = .945510D+00
      FPMASS(6) = ZERO
      FPNUC(6) = ZERO
      MNAME(7) = 'B12     '
      CORD(1,7) = -.715521D+00
      CORD(2,7) = ZERO
      CORD(3,7) = .413179D+00
      FPMASS(7) = ZERO
      FPNUC(7) = ZERO
      MNAME(8) = 'B13     '
      CORD(1,8) =  .715521D+00
      CORD(2,8) = ZERO
      CORD(3,8) =  .413179D+00
      FPMASS(8) = ZERO
      FPNUC(8) = ZERO
C CHARGES
      DOMTMP(1) = .TRUE.
      ACHG(1,1) = 8.0D+00
      ACHG(2,1) = ZERO
      DOMTMP(2) = .TRUE.
      ACHG(1,2) = 1.0D+00
      ACHG(2,2) = ZERO
      DOMTMP(3) = .TRUE.
      ACHG(1,3) = 1.0D+00
      ACHG(2,3) = ZERO
      DOMTMP(4) = .TRUE.
      ACHG(1,4) = -8.210827D+00
      ACHG(2,4) = ZERO
      DOMTMP(5) = .TRUE.
      ACHG(1,5) = -0.556652D+00
      ACHG(2,5) = ZERO
      DOMTMP(6) = .TRUE.
      ACHG(1,6) = -0.556652D+00
      ACHG(2,6) = ZERO
      DOMTMP(7) = .TRUE.
      ACHG(1,7) = -0.337934D+00
      ACHG(2,7) = ZERO
      DOMTMP(8) = .TRUE.
      ACHG(1,8) = -0.337934D+00
      ACHG(2,8) = ZERO
C DIPOLES
      DODTMP(4) = .TRUE.
      ADIP(1,4) = ZERO
      ADIP(2,4) = ZERO
      ADIP(3,4) = .435528D+00
      DODTMP(5) = .TRUE.
      ADIP(1,5) = -.053498D+00
      ADIP(2,5) = ZERO
      ADIP(3,5) = .026668D+00
      DODTMP(6) = .TRUE.
      ADIP(1,6) = .053498D+00
      ADIP(2,6) = ZERO
      ADIP(3,6) = .026668D+00
      DODTMP(7) = .TRUE.
      ADIP(1,7) = .145227D+00
      ADIP(2,7) = ZERO
      ADIP(3,7) = -.106534D+00
      DODTMP(8) = .TRUE.
      ADIP(1,8) = -.145227D+00
      ADIP(2,8) = ZERO
      ADIP(3,8) = -.106534D+00
C QUADRUPOLES
      DOQTMP(4) = .TRUE.
      AQAD(1,4) = -3.600378D+00
      AQAD(2,4) = -4.554786D+00
      AQAD(3,4) = -4.072824D+00
      AQAD(4,4) = ZERO
      AQAD(5,4) = ZERO
      AQAD(6,4) = ZERO
      DOQTMP(5) = .TRUE.
      AQAD(1,5) = -.273844D+00
      AQAD(2,5) = -.284801D+00
      AQAD(3,5) = -.273119D+00
      AQAD(4,5) = ZERO
      AQAD(5,5) = -.008071D+00
      AQAD(6,5) = ZERO
      DOQTMP(6) = .TRUE.
      AQAD(1,6) = -.273844D+00
      AQAD(2,6) = -.284801D+00
      AQAD(3,6) = -.273119D+00
      AQAD(4,6) = ZERO
      AQAD(5,6) = .008071D+00
      AQAD(6,6) = ZERO
      DOQTMP(7) = .TRUE.
      AQAD(1,7) = -.123332D+00
      AQAD(2,7) = -.156586D+00
      AQAD(3,7) = -.135104D+00
      AQAD(4,7) = ZERO
      AQAD(5,7) = -.012710D+00
      AQAD(6,7) = ZERO
      DOQTMP(8) = .TRUE.
      AQAD(1,8) = -.123332D+00
      AQAD(2,8) = -.156586D+00
      AQAD(3,8) = -.135104D+00
      AQAD(4,8) = ZERO
      AQAD(5,8) = .012710D+00
      AQAD(6,8) = ZERO
C OCTUPOLES
      DOOTMP(4) = .TRUE.
      AOCT(1,4) = ZERO
      AOCT(2,4) = ZERO
      AOCT(3,4) = 1.001522D+00
      AOCT(4,4) = ZERO
      AOCT(5,4) = .289430D+00
      AOCT(6,4) = ZERO
      AOCT(7,4) = .336875D+00
      AOCT(8,4) = ZERO
      AOCT(9,4) = ZERO
      AOCT(10,4) = ZERO
      DOOTMP(5) = .TRUE.
      AOCT(1,5) = -.050127D+00
      AOCT(2,5) = ZERO
      AOCT(3,5) = .018626D+00
      AOCT(4,5) = ZERO
      AOCT(5,5) = -.000173D+00
      AOCT(6,5) = -.020918D+00
      AOCT(7,5) = .008664D+00
      AOCT(8,5) = -.013564D+00
      AOCT(9,5) = ZERO
      AOCT(10,5) = ZERO
      DOOTMP(6) = .TRUE.
      AOCT(1,6) = .050127D+00
      AOCT(2,6) = ZERO
      AOCT(3,6) = .018626D+00
      AOCT(4,6) = ZERO
      AOCT(5,6) = -.000173D+00
      AOCT(6,6) = .020918D+00
      AOCT(7,6) = .008664D+00
      AOCT(8,6) = .013564D+00
      AOCT(9,6) = ZERO
      AOCT(10,6) = ZERO
      DOOTMP(7) = .TRUE.
      AOCT(1,7) = .442205D+00
      AOCT(2,7) = ZERO
      AOCT(3,7) = -.296631D+00
      AOCT(4,7) = ZERO
      AOCT(5,7) = -.097197D+00
      AOCT(6,7) = .145673D+00
      AOCT(7,7) = -.100224D+00
      AOCT(8,7) = .147545D+00
      AOCT(9,7) = ZERO
      AOCT(10,7) = ZERO
      DOOTMP(8) = .TRUE.
      AOCT(1,8) = -.442205D+00
      AOCT(2,8) = ZERO
      AOCT(3,8) = -.296631D+00
      AOCT(4,8) = ZERO
      AOCT(5,8) = -.097197D+00
      AOCT(6,8) = -.145673D+00
      AOCT(7,8) = -.100224D+00
      AOCT(8,8) = -.147545D+00
      AOCT(9,8) = ZERO
      AOCT(10,8) = ZERO
C SCREENING
      BMULT(1) = 3.171069D+00
      AMULT(1) = .307981D+00
      BMULT(2) = -.743555D+00
      AMULT(2) = .220351D+00
      BMULT(3) = -.743555D+00
      AMULT(3) = .220351D+00
      BMULT(4) = 3.063892D+00
      AMULT(4) = .308167D+00
      BMULT(5) = -1.501489D+00
      AMULT(5) = .233582D+00
      BMULT(6) = -1.501489D+00
      AMULT(6) = .233582D+00
      BMULT(7) = 1.990144D+00
      AMULT(7) = .440029D+00
      BMULT(8) = 1.990144D+00
      AMULT(8) = .440029D+00
C POLARIZABLE POINTS
      PNAME(1) ='LMO1    '
      PCORD(1,1) = ZERO
      PCORD(2,1) = ZERO
      PCORD(3,1) = -.118948D+00
      POLT(1,1) = 0.001372D+00
      POLT(2,1) = 0.001315D+00
      POLT(3,1) = 0.001555D+00
      POLT(4,1) = ZERO
      POLT(5,1) = ZERO
      POLT(6,1) = ZERO
      POLT(7,1) = ZERO
      POLT(8,1) = ZERO
      POLT(9,1) = ZERO
      PNAME(2) ='LMO2    '
      PCORD(1,2) = .761149D+00
      PCORD(2,2) = ZERO
      PCORD(3,2) = .486642D+00
      POLT(1,2) = 2.093639D+00
      POLT(2,2) = 0.786767D+00
      POLT(3,2) = 1.541635D+00
      POLT(4,2) = ZERO
      POLT(5,2) = 0.951176D+00
      POLT(6,2) = ZERO
      POLT(7,2) = ZERO
      POLT(8,2) = 1.315027D+00
      POLT(9,2) = ZERO
      PNAME(3) ='LMO3    '
      PCORD(1,3) = -.761149D+00
      PCORD(2,3) = ZERO
      PCORD(3,3) = .486642D+00
      POLT(1,3) = 2.093639D+00
      POLT(2,3) = 0.786767D+00
      POLT(3,3) = 1.541635D+00
      POLT(4,3) = ZERO
      POLT(5,3) = -0.951176D+00
      POLT(6,3) = ZERO
      POLT(7,3) = ZERO
      POLT(8,3) = -1.315027D+00
      POLT(9,3) = ZERO
      PNAME(4) ='LMO4    '
      PCORD(1,4) = ZERO
      PCORD(2,4) = -.489534D+00
      PCORD(3,4) = -.407726D+00
      POLT(1,4) = 1.386526D+00
      POLT(2,4) = 0.729779D+00
      POLT(3,4) = 1.052409D+00
      POLT(4,4) = ZERO
      POLT(5,4) = ZERO
      POLT(6,4) = 0.086979D+00
      POLT(7,4) = ZERO
      POLT(8,4) = ZERO
      POLT(9,4) = 0.655755D+00
      PNAME(5) ='LMO5    '
      PCORD(1,5) = ZERO
      PCORD(2,5) = .489534D+00
      PCORD(3,5) = -.407726D+00
      POLT(1,5) = 1.386526D+00
      POLT(2,5) = 0.729779D+00
      POLT(3,5) = 1.052409D+00
      POLT(4,5) = ZERO
      POLT(5,5) = ZERO
      POLT(6,5) = -0.086979D+00
      POLT(7,5) = ZERO
      POLT(8,5) = ZERO
      POLT(9,5) = -0.655755D+00
C AB INITIO/EFP REPULSIVE POTENTIAL
      RNAME(1) = MNAME(4)
      RCORD(1,1) = CORD(1,4)
      RCORD(2,1) = CORD(2,4)
      RCORD(3,1) = CORD(3,4)
      IKFR(1) = 1
      IKLR(1) = 2
      TCLPR(1) = -.00015658525D+00
      INLPR(1) = 2
      TZLPR(1) = .018861917D+00
      TCLPR(2) = 1.2469537D+00
      INLPR(2) = 2
      TZLPR(2) = .41985964D+00
      RNAME(2) = MNAME(5)
      RCORD(1,2) = CORD(1,5)
      RCORD(2,2) = CORD(2,5)
      RCORD(3,2) = CORD(3,5)
      IKFR(2) = 3
      IKLR(2) = 4
      TCLPR(3) = .00044035869D+00
      INLPR(3) = 2
      TZLPR(3) = .064324281D+00
      TCLPR(4) = .11725664D+00
      INLPR(4) = 2
      TZLPR(4) = .69632546D+00
      RNAME(3) = MNAME(6)
      RCORD(1,3) = CORD(1,6)
      RCORD(2,3) = CORD(2,6)
      RCORD(3,3) = CORD(3,6)
      IKFR(3) = 5
      IKLR(3) = 6
      TCLPR(5) = .00044035869D+00
      INLPR(5) = 2
      TZLPR(5) = .064324281D+00
      TCLPR(6) = .11725664D+00
      INLPR(6) = 2
      TZLPR(6) = .69632546D+00
C EFP/EFP REPULSIVE POTENTIAL
      CREL(1,1,1) = -24.269765D+00
      AREL(1,1,1) = 1.4362041D+00
      CREL(1,2,1) = 3.7022852D+00
      AREL(1,2,1) = 1.6618349D+00
      CREL(1,3,1) = 3.7022852D+00
      AREL(1,3,1) = 1.6618349D+00
      CREL(1,4,1) = 4.2645641D+00
      AREL(1,4,1) = 1.2578017D+00
      CREL(2,1,1) = 3.7022852D+00
      AREL(2,1,1) = 1.6618349D+00
      CREL(2,2,1) = 6.2316930D+00
      AREL(2,2,1) = 3.5264849D+00
      CREL(2,3,1) = 6.2316930D+00
      AREL(2,3,1) = 3.5264849D+00
      CREL(2,4,1) = -.42798437D+00
      AREL(2,4,1) = 1.1335629D+00
      CREL(3,1,1) = 3.7022852D+00
      AREL(3,1,1) = 1.6618349D+00
      CREL(3,2,1) = 6.2316930D+00
      AREL(3,3,1) = 3.5264849D+00
      CREL(3,3,1) = 6.2316930D+00
      CREL(3,4,1) = -.42798437D+00
      AREL(3,4,1) = 1.1335629D+00
      AREL(3,2,1) = 3.5264849D+00
      CREL(4,1,1) = 4.2645641D+00
      AREL(4,1,1) = 1.2578017D+00
      CREL(4,2,1) = -.42798437D+00
      AREL(4,2,1) = 1.1335629D+00
      CREL(4,3,1) = -.42798437D+00
      AREL(4,3,1) = 1.1335629D+00
      CREL(4,4,1) = 128.74969D+00
      AREL(4,4,1) = 1.8712451D+00
      CALL DAWRIT(IDAF,IODA,AREL,4*4*2,75,0)
C
      RETURN
      END
C*MODULE EFINP   *DECK WATDFT
      SUBROUTINE WATDFT(IFRAG)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DOMTMP,DODTMP,DOQTMP,DOOTMP
C
      DIMENSION AREL(4,4,2),CREL(4,4,1)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO=0.0D+00)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      COMMON /DOTMP / DOMTMP(MXPT),DODTMP(MXPT),DOQTMP(MXPT),
     *                DOOTMP(MXPT)
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ,MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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
      EQUIVALENCE (AREL(1,1,2),CREL(1,1,1))
C
C         IVANA ADAMOVIC'S EFP PARAMETERIZATION FOR DFT WATER
C         ADDED 11/25/2002
C
      IEFC = 1
      IEFD = 1
      IEFQ = 1
      IEFO = 1
      IEFP = 1
      IREP = 1
      ICHGP= 3
      NMPTS(IFRAG)=5
      NPPTS(IFRAG)=5
      NRPTS(IFRAG)=3
      NDPTS(IFRAG)=0
C
C     INITIALIZE LOCAL COMMON BLOCK FRGSTD
C
      CALL VCLR(CORD(1,1),1,50*MXPT)
      DO 10 I=1,MXPT
         INLPR(4*(I-1)+1)=0
         INLPR(4*(I-1)+2)=0
         INLPR(4*(I-1)+3)=0
         INLPR(4*(I-1)+4)=0
         IKFR(I)=0
         IKLR(I)=0
         MNAME(I)='        '
         PNAME(I)='        '
         RNAME(I)='        '
         DOMTMP(I) =  .FALSE.
         DODTMP(I) =  .FALSE.
         DOQTMP(I) =  .FALSE.
         DOOTMP(I) =  .FALSE.
   10 CONTINUE
C
C COORDINATES
C
      MNAME(1) = 'O1      '
      CORD(1,1) = ZERO
      CORD(2,1) = ZERO
      CORD(3,1) = -.119151D+00
      FPMASS(1) = 15.99491D+00
      FPNUC(1) = 8.0D+00
      MNAME(2) = 'H2      '
      CORD(1,2) = -1.431042D+00
      CORD(2,2) = ZERO
      CORD(3,2) = .945510D+00
      FPMASS(2) = 1.007825D+00
      FPNUC(2) = 1.0D+00
      MNAME(3) = 'H3      '
      CORD(1,3) = 1.431042D+00
      CORD(2,3) = ZERO
      CORD(3,3) = .945510D+00
      FPMASS(3) = 1.007825D+00
      FPNUC(3) = 1.0D+00
      MNAME(4) = 'B12     '
      CORD(1,4) = -.715521D+00
      CORD(2,4) = ZERO
      CORD(3,4) = .413179D+00
      FPMASS(4) = ZERO
      FPNUC(4) = ZERO
      MNAME(5) = 'B13     '
      CORD(1,5) =  .715521D+00
      CORD(2,5) = ZERO
      CORD(3,5) =  .413179D+00
      FPMASS(5) = ZERO
      FPNUC(5) = ZERO
C
C CHARGES
C
      DOMTMP(1) = .TRUE.
      ACHG(1,1) = -8.224578D+00
      ACHG(2,1) =  8.000000D+00
      DOMTMP(2) = .TRUE.
      ACHG(1,2) = -.579055D+00
      ACHG(2,2) =  1.00000D+00
      DOMTMP(3) = .TRUE.
      ACHG(1,3) = -.579055D+00
      ACHG(2,3) =  1.00000D+00
      DOMTMP(4) = .TRUE.
      ACHG(1,4) = -.308655D+00
      ACHG(2,4) = ZERO
      DOMTMP(5) = .TRUE.
      ACHG(1,5) = -.308655D+00
      ACHG(2,5) = ZERO
C
C DIPOLES
C
      DODTMP(1) = .TRUE.
      ADIP(1,1) = ZERO
      ADIP(2,1) = ZERO
      ADIP(3,1) = .439368D+00
      DODTMP(2) = .TRUE.
      ADIP(1,2) = -.045030D+00
      ADIP(2,2) = ZERO
      ADIP(3,2) = .019745D+00
      DODTMP(3) = .TRUE.
      ADIP(1,3) = .045030D+00
      ADIP(2,3) = ZERO
      ADIP(3,3) = .019745D+00
      DODTMP(4) = .TRUE.
      ADIP(1,4) = .151206D+00
      ADIP(2,4) = ZERO
      ADIP(3,4) = -.116204D+00
      DODTMP(5) = .TRUE.
      ADIP(1,5) = -.151206D+00
      ADIP(2,5) = ZERO
      ADIP(3,5) = -.116204D+00
C
C QUADRUPOLES
C
      DOQTMP(1) = .TRUE.
      AQAD(1,1) = -3.545741D+00
      AQAD(2,1) = -4.529667D+00
      AQAD(3,1) = -4.022426D+00
      AQAD(4,1) = ZERO
      AQAD(5,1) = ZERO
      AQAD(6,1) = ZERO
      DOQTMP(2) = .TRUE.
      AQAD(1,2) = -.305693D+00
      AQAD(2,2) = -.313535D+00
      AQAD(3,2) = -.304098D+00
      AQAD(4,2) = ZERO
      AQAD(5,2) =  -.005554D+00
      AQAD(6,2) = ZERO
      DOQTMP(3) = .TRUE.
      AQAD(1,3) = -.305693D+00
      AQAD(2,3) = -.313535D+00
      AQAD(3,3) = -.304098D+00
      AQAD(4,3) = ZERO
      AQAD(5,3) = .005554D+00
      AQAD(6,3) = ZERO
      DOQTMP(4) = .TRUE.
      AQAD(1,4) = -.096367D+00
      AQAD(2,4) = -.130668D+00
      AQAD(3,4) = -.106838D+00
      AQAD(4,4) = ZERO
      AQAD(5,4) = -.011666D+00
      AQAD(6,4) = ZERO
      DOQTMP(5) = .TRUE.
      AQAD(1,5) = -.096367D+00
      AQAD(2,5) = -.130668D+00
      AQAD(3,5) = -.106838D+00
      AQAD(4,5) = ZERO
      AQAD(5,5) = .011666D+00
      AQAD(6,5) = ZERO
C
C OCTUPOLES
C
      DOOTMP(1) = .TRUE.
      AOCT(1,1) = ZERO
      AOCT(2,1) = ZERO
      AOCT(3,1) = 1.073886D+00
      AOCT(4,1) = ZERO
      AOCT(5,1) = .313291D+00
      AOCT(6,1) = ZERO
      AOCT(7,1) = .360352D+00
      AOCT(8,1) = ZERO
      AOCT(9,1) = ZERO
      AOCT(10,1) = ZERO
      DOOTMP(2) = .TRUE.
      AOCT(1,2) = -.044409D+00
      AOCT(2,2) = ZERO
      AOCT(3,2) = .012008D+00
      AOCT(4,2) = ZERO
      AOCT(5,2) = -.000817D+00
      AOCT(6,2) = -.018142D+00
      AOCT(7,2) = .006012D+00
      AOCT(8,2) = -.012450D+00
      AOCT(9,2) = ZERO
      AOCT(10,2) = ZERO
      DOOTMP(3) = .TRUE.
      AOCT(1,3) = .044409D+00
      AOCT(2,3) = ZERO
      AOCT(3,3) = .012008D+00
      AOCT(4,3) = ZERO
      AOCT(5,3) = -.000817D+00
      AOCT(6,3) = .018142D+00
      AOCT(7,3) = .006012D+00
      AOCT(8,3) = .012450D+00
      AOCT(9,3) = ZERO
      AOCT(10,3) = ZERO
      DOOTMP(4) = .TRUE.
      AOCT(1,4) = .467428D+00
      AOCT(2,4) = ZERO
      AOCT(3,4) = -.336104D+00
      AOCT(4,4) = ZERO
      AOCT(5,4) = -.109886D+00
      AOCT(6,4) = .153403D+00
      AOCT(7,4) = -.113583D+00
      AOCT(8,4) = .156548D+00
      AOCT(9,4) = ZERO
      AOCT(10,4) = ZERO
      DOOTMP(5) = .TRUE.
      AOCT(1,5) = -.467428D+00
      AOCT(2,5) = ZERO
      AOCT(3,5) = -.336104D+00
      AOCT(4,5) = ZERO
      AOCT(5,5) = -.109886D+00
      AOCT(6,5) = -.153403D+00
      AOCT(7,5) = -.113583D+00
      AOCT(8,5) = -.156548D+00
      AOCT(9,5) = ZERO
      AOCT(10,5) = ZERO
C
C SCREENING
C
      BMULT(1) = .186119D+00
      AMULT(1) = .549105D+00
      BMULT(2) = .112182D+00
      AMULT(2) = .389541D+00
      BMULT(3) = .112182D+00
      AMULT(3) = .389541D+00
      BMULT(4) = -.717580D+00
      AMULT(4) = .962143D+00
      BMULT(5) = -.717580D+00
      AMULT(5) = .962143D+00
C
C SCREENING2
C
      BMULT2(1) = 1.000000D+00
      AMULT2(1) = 1.960183D+00
      BMULT2(2) = 1.000000D+00
      AMULT2(2) = 2.383508D+00
      BMULT2(3) = 1.000000D+00
      AMULT2(3) = 2.383508D+00
      BMULT2(4) = 1.000000D+00
      AMULT2(4) = 9.999913D+00
      BMULT2(5) = 1.000000D+00
      AMULT2(5) = 9.999913D+00
C
C POLARIZABLE POINTS
C
      PNAME(1) ='LMO1    '
      PCORD(1,1) = ZERO
      PCORD(2,1) = ZERO
      PCORD(3,1) = -.118741D+00
      POLT(1,1) = .003101D+00
      POLT(2,1) = .004553D+00
      POLT(3,1) = .002822D+00
      POLT(4,1) = ZERO
      POLT(5,1) = ZERO
      POLT(6,1) = ZERO
      POLT(7,1) = ZERO
      POLT(8,1) = ZERO
      POLT(9,1) = ZERO
      PNAME(2) ='LMO2    '
      PCORD(1,2) = .767899D+00
      PCORD(2,2) = ZERO
      PCORD(3,2) = .494658D+00
      POLT(1,2) = 2.109350D+00
      POLT(2,2) = .835171D+00
      POLT(3,2) = 1.556153D+00
      POLT(4,2) = ZERO
      POLT(5,2) = 1.313981D+00
      POLT(6,2) = ZERO
      POLT(7,2) = ZERO
      POLT(8,2) = .934523D+00
      POLT(9,2) = ZERO
      PNAME(3) ='LMO3    '
      PCORD(1,3) = -.767899D+00
      PCORD(2,3) = ZERO
      PCORD(3,3) = .494658D+00
      POLT(1,3) = 2.109350D+00
      POLT(2,3) = .835171D+00
      POLT(3,3) = 1.556153D+00
      POLT(4,3) = ZERO
      POLT(5,3) = -1.313981D+00
      POLT(6,3) = ZERO
      POLT(7,3) = ZERO
      POLT(8,3) = -.934523D+00
      POLT(9,3) = ZERO
      PNAME(4) ='LMO4    '
      PCORD(1,4) = ZERO
      PCORD(2,4) = -.492163D+00
      PCORD(3,4) = -.404375D+00
      POLT(1,4) = 1.519500D+00
      POLT(2,4) = .736181D+00
      POLT(3,4) = 1.183064D+00
      POLT(4,4) = ZERO
      POLT(5,4) = ZERO
      POLT(6,4) = .780917D+00
      POLT(7,4) = ZERO
      POLT(8,4) = ZERO
      POLT(9,4) = .089060D+00
      PNAME(5) ='LMO5    '
      PCORD(1,5) = ZERO
      PCORD(2,5) = .492163D+00
      PCORD(3,5) = -.404375D+00
      POLT(1,5) = 1.519500D+00
      POLT(2,5) = .736181D+00
      POLT(3,5) = 1.183064D+00
      POLT(4,5) = ZERO
      POLT(5,5) = ZERO
      POLT(6,5) = -.780917D+00
      POLT(7,5) = ZERO
      POLT(8,5) = ZERO
      POLT(9,5) = -.089060D+00
C
C AB INITIO/EFP REPULSIVE POTENTIAL
C
      RNAME(1) = MNAME(1)
      RCORD(1,1) = CORD(1,1)
      RCORD(2,1) = CORD(2,1)
      RCORD(3,1) = CORD(3,1)
      IKFR(1) = 1
      IKLR(1) = 2
      TCLPR(1) = -.0012471382D+00
      INLPR(1) = 2
      TZLPR(1) = .0761496713D+00
      TCLPR(2) = 17.1604999173D+00
      INLPR(2) = 2
      TZLPR(2) = .9999999904D+00
      RNAME(2) = MNAME(2)
      RCORD(1,2) = CORD(1,2)
      RCORD(2,2) = CORD(2,2)
      RCORD(3,2) = CORD(3,2)
      IKFR(2) = 3
      IKLR(2) = 4
      TCLPR(3) = -.0002488372D+00
      INLPR(3) = 2
      TZLPR(3) = .0949999961D+00
      TCLPR(4) = .1063437802D+00
      INLPR(4) = 2
      TZLPR(4) = .5999987638D+00
      RNAME(3) = MNAME(3)
      RCORD(1,3) = CORD(1,3)
      RCORD(2,3) = CORD(2,3)
      RCORD(3,3) = CORD(3,3)
      IKFR(3) = 5
      IKLR(3) = 6
      TCLPR(5) = -.0002488372D+00
      INLPR(5) = 2
      TZLPR(5) = .0949999961D+00
      TCLPR(6) = .1063437802D+00
      INLPR(6) = 2
      TZLPR(6) = .5999987638D+00
C
C EFP/EFP REPULSIVE POTENTIAL
C
      CREL(1,1,1) = -47.204255D+00
      AREL(1,1,1) = 1.502333D+00
      CREL(1,2,1) = 44.184769D+00
      AREL(1,2,1) = 2.731355D+00
      CREL(1,3,1) = 44.184769D+00
      AREL(1,3,1) = 2.731355D+00
      CREL(1,4,1) = 31.732616D+00
      AREL(1,4,1) = 1.518409D+00
      CREL(2,1,1) = 44.184769D+00
      AREL(2,1,1) = 2.731355D+00
      CREL(2,2,1) = .120699D+00
      AREL(2,2,1) = 1.315321D+00
      CREL(2,3,1) = .120699D+00
      AREL(2,3,1) = 1.315321D+00
      CREL(2,4,1) = -.061708D+00
      AREL(2,4,1) = .802301D+00
      CREL(3,1,1) = 44.184769D+00
      AREL(3,1,1) = 2.731355D+00
      CREL(3,2,1) = .120699D+00
      AREL(3,2,1) = 1.315321D+00
      CREL(3,3,1) = .120699D+00
      AREL(3,3,1) = 1.315321D+00
      CREL(3,4,1) = -.061708D+00
      AREL(3,4,1) = .802301D+00
      CREL(4,1,1) = 31.732616D+00
      AREL(4,1,1) = 1.518409D+00
      CREL(4,2,1) = -.061708D+00
      AREL(4,2,1) = .802301D+00
      CREL(4,3,1) = -.061708D+00
      AREL(4,3,1) = .802301D+00
      CREL(4,4,1) = 146.763464D+00
      AREL(4,4,1) = 2.083947D+00
C
      CALL DAWRIT(IDAF,IODA,AREL,4*4*2,75,0)
C
      RETURN
      END
C*MODULE EFINP   *DECK EFPX
      SUBROUTINE EFPX
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION MAKEFP
C
      LOGICAL GOPARR,DSKWRK,MASWRK,TESTJOB
C
      PARAMETER (MXATM=2000, MXAO=8192, MXIFRQ=12)
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,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
     *                MOOUTA(MXAO),MOOUTB(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PRPOPT/ ILOCAL
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      DATA MAKEFP/8HMAKEFP  /, NNAM/1/, QNAM/8HTEST    /, KQNAM/0/
      DATA RNONE/8HNONE    /,NONE/4HNONE/, RHF/8HRHF     /
C
C                  MAKEFP DRIVER:
C    DMA PERFORMED BEFORE RETURNING FROM ENERGX
C    POLDCM PERFORMED BEFORE RETURNING FROM LMOX
C    POLDYN PERFORMED BEFORE RETURNING FROM LMOX
C    PAULI PARAMETERS PRINTED OUT IN PAULIX
C    FINALLY, CHARGE PENETRATION TERM IS CALCULATED
C
C        TEST FOR VALIDITY OF A RUN, WITH AN UNDOCUMENTED BACK DOOR
C        TO PERMIT EXECUTION OF THIS RUNTYPE BY DEVELOPERS.
C
      TESTJOB = .FALSE.
      CALL NAMEIO(IR,JRET,MAKEFP,NNAM,QNAM,KQNAM,
     *            TESTJOB,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0)
C
      IF((SCFTYP.NE.RHF  .OR.  MPCTYP.NE.NONE  .OR.
     *   MPLEVL.GT.0     .OR.  CCTYP.NE.RNONE  .OR.
     *   CITYP.NE.RNONE  .OR.  DFTYPE.NE.RNONE)
     *  .AND.  (.NOT.TESTJOB)) THEN
         IF(MASWRK) WRITE(IW,9010)
     *        SCFTYP,MPCTYP,MPLEVL,DFTYPE,CITYP,CCTYP
         CALL ABRT
      END IF
 9010 FORMAT(1X,'RUNTYP=MAKEFP IS PROGRAMMED FOR SCFTYP=RHF,'/
     *       1X,'WITHOUT THE USE OF MOPAC OR ELECTRON CORRELATION,'/
     *       1X,'BUT YOUR JOB REQUESTS SCFTYP=',A8,' MPCTYP=',A4/
     *       1X,'AND/OR MPLEVL=',I4,' DFTTYP=',A8,
     *          ' CITYP=',A8,' CCTYP=',A8)
C
      CALL ENERGX
C
      CALL LMOX
      ILOCAL = 0
C
C ALLOCATE MEMORY
C
      LNA = NA - NOUTA
      LNA2 = (LNA*LNA+LNA)/2
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
      CALL VALFM(LOADFM)
      LVEC    = 1       + LOADFM
      LARRAY  = LVEC    + L1*NA
      LFMO    = LARRAY  + L2
      LCCHG   = LFMO    + LNA2
      LWRK2   = LCCHG   + 3*NA
      LDLPOL  = LWRK2   + L1
      LIDMYP  = LDLPOL  + 9*LNA
      LNNOPRT = LIDMYP  + L1
      LPOL    = LNNOPRT + L1
      LCANVEC = LPOL    + 9*LNA*MXIFRQ
      LCANFOK = LCANVEC + L3
      LAST    = LCANFOK + L2
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL PAULIX(X(LVEC),X(LARRAY),X(LFMO),X(LCCHG),X(LWRK2),
     *            X(LDLPOL),X(LIDMYP),X(LNNOPRT),X(LPOL),X(LCANVEC),
     *            X(LCANFOK),LNA,LNA2,L1,L2)
      CALL RETFM(NEED)
C
C        WALT STEVENS' FITTING CODE FOR CHARGE PENETRATION SCREENING
C
      CALL CGPX
C
C        ALL TERMS IN MAKEFP JOB ARE NOW COMPLETE, SO END THE $FRAGNAME.
C        THE MULTIPOLE EXPANSION THAT WAS USED BY THE CHARGE FITTING
C        SHOULD BE DISPOSED OF, AS IT ISN'T A COMPLETE $FRAGNAME FILE.
C
      IF(MASWRK) THEN
         WRITE(IP,9030)
         IDMP = 4
         CALL SEQCLO(IDMP,'DELETE')
      END IF
      RETURN
 9030 FORMAT(' $END')
      END
C*MODULE EFINP   *DECK PAULIX
      SUBROUTINE PAULIX(VEC,ARRAY,FMO,CCHG,WRK2,DLPOL,IDMYPT,NNOPRT,
     *                  POL,CANVEC,CANFOK,LNA,LNA2,L1,L2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,POLANG,
     *        POLAPP,KMIDPT,POLDYN,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXAO=8192,
     *           MXFGPT=12000)
      PARAMETER (NMO=500, MXMID=50)
      PARAMETER (TWO=2.0D+00)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /EFPPRT/ NOPRT(MXATM),MIDPRT(MXATM),NUMFFD(MXATM),
     *                INOPRT(2*MXATM),LSTGRP(20,MXATM+1),
     *                ISUM(20,MXFGPT),GRPSUM(20,4),NMDFFD
      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 /NOPOL / NOPATM(MXATM),KPOINT(MXMID),NODENS(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      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
      DOUBLE PRECISION LABEL(6), XYZP(3), NUMCOR(103)
      DIMENSION VEC(L1,NA), ARRAY(L2), FMO(LNA2), CCHG(3,LNA),
     *          WRK2(L1), DLPOL(9,LNA), IDMYPT(L1), NNOPRT(L1),
     *          POL(9,LNA,NDPFREQ)
      DIMENSION CANVEC(L1*L1), CANFOK(L2)
C
      DATA LABEL/8HS       ,8HP       ,8HD       ,8HF       ,
     *           8HG       ,8HL       /
      DATA NUMCOR/2*0,
     *            2*1,                  6*1,
     *            2*5,                  6*5,
     *            2*9,          10*9,   6*14,
     *            2*18,         10*18,  6*23,
     *            2*27,  14*27, 10*34,  6*39,
     *            2*43,  14*43,    50/
      DATA CHECK/8HCHECK   /
C
      MCORE = NA - LNA
C
      CALL STONE
C
C GET LMOS
C
      CALL DAREAD(IDAF,IODA,VEC,L1*NA,71,0)
      IF (MCORE.GT.0) THEN
         DO I = 1,LNA
            CALL DCOPY(L1,VEC(1,MCORE+I),1,VEC(1,I),1)
         END DO
      END IF
C
C    FILL XYZP
C
      XYZP(1) = XP
      XYZP(2) = YP
      XYZP(3) = ZP
C
C   CALCULATE CENTROIDS OF CHARGE
C
      DO I = 1,3
         IF(EXETYP.NE.CHECK) CALL DAREAD(IDAF,IODA,ARRAY,L2,94+I,0)
         DO J = 1,LNA
            IF(EXETYP.NE.CHECK) THEN
               CALL TFTRI(CCHG(I,J),ARRAY,VEC(1,J),WRK2,1,L1,L1)
            ELSE
               CCHG(I,J) = 0.0D+00
            END IF
            CCHG(I,J) = CCHG(I,J) + XYZP(I)
         END DO
      END DO
C
      IF(EXETYP.NE.CHECK) THEN
         CALL DAREAD(IDAF,IODA,DLPOL,LNA*9,251,0)
      ELSE
         CALL VCLR(DLPOL,1,LNA*9)
      END IF
      IF(MASWRK) WRITE(IP,*) 'POLARIZABLE POINTS'
C
C   1. IF FIRST FEW MO-S IN THE QM/MM BUFFER ARE SPECIFIED BY NBUFFM,
C   THEY SHOULD BE SKIPPED IN THE PUNCH OUT ... AND THEY ARE SKIPPED
C   ANYWAY WHEN THE DEFAULT NOUTA=N, WHERE NO. OF BUFFER ORBITALS, IS
C   USED.
C   2. ALSO BY DEFAULT SKIP POLARIZABILITIES NEIGHBORING TO THE BUFFER
C   ATOMS (NONEAR=1) BASED ON THE FOLLOWING CRITERION: DOES
C   POLARIZABILITY UNDER QUESTION CORRESPOND TO A BOND CONNECTED TO A
C   BUFFER ATOM? -TO ACTIVATE 2. UNCOMMENT NONEAR=1
C
      LBF=0
      NONEAR=0
CCC      NONEAR=1
C
C  WHICH ATOMS ARE IN THE BUFFER? NOTE THAT
C  WE ASSUME THERE IS ONE LUMP POLARIZABILITY FOR BUFFER MO-S
C  AND THE BUFFER ATOMS ARE FIRST IN $DATA
C
      IF(NBUFFM.GT.0) THEN
C        IF(NA-NBUFFM.NE.LNA) THEN
C           IF(MASWRK) WRITE(IW,*) 'INCONSISTENCY: NUMBER OF BUFFER ',
C     *                         'MOS PLUS NUMBER OF POL. POINTS ',
C     *                         'IS NOT EQUAL TO NUMBER OF ORBITALS'
C           CALL ABRT
C        END IF
        MINBFA=1
        MAXBFA=1
        DO 150 I=1,NBUFFM
           JMAX=NMOAT(I)
           MINBFA=MIN(MINBFA,MOIDNO(1,I))
           MAXBFA=MAX(MAXBFA,MOIDNO(JMAX,I))
 150    CONTINUE
        IF(MASWRK) WRITE(IW,9500) NBUFFM
        IF(MINBFA.NE.1) THEN
           IF(MASWRK) WRITE(IW,9600) MINBFA
           CALL ABRT
        END IF
        LBF=MAXBFA
        IF(MASWRK) WRITE(IW,9520) LBF
      END IF
C
C IDENTIFY LMOS BELONGING TO THE OVERLAPPING REGION
C
      CALL VICLR(IDMYPT,1,NMO)
      INDPOL=0
      DO 160 IPOL=1,LNA
         ILMO=IPOL + MCORE
         MPOL=0
         DO 170 JAT=1,MXATM
            JMAX=NMOAT(ILMO)
            IF (JMAX.EQ.1) THEN
C PABLO CHANGE NODENS INSTEAD OF NOPATM
               IF (NODENS(JAT).EQ.MOIDNO(1,ILMO)) MPOL=1
C              IF (NOPATM(JAT).EQ.MOIDNO(1,ILMO)) MPOL=1
            END IF
C PABLO
C IDENTIFY LMOS BELONGING TO LONE PAIRS OF THE KPOINT ATOM IF
C KMIDPT IS TRUE
            IF((JMAX.EQ.1).AND.KMIDPT) THEN
               IF (KPOINT(JAT).EQ.MOIDNO(1,ILMO)) MPOL=1
            END IF
            IF (JMAX.EQ.2) THEN
               IF ((NODENS(JAT).EQ.MOIDNO(1,ILMO)) .OR.
     *            (NODENS(JAT).EQ.MOIDNO(2,ILMO))) MPOL=1
            END IF
C           IF (JMAX.EQ.2) THEN
C              IF ((NOPATM(JAT).EQ.MOIDNO(1,ILMO)) .OR.
C    *            (NOPATM(JAT).EQ.MOIDNO(2,ILMO))) MPOL=1
C           END IF
  170    CONTINUE
         IF(MPOL.EQ.1) THEN
         INDPOL=INDPOL+1
         IDMYPT(INDPOL)=IPOL
         END IF
  160 CONTINUE
      NUMPOL=INDPOL
      IF(MASWRK.AND.NUMPOL.GT.0) THEN
         WRITE(IW,*) 'ACCORDING TO THE INFORMATION IN $LOCAL'
         WRITE(IW,9510) NUMPOL,(IDMYPT(INDPOL),INDPOL=1,NUMPOL)
      END IF
C
C         IDENTIFY LMOS BELONGING TO THE OVERLAPPING REGION
C         ACCORDING TO THE INFORMATION PROVIDED IN NOPRT(I)
C         AND MIDPRT(I)
C
      CALL VICLR(NNOPRT,1,L1)
      INDPOL=0
      DO 260 IPOL=1,LNA
         ILMO=IPOL + MCORE
         MPOL=0
         DO 270 JAT=1,MXATM
            JMAX=NMOAT(ILMO)
            IF (JMAX.EQ.1) THEN
               IF (NOPRT(JAT).EQ.MOIDNO(1,ILMO)) MPOL=1
            END IF
            IF (JMAX.EQ.2) THEN
               IF ((NOPRT(JAT).EQ.MOIDNO(1,ILMO).OR.
     *              NOPRT(JAT).EQ.MOIDNO(2,ILMO)    ).AND.
     *             (MIDPRT(JAT).NE.MOIDNO(1,ILMO).AND.
     *              MIDPRT(JAT).NE.MOIDNO(2,ILMO)         ))
     *                         MPOL=1
            END IF
  270    CONTINUE
         IF(MPOL.EQ.1) THEN
         INDPOL=INDPOL+1
         NNOPRT(INDPOL)=IPOL
         END IF
  260 CONTINUE
      NUMPOL=INDPOL
      IF(MASWRK.AND.NUMPOL.GT.0) THEN
         WRITE(IW,*) 'ACCORDING TO THE INFORMATION IN $PRTEFP'
         WRITE(IW,9510) NUMPOL,(NNOPRT(INDPOL),INDPOL=1,NUMPOL)
         WRITE(IW,*) ' '
      END IF
C
C     PUNCH OUT POLARIZABLE POINTS
C
      II=0
      DO 200 I = 1,LNA
         NEIGH=0
         IF(NONEAR.EQ.1 .AND. LBF.GT.0) THEN
C        DECIDE IF THE I-TH MO IS 'NEIGHBORING' TO THE BUFFER
            ILMO=I+NBUFFM
            JMAX=NMOAT(ILMO)
            MINAT=MOIDNO(1,ILMO)
            IF(MINAT .LE. LBF) NEIGH=1
            IF(NEIGH.EQ.1 .AND. MASWRK) THEN
              IF(JMAX.EQ.1) WRITE(IW,9541) ILMO,MOIDNO(1,ILMO)
              IF(JMAX.EQ.2) WRITE(IW,9542) ILMO,(MOIDNO(IX,ILMO),IX=1,2)
              IF(JMAX.EQ.3) WRITE(IW,9543) ILMO,(MOIDNO(IX,ILMO),IX=1,3)
              IF(JMAX.EQ.4) WRITE(IW,9544) ILMO,(MOIDNO(IX,ILMO),IX=1,4)
              IF(JMAX.EQ.5) WRITE(IW,9545) ILMO,(MOIDNO(IX,ILMO),IX=1,5)
            END IF
         END IF
         IF(NEIGH.EQ.1) GO TO 200
         IF(NEIGH.NE.1) II=II+1
C
C CHECK FOR POLARIZ. POINT THAT SHOULD BE REMOVED
C
         DO 205 ICHK=1,NUMPOL
            IF(I.EQ.IDMYPT(ICHK)) GO TO 200
            IF(I.EQ.NNOPRT(ICHK)) GO TO 200
 205     CONTINUE
         IF(MASWRK) THEN
            IF (II.LT.10) WRITE(IP,9301) II,(CCHG(J,I),J=1,3)
            IF (II.GE.10 .AND. II.LT.100)
     *                    WRITE(IP,9302) II,(CCHG(J,I),J=1,3)
            IF (II.GE.100) WRITE(IP,9303) II,(CCHG(J,I),J=1,3)
            WRITE(IP,9250) DLPOL(1,I),DLPOL(5,I),DLPOL(9,I),DLPOL(2,I),
     *                     DLPOL(3,I),DLPOL(6,I),DLPOL(4,I),DLPOL(7,I),
     *                     DLPOL(8,I)
         END IF
 200  CONTINUE
      IF(MASWRK) WRITE(IP,9111)
C
C        OUTPUT THE DYNAMIC POLARIZABILITY TERM OF THE EFP
C
      IF(POLDYN) THEN
         IF(EXETYP.NE.CHECK) THEN
            CALL DAREAD(IDAF,IODA,POL,LNA*9*NDPFREQ,401,0)
         ELSE
            CALL VCLR(POL,1,LNA*9*NDPFREQ)
         END IF
         IF(MASWRK) WRITE(IP,*) 'DYNAMIC POLARIZABLE POINTS'
         DO K = 1,NDPFREQ
            II = 0
            DO I = 1,LNA
               II = II+I
               IF(MASWRK) THEN
                  IF(I.EQ.1) THEN
                     WRITE(IP,9304) I,(CCHG(J,I),J=1,3),DPFREQ(K)
                  ELSE
                     WRITE(IP,9303) I,(CCHG(J,I),J=1,3)
                  END IF
                  WRITE(IP,9250) POL(1,I,K), POL(5,I,K), POL(9,I,K),
     *                           POL(2,I,K), POL(3,I,K), POL(6,I,K),
     *                           POL(4,I,K), POL(7,I,K), POL(8,I,K)
               END IF
            ENDDO
         ENDDO
         IF(MASWRK) WRITE(IP,9111)
      ENDIF
C
C  PRINT AO INFORMATION
C
      IF(MASWRK) WRITE(IP,8000)
      N = 0
      LASTAT=0
      DO 120 II = 1,NSHELL
         IAT = KATOM(II)
         J = INT(ZAN(IAT))
         I1 = KSTART(II)
         I2 = I1+KNG(II)-1
         NBFS = KMAX(II) - KMIN(II) + 1
         IF (NBFS.EQ.1) ITYP = 1
         IF (NBFS.EQ.3) ITYP = 2
         IF (NBFS.EQ.6) ITYP = 3
         IF (NBFS.EQ.10)ITYP = 4
         IF (NBFS.EQ.15)ITYP = 5
         IF (NBFS.EQ.4) ITYP = 6
         IF (LASTAT.NE.IAT) THEN
            IF (MASWRK  .AND.  IAT.NE.1) WRITE(IP,*) ' '
            ZNUC = ZAN(IAT)
            IZ = INT(ZAN(IAT)) + IZCORE(IAT)
            IF (MCORE.GT.0) ZNUC = ZNUC - TWO*NUMCOR(IZ)
            IF(MASWRK) WRITE(IP,9000) ANAM(IAT),BNAM(IAT),
     *                                (C(J,IAT),J=1,3),ZNUC
         END IF
         IF(MASWRK) WRITE(IP,9050) LABEL(ITYP),(I2-I1+1)
         DO 110 IG = I1,I2
            N = N+1
            IF(ITYP.EQ.1) C1 = CS(IG)
            IF(ITYP.EQ.2) C1 = CP(IG)
            IF(ITYP.EQ.3) C1 = CD(IG)
            IF(ITYP.EQ.4) C1 = CF(IG)
            IF(ITYP.EQ.5) C1 = CG(IG)
            IF(ITYP.EQ.6) C1 = CS(IG)
            IF(ITYP.EQ.6) C2 = CP(IG)
            IF (MASWRK  .AND.  ITYP.LE.5) WRITE(IP,9100) IG,EX(IG),C1
            IF (MASWRK  .AND.  ITYP.EQ.6) WRITE(IP,9100) IG,EX(IG),C1,C2
  110    CONTINUE
         LASTAT=IAT
  120 CONTINUE
      IF(MASWRK) THEN
         WRITE(IP,*) ' '
         WRITE(IP,9111)
      END IF
C
C  PRINT MO INFORMATION
C
      IF(MASWRK) WRITE(IP,9200) LNA, L1
      CALL PUSQL(VEC,LNA,L1,L1)
C
C  OBTAIN FOCK MATRIX IN THE LMO BASIS AND PRINT OUT
C
      IF(EXETYP.NE.CHECK) THEN
         CALL DAREAD(IDAF,IODA,ARRAY,L2,14,0)
         CALL TFTRI(FMO,ARRAY,VEC,WRK2,LNA,L1,L1)
      ELSE
         CALL VCLR(FMO,1,LNA2)
      END IF
      IF(MASWRK) THEN
         WRITE(IP,*) 'FOCK MATRIX ELEMENTS'
         WRITE(IP,9250) (FMO(I),I=1,LNA2)
      END IF
C
      IF(MASWRK) THEN
         WRITE(IP,*) 'LMO CENTROIDS'
         DO I=1,LNA
            IF (I.LT.10)  WRITE(IP,9301) I,(CCHG(J,I),J=1,3)
            IF (I.GE.10 .AND. I.LT.100)
     *                    WRITE(IP,9302) I,(CCHG(J,I),J=1,3)
            IF (I.GE.100) WRITE(IP,9303) I,(CCHG(J,I),J=1,3)
         END DO
         WRITE(IP,9111)
      END IF
C
C  PRINT OUT WAVEFUNCTION (IN AO BASIS)
C
      CALL DAREAD(IDAF,IODA,CANVEC,L1*L1,15,0)
      IF(MASWRK) WRITE(IP,*) 'CANONVEC ',NA,' ',L1
      CALL PUSQL(CANVEC,L1,L1,L1)
C
C  PRINT OUT FOCK MATRIX (IN MO BASIS)
C
      IF(EXETYP.NE.CHECK) THEN
         CALL DAREAD(IDAF,IODA,ARRAY,L2,14,0)
         CALL TFTRI(CANFOK,ARRAY,CANVEC,WRK2,L1,L1,L1)
      END IF
      IF(MASWRK) THEN
         WRITE(IP,*) 'CANONFOK'
         WRITE(IP,9250)(CANFOK(I*(I+1)/2),I=1,L1)
         WRITE(IP,9111)
      END IF
C
      CALL FLSHBF(IP)
      RETURN
C
 8000 FORMAT(1X,'PROJECTION BASIS SET')
 9000 FORMAT(A8,A2,3F15.10,1X,F6.1)
 9050 FORMAT(3X,A8,I4)
 9100 FORMAT(3X,I3,1X,F20.10,2F12.8)
 9111 FORMAT(1X,'STOP')
 9200 FORMAT(1X,'PROJECTION WAVEFUNCTION',1X,I4,I4)
 9250 FORMAT(4(1X,F15.10),' >')
 9301 FORMAT('CT',I1,3F15.10)
 9302 FORMAT('CT',I2,3F15.10)
 9303 FORMAT('CT',I3,3F15.10)
 9304 FORMAT('CT',I3,3F15.10,' -- FOR W=',F9.6,'I A.U.')
 9500 FORMAT(/1X,'NUMBER OF BUFFER MO-S IS ',I4)
 9510 FORMAT(1X,'THE NUMBER OF POLARIZ. POINTS TO BE REMOVED IS',
     *       I5,/3X,'THEIR NUMBERS ARE:',(10I3))
 9520 FORMAT(1X,'NUMBER OF ATOMS IN THE BUFFER IS ',I5)
 9541 FORMAT(I5,'TH LMO CENTERED ON ATOM ',I5,
     *          ' IS EXCLUDED FROM THE LIST OF POLARIZABILITIES')
 9542 FORMAT(I5,'TH LMO CENTERED ON ATOMS ',I5,' AND ',I5,
     *          ' IS EXCLUDED FROM THE LIST OF POLARIZABILITIES')
 9543 FORMAT(I5,'TH LMO CENTERED ON ATOMS ',I5,' , ',I5,' AND ',I5,
     *          ' IS EXCLUDED FROM THE LIST OF POLARIZABILITIES')
 9544 FORMAT(I5,'TH LMO CENTERED ON ATOMS ',I5,' , ',I5,' , ',I5,
     * ' AND ',I5,' IS EXCLUDED FROM THE LIST OF POLARIZABILITIES')
 9545 FORMAT(I5,'TH LMO CENTERED ON ATOMS ',I5,' , ',I5,' , ',I5,
     *        ' , ',I5,' AND ',I5,
     *        ' IS EXCLUDED FROM THE LIST OF POLARIZABILITIES')
 9600 FORMAT(1X,'THE FIRST BUFFER ATOM IS NOT THE FIRST ATOM '/
     *       1X,'IN $DATA  (BUT #',I5,')')
      END
C*MODULE EFINP   *DECK PREFIN
      SUBROUTINE PREFIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION MAKEFP
C
      PARAMETER (MXATM=2000, MXFGPT=12000)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /EFPPRT/ NOPRT(MXATM),MIDPRT(MXATM),NUMFFD(MXATM),
     *                INOPRT(2*MXATM),LSTGRP(20,MXATM+1),
     *                ISUM(20,MXFGPT),GRPSUM(20,4),NMDFFD
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (NNAM=3)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA PRTEFP/8HPRTEFP  /, MAKEFP/8HMAKEFP   /
      DATA QNAM /8HNOPRT   ,8HMIDPRT  ,8HNUMFFD  /
      DATA KQNAM/-1,-1,-1/
C
      KQNAM(1)=10*MXATM+1
      KQNAM(2)=10*MXATM+1
      KQNAM(3)=10*MXATM+1
C
C     NOPRT : ATOMS WITH WHICH ALL MULTIPLE EXPANSION POINTS
C             AND POLARIZABLE POINTS ASSOCIATED WILL NOT
C             BE PRINTED/PUNCHED OUT
C
C     MIDPRT: ATOMS WITH WHICH ALL MIDDLE POINTS (BONDS)
C             ASSOCIATED WILL AND MUST BE PRINTED/PUNCHED OUT.
C             THIS RANKS OVER NOPRT.
C
C     NUMFFD: ARRAY WITH THE FIRST POSITIVE NUMBER BEING THE ATOM
C             CONNECTS THE FORCE FIELD PART, I.E. THE END OF
C             THE EFP. THE SECOND NUMBER TELLS HOW MANY ATOMS
C             ARE IN THE FORCE FIELD PART THAT WILL NOT BE
C             PRINTED OUT AS INDICATED IN NOPRT(I). THE REST ARE
C             THE ATOMS OF THE FORCE FIELD PART.
C             IF THERE ARE MORE THAN ONE CONNECTION ATOM, THEN
C             REPEAT ABOVE.
C
      DO I = 1, MXATM
        NOPRT(I)  = -1
        MIDPRT(I) = -1
        NUMFFD(I) = -1
      ENDDO
      DO I = 1, 2*MXATM
        INOPRT(I) = -1
      ENDDO
      DO I = 1, 20
        DO J1 = 1, MXATM+1
          LSTGRP(I,J1) = -1
        ENDDO
        DO J2 = 1, MXFGPT
          ISUM(I,J2)   = -1
        ENDDO
        DO J3 = 1, 4
          GRPSUM(I,J3) = 0.0D+00
        ENDDO
      ENDDO
      NMDFFD = 0
C
      IF(RUNTYP.NE.MAKEFP) RETURN
C
C     READ THE PRTEFP NAMELIST
C
      JRET=0
      CALL NAMEIO(IR,JRET,PRTEFP,NNAM,QNAM,KQNAM,
     *            NOPRT,MIDPRT,NUMFFD,
     *            0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0)
      IF(JRET.EQ.2) THEN
         IF(MASWRK) WRITE(IW,*) '**** ERROR IN $PRTEFP INPUT'
         CALL ABRT
      END IF
C
C         FIND THE GROUP ATTACHED TO THE ATOMS DEFINED IN NUMFFD(I)
C         THIS GROUP IS OR IS AMONG THE GROUPS DEFINED IN NOPRT(I)
C         THE GROUP'S EFP CHARGES(MONOPOLES) WILL BE COLLECTED AND
C         ADDED TO THE ATOM OR THE MIDPOINT DEFINED IN NUMFFD(I),
C         SO AN INTEGER CHARGE IS ASSIGNED TO THE EFP GENERATED.
C         IF THE MIDPOINT WILL BE PRINTED OUT,
C         THE CHARGE GOES TO THE MIDPOINT.
C         IF THE MIDPOINT WILL NOT BE PRINTED OUT,
C         THE CHARGE GOES TO THE ATOM.
C
       DO I =1, MXATM
         IF(NUMFFD(I).GT.0) THEN
                J = I
 200            NMDFFD = NMDFFD + 1
                IF(NMDFFD.GT.20) THEN
                  IF(MASWRK) WRITE(IW,*)
     *              ' ERROR: NMDFFD MORE THAN',20
                  CALL ABRT
                END IF
                LSTGRP(NMDFFD,1) = NUMFFD(J)
                IF(NUMFFD(J+1).GT.0) THEN
                  LSTGRP(NMDFFD,2) = NUMFFD(J+1)
                  DO K = J+2, J+1+NUMFFD(J+1)
                    IF(NUMFFD(K).GT.0) THEN
                      LSTGRP(NMDFFD,K-J+1)=NUMFFD(K)
                    ELSE
                      IF(MASWRK) WRITE(IW,*)
     *                  ' ERROR: NUMFFD(',K,') IS EMPTY'
                      CALL ABRT
                    END IF
                  ENDDO
                  IF(NUMFFD(J+2+NUMFFD(J+1)).GT.0) THEN
                    J = J + 2 + NUMFFD(J+1)
                    GO TO 200
                  END IF
                  GO TO 300
                ELSE
                  IF(MASWRK) WRITE(IW,*)
     *              ' ERROR: NUMFFD(',J+1,') IS EMPTY'
                  CALL ABRT
                END IF
         END IF
      ENDDO
C
C     PRINT MESSAGE
C
 300  CONTINUE
      DO I =1, MXATM
         IF(MIDPRT(I).GT.0 .OR.
     *       NOPRT(I).GT.0     ) THEN
           IF(MASWRK) WRITE(IW,*) ' '
           IF(MASWRK) WRITE(IW,*) '$PRTEFP INPUT IS EFFECTIVE...'
           IF(MASWRK) WRITE(IW,*)
     *'SOME EXPANSION AND POLARIZABLE POINTS WILL NOT',
     *' BE PRINTED/PUNCHED OUT.'
           GO TO 400
         END IF
      ENDDO
C
 400  CONTINUE
      IF(NMDFFD.GT.0) THEN
        IF(MASWRK) THEN
           WRITE(IW,9100)
           DO I = 1, NMDFFD
             WRITE(IW,'(A,I5,A/18I5)')
     *         ' CONNECTION ATOM',LSTGRP(I,1),
     *         ' COLLECTS THE CHARGES ON ATOMS:',
     *          (LSTGRP(I,J),J=3,2+LSTGRP(I,2))
           ENDDO
        END IF
      END IF
      RETURN
C
 9100 FORMAT(1X,'EFP/FORCE FIELD CONNECTION POINTS COLLECT ESCAPED',
     *          ' CHARGES'/
     *       1X,'SO THE EFP GENERATED HAS AN INTEGER CHARGE.')
      END
C
C*MODULE EFINP   *DECK RDDPTEN
      SUBROUTINE RDDPTEN(NPTS,N)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXIFRQ=12,MXDFG=5,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 MNAME,PNAME,RNAME,DPNAME
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT),
     *                DPCORD(3,MXIFRQ*MXPT),DPOLT(9,MXIFRQ*MXPT),
     *                ACHG(2,MXPT),ADIP(3,MXPT),AQAD(6,MXPT),
     *                AOCT(10,MXPT),AMULT(MXPT),BMULT(MXPT),
     *                AMULT2(MXPT),BMULT2(MXPT),
     *                RCORD(3,MXPT),TCLPR(4*MXPT),TZLPR(4*MXPT),
     *                INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT),
     *                MNAME(MXPT),PNAME(MXPT),RNAME(MXPT),
     *                DPNAME(MXIFRQ*MXPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IERR = 0
      IEOF = 0
      NPTS = 0
  100 CONTINUE
      K = NPTS + 1
      IF(K.GT.MXIFRQ*MXPT) THEN
         IF(MASWRK) WRITE(IW,9000) N,MXPT
         CALL ABRT
      END IF
C
      CALL RDCARD('RDDPTEN1',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      DPNAME(K) = '        '
      LGSTR=-8
      CALL GSTRNG(DPNAME(K),LGSTR)
      IF(DPNAME(K).EQ.'STOP    ') GO TO 600
      DO 120 L = 1,NMPTS(N)
        IF(DPNAME(K).EQ.MNAME(L)) GO TO 130
  120 CONTINUE
      GO TO 140
  130 CONTINUE
      DPCORD(1,K) = CORD(1,L)
      DPCORD(2,K) = CORD(2,L)
      DPCORD(3,K) = CORD(3,L)
      GO TO 200
  140 CONTINUE
      DO 150 J=1,3
        DPCORD(J,K) = RFIND('DPCORD  ',IERR)
C
        IF(IERR.NE.0) CALL ABRT
  150 CONTINUE
  200 CONTINUE
      CALL RDCARD('RDDPTEN2',IEOF)
      IF(IEOF.EQ.1) CALL ABRT
      DO 500 L=1,9
        DPOLT(L,K) = RFIND('DPOLT   ',IERR)
        IF(IERR.NE.0) CALL ABRT
  500 CONTINUE
      NPTS = NPTS + 1
      GO TO 100
C
  600 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'ERROR IN READING DYNAMIC POLARIZABLE
     *       POINTS FOR FRAGMENT',I4,' EXCEEDED MXPT=',I5)
      END
C*MODULE EFINP   *DECK RDCANV
      SUBROUTINE RDCANV(N,CANVEC,MXBF,NTAOF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192, MXDFG=5, MXFRG=1050, MXFGPT=12000)
C
      LOGICAL GOPARR,MASWRK,DSKWRK
C
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
C
      DIMENSION CANVEC(MXBF,NTAOF)
C
      IZERO = 0
      IONE  = 1
      ITWO  = 2
C
      NAOS=NAO(ISET(N))
      IF(NAOS.GT.MXBF) THEN
         IF(MASWRK) WRITE(IW,9010) NAOS,MXBF
         CALL ABRT
      END IF
C
      IF (MASWRK) THEN
      DO 280 J = 1,NAOS
         IMAX = 0
         IC = 0
  240    CONTINUE
            IMIN = IMAX+1
            IMAX = IMAX+5
            IC = IC+1
            IF(IMAX .GT. NAOS) IMAX = NAOS
            READ(IR,9040,END=300,ERR=300) JJ,ICC,
     *                                    (CANVEC(I,J+NTAO),I=IMIN,IMAX)
            MODJ=MOD(J,100)
            IF(JJ.EQ.MODJ . AND.  ICC.EQ.IC) GO TO 260
               WRITE(IW,9060) J,IC,JJ,ICC
               IF (GOPARR) CALL DDI_BCAST(355,'I',ITWO,1,MASTER)
               CALL ABRT
  260       CONTINUE
         IF(IMAX .LT. NPBF(N)) GO TO 240
  280 CONTINUE
      IF (GOPARR) CALL DDI_BCAST(355,'I',IZERO,1,MASTER)
C
C SLAVE WORK.  IEND=0,1,2 MEANS OK DATA, INCOMPLETE DATA, SCRAMBLED DATA
C
      ELSE
         IF (GOPARR) CALL DDI_BCAST(355,'I',IEND,1,MASTER)
         IF (IEND.EQ.IONE) GO TO 300
         IF (IEND.EQ.ITWO) CALL ABRT
      END IF
C
C  GIVE VECTORS TO ALL PROCESSES
C
      IF (GOPARR) CALL DDI_BCAST(356,'F',CANVEC,NAOS*NAOS,MASTER)
C
      IEOF = 0
      CALL RDCARD('CANONFOK',IEOF)
      CALL RDCARD('FOCK    ',IEOF)
      DO  I = 1,NAOS
         CANFOK(I,ISET(N)) = RFIND('FOCK    ',IEOF)
      END DO
      CALL RDCARD('STOP    ',IEOF)
      RETURN
C
C        PREMATURE END OF $VEC INPUT ENCOUNTERED
C
  300 CONTINUE
      IF (MASWRK) THEN
         IF (GOPARR) CALL DDI_BCAST(355,'I',IONE,1,MASTER)
         WRITE(IW,9100) J,IC
      ENDIF
      CALL ABRT
      RETURN
C
 9010 FORMAT(/1X,'* * * ERROR * * *'/
     *       1X,'NUMBER OF AO''S IN THIS FRAGMENT =',I5,' EXCEEDS THE'/
     *       1X,'MAXIMUM NO. OF AO''S GIVEN IN $EFRAG=',I5/
     *       1X,'PLEASE GIVE CORRECT -MXBF- KEYWORDS',
     *       1X,' ON THE FIRST $EFRAG CARD.'/)
 9040 FORMAT(I2,I3,5E15.8)
 9060 FORMAT(' *** ERROR READING THE MO COEFFICIENTS AT',2I4/
     *       '     THE INPUT VALUES WERE',2I4)
 9100 FORMAT(' *** ERROR: PREMATURE END OF ORBITAL INPUT ENCOUNTERED'/
     *       '            LOOKING FOR ORBITAL',I4,' ELEMENT',I4)
      END
