C 17 JAN 06 - HL  - MD SWITCHING, ADD INDIND,INDCHG,INDDPL,INDQUA
C 19 SEP 05 - IA  - SYNCHRONIZE FRGINF COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - HL  - PERIODIC BOUNDARY COND. FOR EFP
C 14 MAR 05 - HL  - CHANGE FMASS IN FRGMSS COMMON
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 22 FEB 05 - MWS - DININ: FIX PARALLELIZATION, EDISPR: BEAUTIFY
C 13 FEB 05 - HMN - ADD DUMMY EFP MD HOOKS TO ALL ENERGY/GRADIENT CODES,
C                   ADD EFP PARALLELIZATION INTO ENERGY AND GRADIENT,
C                   ADD DUMMY SPCE ENERGY.GRADIENT CODE SPCEG AND SPCTGT
C 13 FEB 05 - JS  - ADD EFP MP2 DISPERSION ROUTINES, EDISPR AND DDISPR
C  3 JUL 03 - MWS - DCHQUA,DCHOCT,DDPQUD,DQDQD: PASS IN WORKING STORAGE
C  7 AUG 02 - IA  - CHANGES TO MULTIPOLE SCREENING THROUGHOUT
C 17 APR 02 - MWS - SYNCH UP EFMULT AND FRGINF COMMON
C 13 JUN 01 - MAF - CHGCHG,CHGDIP: REMOVE CHARGE PENETRATION CALCULATION
C 18 SEP 96 - MWS - ELIMINATE FRAG-FRAG REPULSION COMMON
C 14 SEP 96 - BMB - CHGCHG,DCHCH: USE ERRF INSTEAD OF DERF
C 10 SEP 96 - MWS - INCLUDE THIS CODE IN DISTRIBUTION VERSION
C 13 JUN 96 - MWS - DELETE DEAD CODE PRNT,CHGIND,INDIND,QUDIND
C 24 MAY 96 - WC  - REMOVE EFPEX IN COMMOM EFPPAR
C 12 SEP 95 - WC  - EREPUL,DREPUL: READ FRAGMENT-FRAGMENT INTERACTION
C  6 JAN 95 - PND - CHANGES FOR UNSYMMETRIC POLARIZABILITY TENSORS
C 23 NOV 94 - MWS - REMOVE ALL FTNCHEK ERRORS
C 15 JUL 93 - PND - MODULE FOR INTERFRAGMENT ELECTROSTATICS
C
C CHGCHG - CHARGE-CHARGE INTERACTION ENERGY
C PRNT  -  ROUTINE FOR DEBUG PRINTING
C ELENER - "PARENT" ELECTROSTATIC CODE, FROM WALT STEVENS
C CHGDIP - CHARGE-DIPOLE INTERACTION ENERGY
C CHGQUA - CHARGE-QUADRUPOLE INTERACTION ENERGY
C CHGOCT - CHARGE-OCTUPOLE INTERACTION ENERGY
C DPLDPL - DIPOLE-DIPOLE INTERACTION ENERGY
C DPQUAD - DIPOLE-QUADRUPOLE INTERACTION ENERGY
C QUDQUD - QUADRUPOLE-QUADRUPOLE INTERACTION ENERGY
C DCHCH  - GRADIENT OF CHARGE-CHARGE INTERACTION ENERGY
C DCHDIP - GRADIENT OF CHARGE-DIPOLE INTERACTION ENERGY
C DDPDP  - GRADIENT OF DIPOLE-DIPOLE INTERACTION ENERGY
C DCHQUA - GRADIENT OF CHARGE-QUADRUPOLE INTERACTION ENERGY
C DCHOCT - GRADIENT OF CHARGE-OCTUPOLE INTERACTION ENERGY
C DDPQUD - GRADIENT OF DIPOLE-QUADRUPOLE INTERACTION ENERGY
C DQDQD  - GRADIENT OF QUADRUPOLE-QUADRUPOLE ENERGY
C CHGIND - CHARGE-INDUCED DIPOLE INTERACTION ENERGY
C DCHIND - GRADIENT OF CHARGE-INDUCED DIPOLE INTERACTION ENERGY
C INDIND - INDUCED DIPOLE-INDUCED DIPOLE INTERACTION ENERGY
C DININ - GRADIENT OF INDUCED DIPOLE-INDUCED DIPOLE INTERACTION ENERGY
C DPLIND - DIPOLE-INDUCED DIPOLE INTERACTION ENERGY
C DDPIND - GRADIENT OF DIPOLE-INDUCED DIPOLE INTERACTION ENERGY
C QUDIND - QUADRUPOLE-INDUCED DIPOLE INTERACTION ENERGY
C DQDIND - GRADIENT OF QUADRUPOLE-INDUCED DIPOLE INTERACTION ENERGY
C
C*MODULE EFELEC  *DECK CHGCHG
      SUBROUTINE CHGCHG(ELTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, ZERO=0.0D+00)
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-10)
C
      CALL VCLR(DESFRG,1,6*MXFRG)
      PI=4*ATAN(1.0D+00)
      ELTOT=ZERO
      IC1=0
C
      CALL EFCM
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 280 IM = 1,NFRG
      DO 280 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 270 IP=1,NMPTS(IM)
            IC1=IC1+1
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            Q1 = EFCHG(1,IC1)
            Q1N = EFCHG(2,IC1)
            IC2=0
            DO 260 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 260
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 260
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 260
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 260
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               EPAIR = 0.0D+00
               DO 250 JP = 1,NMPTS(JM)
                  IC2=IC2+1
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)
                  Q2N = EFCHG(2,IC2)
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                  IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  R2 = X*X + Y*Y + Z*Z
                  R = SQRT(R2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     AI=ZERO
                     AJ=ZERO
                     CF1 = ZERO
                     CF2 = ZERO
                     ALPHAA = EFATRM2(IC1)
                     BETAA = EFBTRM2(IC1)
                     ALPHAB = EFATRM2(IC2)
                  ELSE
                     AI=EFATRM(IC1)
                     AJ=EFATRM(IC2)
                     CF1 = EFBTRM(IC1)
                     CF2 = EFBTRM(IC2)
                     ALPHAA = ZERO
                     BETAA = ZERO
                     ALPHAB = ZERO
                  END IF
                  EX1 = EXP(-AI*R2)
                  EX2 = EXP(-AJ*R2)
            IF(Q1N.NE.ZERO.OR.Q2N.NE.ZERO) THEN
            SCREEN1 = 1.0D+00 - CF1*EX1
            SCREEN2 = 1.0D+00 - CF2*EX2
              EPAIR=EPAIR+(Q1N*Q2*SCREEN2
     *                    +Q2N*Q1*SCREEN1+Q1N*Q2N)/R
            END IF
            EPAIR=EPAIR+Q1*Q2*(1/R
     *                 -CF1*EX1/R
     *                 -CF2*EX2/R)
           IF(CF1*CF2.NE.ZERO)EPAIR=EPAIR+Q1*Q2*
     *                  CF1*CF2*(AI*AJ*SQRT(PI/(AI+AJ)**3)*
     *                  EXP(-R2*AI*AJ/(AI+AJ))*(1-ERRF(R*AI/SQRT(AI+
     *                  AJ))-ERRF(R*AJ/SQRT(AI+AJ)))+(AI*EX1+
     *                  AJ*EX2)/R/(AI+AJ))
C
      IF(ICHGP.EQ.1.OR.R.GT.ELEVEN.OR.BETAA.EQ.ZERO) GOTO 250
C
C     -------  CALCULATE CHARGE PENETRATION --------
C     THIS FORMULA INVOLVES FRAGMENT/FRAGMENT EXPONENTIAL SCREENING
C
               AP=ALPHAA*R
               BP=ALPHAB*R
               AA2=ALPHAA*ALPHAA
               AB2=ALPHAB*ALPHAB
               DIFF=ABS(ALPHAA-ALPHAB)
C
C          ALPHAA = ALPHAB?
C
               IF(DIFF.LT.SMALL) THEN
                  TPCHPE=-(EXP(-AP)/R)*(Q1*Q2*(ONE+(AP/TWO))
     *                   +Q1*Q2N+Q2*Q1N)
               ELSE
                  TPCHPE=-(ONE/(TWO*R))*(Q1*(Q2+TWO*Q2N)*EXP(-AP)
     *              +Q2*(Q1+TWO*Q1N)*EXP(-BP)
     *              +Q1*Q2*((AA2+AB2)/(AA2-AB2))*(EXP(-BP)-EXP(-AP)))
               ENDIF
C
C INCORPORATE INTO ELECTROSTATIC ENERGY
C
                EPAIR=EPAIR+TPCHPE
C
250         CONTINUE
              ELTOT = ELTOT + SWF*EPAIR
              DESFRG(1,JM) = DESFRG(1,JM) - EPAIR*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - EPAIR*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - EPAIR*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + EPAIR*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + EPAIR*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + EPAIR*SWFDZ
260         CONTINUE
270      CONTINUE
280   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK CHGDIP
      SUBROUTINE CHGDIP(ELTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      PARAMETER (ZERO=0.0D+00)
C
      ELTOT=ZERO
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DODIPO(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            DX1 = EFDIP(1,IC1)
            DY1 = EFDIP(2,IC1)
            DZ1 = EFDIP(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
C
               CFX = ZERO
               CFY = ZERO
               CFZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     EX = ZERO
                     CF = ZERO
                  ELSE
                     EX = EFATRM(IC2)
                     CF = EFBTRM(IC2)
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
                  DUM = Q2/R3
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     CFX = CFX + X*DUM
                     CFY = CFY + Y*DUM
                     CFZ = CFZ + Z*DUM
                  ELSE
                     EX2=EXP(-EX*R2)
                     SCREEN=1.0D+00-CF*EX2
                     CFX = CFX + X*DUM*SCREEN - 2.0D+00*Q2*CF*X*EX*EX2/R
                     CFY = CFY + Y*DUM*SCREEN - 2.0D+00*Q2*CF*Y*EX*EX2/R
                     CFZ = CFZ + Z*DUM*SCREEN - 2.0D+00*Q2*CF*Z*EX*EX2/R
                  END IF
C
C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
370            CONTINUE
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, ETC. AT POINT 'IP' IN
C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IP'
C     WITH THESE FIELDS TO THE 'IM' WITH 'JM' INTERACTION.
C
C
C.... CHARGE(JM) - DIPOLE(IM)
C
               TERM = -(DX1*CFX+DY1*CFY+DZ1*CFZ)
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK CHGQUA
      SUBROUTINE CHGQUA(ELTOT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,MXFGPT)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00, THREE=3.0D+00,
     *           PT5=0.5D+00, ONEPT5=1.5D+00)
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      ELTOT=ZERO
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               CFXX = ZERO
               CFYY = ZERO
               CFZZ = ZERO
               CFXY = ZERO
               CFXZ = ZERO
               CFYZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R5
      CFXX = CFXX - (THREE*XX-R2)*DUM
      CFYY = CFYY - (THREE*YY-R2)*DUM
      CFZZ = CFZZ - (THREE*ZZ-R2)*DUM
      CFXY = CFXY - THREE*XY*DUM
      CFXZ = CFXZ - THREE*XZ*DUM
      CFYZ = CFYZ - THREE*YZ*DUM
C
370            CONTINUE
C
C.... CHARGE(JM) - QUADRUPOLE(IM)
C
               TERM = XX1*CFXX + YY1*CFYY + ZZ1*CFZZ
     1               +TWO*(XY1*CFXY + XZ1*CFXZ + YZ1*CFYZ)
               TERM = -TERM/3
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK CHGOCT
      SUBROUTINE CHGOCT(ELTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      CHARACTER*8 FRGNME
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION OCT(10,MXFGPT)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA PT5/0.5D+00/
      DATA THREE,FIVE,SIX/3.0D+00,5.0D+00,6.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THIRD MOMENTS WITH OCTUPOLE MOMENTS           ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      ELTOT=ZERO
      DO 242 I = 1,NMTTPT
        IF(.NOT.DOOCTU(I)) GO TO 242
         XXX = EFOCT(1,I) * PT5
         YYY = EFOCT(2,I) * PT5
         ZZZ = EFOCT(3,I) * PT5
         XXY = EFOCT(4,I) * PT5
         XXZ = EFOCT(5,I) * PT5
         XYY = EFOCT(6,I) * PT5
         YYZ = EFOCT(7,I) * PT5
         XZZ = EFOCT(8,I) * PT5
         YZZ = EFOCT(9,I) * PT5
         XYZ = EFOCT(10,I) * PT5
         DUMX = XXX + XYY + XZZ
         DUMY = XXY + YYY + YZZ
         DUMZ = XXZ + YYZ + ZZZ
         OCT(1,I) = FIVE * XXX - THREE * DUMX
         OCT(2,I) = FIVE * YYY - THREE * DUMY
         OCT(3,I) = FIVE * ZZZ - THREE * DUMZ
         OCT(4,I) = FIVE * XXY - DUMY
         OCT(5,I) = FIVE * XXZ - DUMZ
         OCT(6,I) = FIVE * XYY - DUMX
         OCT(7,I) = FIVE * YYZ - DUMZ
         OCT(8,I) = FIVE * XZZ - DUMX
         OCT(9,I) = FIVE * YZZ - DUMY
         OCT(10,I) = FIVE * XYZ
242   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOOCTU(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XXX1 = OCT(1,IC1)
            YYY1 = OCT(2,IC1)
            ZZZ1 = OCT(3,IC1)
            XXY1 = OCT(4,IC1)
            XXZ1 = OCT(5,IC1)
            XYY1 = OCT(6,IC1)
            YYZ1 = OCT(7,IC1)
            XZZ1 = OCT(8,IC1)
            YZZ1 = OCT(9,IC1)
            XYZ1 = OCT(10,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               CFXXX = ZERO
               CFYYY = ZERO
               CFZZZ = ZERO
               CFXXY = ZERO
               CFXXZ = ZERO
               CFXYY = ZERO
               CFYYZ = ZERO
               CFXZZ = ZERO
               CFYZZ = ZERO
               CFXYZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  XXX = XX*X
                  YYY = YY*Y
                  ZZZ = ZZ*Z
                  XXY = XX*Y
                  XXZ = XX*Z
                  XYY = XY*Y
                  YYZ = YY*Z
                  XZZ = XZ*Z
                  YZZ = YZ*Z
                  XYZ = XY*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R7
      RRX = R2*X
      RRY = R2*Y
      RRZ = R2*Z
      CFXXX = CFXXX + (FIVE*XXX-THREE*RRX)*DUM
      CFYYY = CFYYY + (FIVE*YYY-THREE*RRY)*DUM
      CFZZZ = CFZZZ + (FIVE*ZZZ-THREE*RRZ)*DUM
      CFXXY = CFXXY + (FIVE*XXY-RRY)*DUM
      CFXXZ = CFXXZ + (FIVE*XXZ-RRZ)*DUM
      CFXYY = CFXYY + (FIVE*XYY-RRX)*DUM
      CFYYZ = CFYYZ + (FIVE*YYZ-RRZ)*DUM
      CFXZZ = CFXZZ + (FIVE*XZZ-RRX)*DUM
      CFYZZ = CFYZZ + (FIVE*YZZ-RRY)*DUM
      CFXYZ = CFXYZ + (FIVE*XYZ)*DUM
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
370            CONTINUE
C
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, ETC. AT POINT 'IP' IN
C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IP'
C     WITH THESE FIELDS TO THE 'IM' WITH 'JM' INTERACTION.
C
C.... CHARGE(JM) - OCTUPOLE(IM)
C
               TERM = XXX1*CFXXX + YYY1*CFYYY + ZZZ1*CFZZZ
     1              + THREE*(XXY1*CFXXY + XXZ1*CFXXZ + XYY1*CFXYY)
     1              + THREE*(YYZ1*CFYYZ + XZZ1*CFXZZ + YZZ1*CFYZZ)
     1              + SIX*XYZ1*CFXYZ
               TERM = -TERM/FIVE
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C.... END OF 'JM' MOLECULE LOOP
380         CONTINUE
C
C.... END OF 'IP' LOOP IN 'IM' MOLECULE
390      CONTINUE
C
C
C.... END OF 'IM' MOLECULE LOOP
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DPLDPL
      SUBROUTINE DPLDPL(ELTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00)
C
      ELTOT=ZERO
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DODIPO(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            DX1 = EFDIP(1,IC1)
            DY1 = EFDIP(2,IC1)
            DZ1 = EFDIP(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               DFX = ZERO
               DFY = ZERO
               DFZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
C
      DOT = DX2*X + DY2*Y + DZ2*Z
      DUM = DOT*THREE/R5
      DFX = DFX - DX2/R3 + X*DUM
      DFY = DFY - DY2/R3 + Y*DUM
      DFZ = DFZ - DZ2/R3 + Z*DUM
C
370            CONTINUE
C
C.... DIPOLE(JM) - DIPOLE(IM)
C
               TERM = -(DX1*DFX+DY1*DFY+DZ1*DFZ)
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DPQUAD
      SUBROUTINE DPQUAD(ELTOT)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,MXFGPT)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00, PT5=0.5D+00,
     *           ONEPT5=1.5D+00, TWO=2.0D+00, FIFTEN=1.5D+01)
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      ELTOT=ZERO
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               DFXX = ZERO
               DFYY = ZERO
               DFZZ = ZERO
               DFXY = ZERO
               DFXZ = ZERO
               DFYZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
      DOT = DX2*X + DY2*Y + DZ2*Z
C
      DUM = THREE/R5
C     DFXX = DFXX + (TWO*DX2*X+DOT)*DUM - FIFTEN*XX*DOT/R7
C     DFYY = DFYY + (TWO*DY2*Y+DOT)*DUM - FIFTEN*YY*DOT/R7
C     DFZZ = DFZZ + (TWO*DZ2*Z+DOT)*DUM - FIFTEN*ZZ*DOT/R7
      DFXX = DFXX + (TWO*DX2*X)*DUM - FIFTEN*XX*DOT/R7
      DFYY = DFYY + (TWO*DY2*Y)*DUM - FIFTEN*YY*DOT/R7
      DFZZ = DFZZ + (TWO*DZ2*Z)*DUM - FIFTEN*ZZ*DOT/R7
      DFXY = DFXY + (DX2*Y+DY2*X)*DUM - FIFTEN*XY*DOT/R7
      DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*DOT/R7
      DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*DOT/R7
C
C     DFXX = DFXX + (TWO*DX2*X+DOT)*DUM
C     DFYY = DFYY + (TWO*DY2*Y+DOT)*DUM
C     DFZZ = DFZZ + (TWO*DZ2*Z+DOT)*DUM
C     DFXX = DFXX + (TWO*DX2*X)*DUM
C     DFYY = DFYY + (TWO*DY2*Y)*DUM
C     DFZZ = DFZZ + (TWO*DZ2*Z)*DUM
C     DFXY = DFXY + (DX2*Y+DY2*X)*DUM
C     DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM
C     DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM
C
C     DFXX = DFXX - FIFTEN*XX*DOT/R7
C     DFYY = DFYY - FIFTEN*YY*DOT/R7
C     DFZZ = DFZZ - FIFTEN*ZZ*DOT/R7
C     DFXY = DFXY - FIFTEN*XY*DOT/R7
C     DFXZ = DFXZ - FIFTEN*XZ*DOT/R7
C     DFYZ = DFYZ - FIFTEN*YZ*DOT/R7
C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
370            CONTINUE
C
C.... DIPOLE(JM) - QUADRUPOLE(IM)
C
C              TERM = XX1*DFXX
               TERM = XX1*DFXX + YY1*DFYY + ZZ1*DFZZ
     1              + TWO*(XY1*DFXY + XZ1*DFXZ + YZ1*DFYZ)
               TERM = -TERM/THREE
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK QUDQUD
      SUBROUTINE QUDQUD(ELTOT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C     DIMENSION QUAQUA(MXFRG,MXFRG),ASUM(MXFRG,MXFRG),QUA(6,MXFGPT)
      DIMENSION QUA(6,MXFGPT)
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      DATA MD         /8HMD      /
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA THREE,SIX/3.0D+00,6.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      ELTOT=ZERO
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               QUAD = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOQUAD(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  XX2 = QUA(1,IC2)
                  YY2 = QUA(2,IC2)
                  ZZ2 = QUA(3,IC2)
                  XY2 = QUA(4,IC2)
                  XZ2 = QUA(5,IC2)
                  YZ2 = QUA(6,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
C
C.... GET THE QUADRUPOLE(IM)-QUADRUPOLE CONTRIBUTION(JM) ....
C     THIS PART HANDLED SEPARATELY FROM REST UNTIL
C     FIELD GRADIENT DUE TO QUADRUPOLE IS DERIVED
C
                  VAL = ZERO
                  VAL = VAL + X*(X*XX2 + Y*XY2 + Z*XZ2)
                  VAL = VAL + Y*(X*XY2 + Y*YY2 + Z*YZ2)
                  VAL = VAL + Z*(X*XZ2 + Y*YZ2 + Z*ZZ2)
                  QUAD1 = XX1*XX2 + TWO*XY1*XY2 + TWO*XZ1*XZ2
                  QUAD1 = QUAD1 + YY1*YY2 + TWO*YZ1*YZ2 + ZZ1*ZZ2
                  QUAD = QUAD + QUAD1*SIX/R5
                  QUAD2 = X*(X*XX1+Y*XY1+Z*XZ1)
                  QUAD2 = Y*(X*XY1+Y*YY1+Z*YZ1) + QUAD2
                  QUAD2 = Z*(X*XZ1+Y*YZ1+Z*ZZ1) + QUAD2
                  QUAD = QUAD + QUAD2*VAL*105.0D+00 / R9
                  FACT1 = X*XX1 + Y*XY1 + Z*XZ1
                  FACT2 = X*XX2 + Y*XY2 + Z*XZ2
                  QUAD3 = FACT1 * FACT2
                  FACT1 = X*XY1 + Y*YY1 + Z*YZ1
                  FACT2 = X*XY2 + Y*YY2 + Z*YZ2
                  QUAD3 = QUAD3 + FACT1 * FACT2
                  FACT1 = X*XZ1 + Y*YZ1 + Z*ZZ1
                  FACT2 = X*XZ2 + Y*YZ2 + Z*ZZ2
                  QUAD3 = QUAD3 + FACT1 * FACT2
                  QUAD = QUAD - 60.0D+00 * QUAD3 / R7
C     FIELD DUE TO QUADRUPOLE MOMENTS ON JM.
C
C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
370            CONTINUE
C
C.... QUADRUPOLE(JM) - QUADRUPOLE(IM)
C
               TERM = TWO*QUAD/18.0D+00
               ELTOT = ELTOT + SWF*TERM
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
C     RUNTYP=ENERGY
      RETURN
      END
C*MODULE EFELEC  *DECK DCHCH
      SUBROUTINE DCHCH
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
        COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-10)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
C
      PI=4.0D+00 * ATAN(1.0D+00)
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C      DO 280 IM = 1,NFRG
      DO 280 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 270 IP=1,NMPTS(IM)
            IC1=IC1+1
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            Q1 = EFCHG(1,IC1)
            Q1N = EFCHG(2,IC1)
            IC2=0
            DO 260 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 260
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 260
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 260
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 260
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DO 250 JP = 1,NMPTS(JM)
                  IC2=IC2+1
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)
                  Q2N = EFCHG(2,IC2)
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  R2 = X*X + Y*Y + Z*Z
                  R = SQRT(R2)
                  R3 = R * R * R
C
                  IF(ICHGP.EQ.1) THEN
                     AI=EFATRM(IC1)
                     AJ=EFATRM(IC2)
                     AIJ=AI+AJ
                     CF1 = EFBTRM(IC1)
                     CF2 = EFBTRM(IC2)
                  ELSE
                     AI= ZERO
                     AJ= ZERO
                     AIJ=ZERO
                     CF1 = ZERO
                     CF2 = ZERO
                  END IF
C
                  EX1 = EXP(-AI*R2)
                  EX2 = EXP(-AJ*R2)
                  SCREEN1 = 1.0D+00 - CF1*EX1
                  CON1=ZERO
                  IF(Q1N.NE.ZERO.OR.Q2N.NE.ZERO) THEN
                     SCREEN2 = 1.0D+00 - CF2*EX2
                     CON1=(Q1N*Q2*SCREEN2+Q2N*Q1*SCREEN1+Q1N*Q2N)/R3
                  END IF
C
                  CON1=CON1+Q1*Q2*(SCREEN1-CF2*EX2)/R3
C
                  IF(CF1*CF2.NE.ZERO) THEN
                     CON1=CON1+Q1*Q2*CF1*CF2*(AI*EX1+AJ*EX2)/(AIJ*R3)
                     CON1=CON1-TWO*(Q1*(Q2+Q2N)*AI*CF1*EX1+Q2*(Q1+Q1N)
     *                                                  *AJ*CF2*EX2)/R
               CON1=CON1+TWO*Q1*Q2*CF1*CF2*(AI*AI*EX1+AJ*AJ*EX2)/AIJ/R
C
                     CON =AI*AJ*SQRT(PI/AIJ**3)*EXP(-R2*AI*AJ/AIJ)
                     CON1=CON1+Q1*Q2*CF1*CF2*CON
     *                 *((1-ERRF(R*AI/SQRT(AIJ))-ERRF(R*AJ/SQRT(AIJ)))
     *                           *TWO*AI*AJ/AIJ
     *                  +(AI*EXP(-AI*AI*R2/AIJ)+AJ*EXP(-AJ*AJ*R2/AIJ))
     *                         *TWO/(R*SQRT(PI*AIJ)))
                  END IF
C
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                    ALPHAA = EFATRM2(IC1)
                    BETAA = EFBTRM2(IC1)
                    ALPHAB = EFATRM2(IC2)
                  ELSE
                    ALPHAA = ZERO
                    BETAA = ZERO
                    ALPHAB = ZERO
                  END IF
C
C BEGINING OF CHARGE PENETRATION GRADIENT :
C
           IF(ICHGP.EQ.1.OR.R.GT.ELEVEN.OR.BETAA.EQ.ZERO)  GOTO 249
C
C     -------  CALCULATE CHARGE PENETRATION GRADIENT --------
C     FRAGMENT/FRAGMENT EXPONENTIAL SCREENING FORMULA
C
               AP=ALPHAA*R
               BP=ALPHAB*R
               AA2=ALPHAA*ALPHAA
               AB2=ALPHAB*ALPHAB
               DIFF=ABS(ALPHAA-ALPHAB)
               IF(DIFF.LT.SMALL) THEN
C
C       -------- FORMULA FOR ALPHAA=ALPHAB ---------
C
       GTPCHPE=-ONE*(EXP(-AP)/R3)*((Q1*Q2+Q1*Q2N+Q2*Q1N)*(ONE+
     *         AP)+(AA2*Q1*Q2*R2/TWO))
               ELSE
C
C IF ALPHAA NOT EQUAL TO ALPHAB:
C
      GTPCHPE=-ONE*((EXP(-AP-BP))/((AA2-AB2)*R3))*(Q2*(ONE+
     *        BP)*EXP(AP)*(Q1*AA2+Q1N*(AA2-AB2))+Q1*(ONE+
     *        AP)*EXP(BP)*(Q2N*(AA2-AB2)-Q2*AB2))
              END IF
C
            CON1=CON1+GTPCHPE
C
  249       CONTINUE
            CONX=CON1*X
            CONY=CON1*Y
            CONZ=CON1*Z
C
C            EF3(1,IC2)=EF3(1,IC2)+CONX
C            EF3(2,IC2)=EF3(2,IC2)+CONY
C            EF3(3,IC2)=EF3(3,IC2)+CONZ
C            EF3(1,IC1)=EF3(1,IC1)-CONX
C            EF3(2,IC1)=EF3(2,IC1)-CONY
C            EF3(3,IC1)=EF3(3,IC1)-CONZ
C
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM)))
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM)))
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM)))
250         CONTINUE
260         CONTINUE
270      CONTINUE
280   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DCHDIP
      SUBROUTINE DCHDIP
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO=0.0D+00)
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DODIPO(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            DX1 = EFDIP(1,IC1)
            DY1 = EFDIP(2,IC1)
            DZ1 = EFDIP(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               CFR = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     EX = ZERO
                     CF = ZERO
                  ELSE
                     EX = EFATRM(IC2)
                     CF = EFBTRM(IC2)
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R3
      DOT = DX1*X + DY1*Y + DZ1*Z
      IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
         CFR =  DUM
         CN1 = (3.0D+00/R5)*DOT*Q2
      ELSE
         EX2=EXP(-EX*R2)
         SCREEN=1.0D+00-CF*EX2
         CFR =  DUM*SCREEN - 2.0D+00*Q2*CF*EX*EX2/R
         CN1 = (3.0D+00*SCREEN/R5
     *        - 4.0D+00*CF*EX*EX2*(1.0D+00/R3 + EX/R))*DOT*Q2
      END IF
      CONX = DX1*CFR - X*CN1
      CONY = DY1*CFR - Y*CN1
      CONZ = DZ1*CFR - Z*CN1
C     EF3(1,IC2) = EF3(1,IC2) + CONX
C     EF3(2,IC2) = EF3(2,IC2) + CONY
C     EF3(3,IC2) = EF3(3,IC2) + CONZ
C     EF3(1,IC1) = EF3(1,IC1) - CONX
C     EF3(2,IC1) = EF3(2,IC1) - CONY
C     EF3(3,IC1) = EF3(3,IC1) - CONZ
C     ATORQ(1,IM) = ATORQ(1,IM) - CFR*(DY1*Z-DZ1*Y)
C     ATORQ(2,IM) = ATORQ(2,IM) - CFR*(DZ1*X-DX1*Z)
C     ATORQ(3,IM) = ATORQ(3,IM) - CFR*(DX1*Y-DY1*X)
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      +CFR*(DY1*Z-DZ1*Y)             )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      +CFR*(DZ1*X-DX1*Z)             )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      +CFR*(DX1*Y-DY1*X)             )
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DDPDP
      SUBROUTINE DDPDP
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00)
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DODIPO(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            DX1 = EFDIP(1,IC1)
            DY1 = EFDIP(2,IC1)
            DZ1 = EFDIP(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DFX2 = ZERO
               DFY2 = ZERO
               DFZ2 = ZERO
               DFX1 = ZERO
               DFY1 = ZERO
               DFZ1 = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
      DOT1 = DX1*X + DY1*Y + DZ1*Z
      DOT2 = DX2*X + DY2*Y + DZ2*Z
      DOTM = DX2*DX1 + DY2*DY1 + DZ2*DZ1
      DOTXY=DY2*DX1+DY1*DX2
      DOTXZ=DZ2*DX1+DZ1*DX2
      DOTYZ=DY2*DZ1+DY1*DZ2
      DOTX = 2.0D+00*DX2*DX1*X+DOTXY*Y+DOTXZ*Z
      DOTY = 2.0D+00*DY2*DY1*Y+DOTXY*X+DOTYZ*Z
      DOTZ = 2.0D+00*DZ2*DZ1*Z+DOTXZ*X+DOTYZ*Y
      DUM = THREE/R5
      DUM2=DUM*DOT2
      DUM1=DUM*DOT1
      TEMP = DX1*DX2*XX+DY1*DY2*YY+DZ1*DZ2*ZZ
     * +(DX1*DY2+DY1*DX2)*XY+(DX1*DZ2+DZ1*DX2)*XZ
     * +(DY1*DZ2+DZ1*DY2)*YZ
      DUM7 = 15.0D+00 * TEMP/R7
C     DFX2 = DFX2 - (DX2/R3 + X*DUM2)
C     DFY2 = DFY2 - (DY2/R3 + Y*DUM2)
C     DFZ2 = DFZ2 - (DZ2/R3 + Z*DUM2)
C     DFX1 = DFX1 - (DX1/R3 + X*DUM1)
C     DFY1 = DFY1 - (DY1/R3 + Y*DUM1)
C     DFZ1 = DFZ1 - (DZ1/R3 + Z*DUM1)
      DFX2 = -DX2/R3 + X*DUM2
      DFY2 = -DY2/R3 + Y*DUM2
      DFZ2 = -DZ2/R3 + Z*DUM2
      DFX1 = -DX1/R3 + X*DUM1
      DFY1 = -DY1/R3 + Y*DUM1
      DFZ1 = -DZ1/R3 + Z*DUM1
      CONX = DUM*(DOTM*X+DOTX)-DUM7*X
      CONY = DUM*(DOTM*Y+DOTY)-DUM7*Y
      CONZ = DUM*(DOTM*Z+DOTZ)-DUM7*Z
C
C
C           EF3(1,IC2)=EF3(1,IC2)+CONX
C           EF3(2,IC2)=EF3(2,IC2)+CONY
C           EF3(3,IC2)=EF3(3,IC2)+CONZ
C           EF3(1,IC1)=EF3(1,IC1)-CONX
C           EF3(2,IC1)=EF3(2,IC1)-CONY
C           EF3(3,IC1)=EF3(3,IC1)-CONZ
C
C
C     ATORQ(1,IM)=ATORQ(1,IM)-DY1*DFZ2+DZ1*DFY2
C     ATORQ(2,IM)=ATORQ(2,IM)-DZ1*DFX2+DX1*DFZ2
C     ATORQ(3,IM)=ATORQ(3,IM)-DX1*DFY2+DY1*DFX2
C     ATORQ(1,JM)=ATORQ(1,JM)-DY2*DFZ1+DZ2*DFY1
C     ATORQ(2,JM)=ATORQ(2,JM)-DZ2*DFX1+DX2*DFZ1
C     ATORQ(3,JM)=ATORQ(3,JM)-DX2*DFY1+DY2*DFX1
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -(DY2*DFZ1-DZ2*DFY1)       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -(DZ2*DFX1-DX2*DFZ1)       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -(DX2*DFY1-DY2*DFX1)       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      +(DY1*DFZ2-DZ1*DFY2)       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      +(DZ1*DFX2-DX1*DFZ2)       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      +(DX1*DFY2-DY1*DFX2)       )
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DCHQUD
      SUBROUTINE DCHQUD(QUA)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
C                   2ND DIMENSION OF QUA MUST BE NMTTPT...
      DIMENSION QUA(6,*)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA THREE/3.0D+00/, ZERO/0.0D+00/
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               CFXX = ZERO
               CFYY = ZERO
               CFZZ = ZERO
               CFXY = ZERO
               CFXZ = ZERO
               CFYZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = 2.0D+00*Q2/R5
      DUM7 = 5.0D+00*Q2/R7/3.0D+00
      CFXX = (THREE*XX-R2)*DUM7
      CFYY = (THREE*YY-R2)*DUM7
      CFZZ = (THREE*ZZ-R2)*DUM7
      CFXY = THREE*XY*DUM7
      CFXZ = THREE*XZ*DUM7
      CFYZ = THREE*YZ*DUM7
C
      TMX = (XX1*X+XY1*Y+XZ1*Z)*DUM
      TMY = (XY1*X+YY1*Y+YZ1*Z)*DUM
      TMZ = (XZ1*X+YZ1*Y+ZZ1*Z)*DUM
C
               TERM = XX1*CFXX + YY1*CFYY + ZZ1*CFZZ
     1               +TWO*(XY1*CFXY + XZ1*CFXZ + YZ1*CFYZ)
               TERMX = TERM*X
               TERMY = TERM*Y
               TERMZ = TERM*Z
C           EF3(1,IC2)=EF3(1,IC2)-TMX+TERMX
C           EF3(2,IC2)=EF3(2,IC2)-TMY+TERMY
C           EF3(3,IC2)=EF3(3,IC2)-TMZ+TERMZ
C           EF3(1,IC1)=EF3(1,IC1)+TMX-TERMX
C           EF3(2,IC1)=EF3(2,IC1)+TMY-TERMY
C           EF3(3,IC1)=EF3(3,IC1)+TMZ-TERMZ
C     ATORQ(1,IM)=ATORQ(1,IM)-Y*TMZ+Z*TMY
C     ATORQ(2,IM)=ATORQ(2,IM)-Z*TMX+X*TMZ
C     ATORQ(3,IM)=ATORQ(3,IM)-X*TMY+Y*TMX
             CONX = -TMX + TERMX
             CONY = -TMY + TERMY
             CONZ = -TMZ + TERMZ
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      +(Y*TMZ - Z*TMY)             )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      +(Z*TMX - X*TMZ)             )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      +(X*TMY - Y*TMX)             )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DCHOCT
      SUBROUTINE DCHOCT(OCT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
C                   2ND DIMENSION OF OCT MUST BE NMTTPT...
      DIMENSION OCT(10,*)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      DATA MD         /8HMD      /
C
      DATA PT5,TWO/0.5D+00,2.0D+00/
      DATA TEN,FIFTEN,THIRTY/10.0D+00,15.0D+00,30.0D+00/
      DATA THREE,FIVE,SIX,SEVEN/3.0D+00,5.0D+00,6.0D+00,7.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THIRD MOMENTS WITH OCTUPOLE MOMENTS           ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      DO 242 I = 1,NMTTPT
        IF(.NOT.DOOCTU(I)) GO TO 242
         XXX = EFOCT(1,I) * PT5
         YYY = EFOCT(2,I) * PT5
         ZZZ = EFOCT(3,I) * PT5
         XXY = EFOCT(4,I) * PT5
         XXZ = EFOCT(5,I) * PT5
         XYY = EFOCT(6,I) * PT5
         YYZ = EFOCT(7,I) * PT5
         XZZ = EFOCT(8,I) * PT5
         YZZ = EFOCT(9,I) * PT5
         XYZ = EFOCT(10,I) * PT5
         DUMX = XXX + XYY + XZZ
         DUMY = XXY + YYY + YZZ
         DUMZ = XXZ + YYZ + ZZZ
         OCT(1,I) = FIVE * XXX - THREE * DUMX
         OCT(2,I) = FIVE * YYY - THREE * DUMY
         OCT(3,I) = FIVE * ZZZ - THREE * DUMZ
         OCT(4,I) = FIVE * XXY - DUMY
         OCT(5,I) = FIVE * XXZ - DUMZ
         OCT(6,I) = FIVE * XYY - DUMX
         OCT(7,I) = FIVE * YYZ - DUMZ
         OCT(8,I) = FIVE * XZZ - DUMX
         OCT(9,I) = FIVE * YZZ - DUMY
         OCT(10,I) = FIVE * XYZ
242   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOOCTU(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XXX1 = OCT(1,IC1)
            YYY1 = OCT(2,IC1)
            ZZZ1 = OCT(3,IC1)
            XXY1 = OCT(4,IC1)
            XXZ1 = OCT(5,IC1)
            XYY1 = OCT(6,IC1)
            YYZ1 = OCT(7,IC1)
            XZZ1 = OCT(8,IC1)
            YZZ1 = OCT(9,IC1)
            XYZ1 = OCT(10,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               CFXXX = ZERO
               CFYYY = ZERO
               CFZZZ = ZERO
               CFXXY = ZERO
               CFXXZ = ZERO
               CFXYY = ZERO
               CFYYZ = ZERO
               CFXZZ = ZERO
               CFYZZ = ZERO
               CFXYZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  XXX = XX*X
                  YYY = YY*Y
                  ZZZ = ZZ*Z
                  XXY = XX*Y
                  XXZ = XX*Z
                  XYY = XY*Y
                  YYZ = YY*Z
                  XZZ = XZ*Z
                  YZZ = YZ*Z
                  XYZ = XY*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
C
      DUM = Q2/R7/FIVE
      DUM9 = SEVEN*Q2/R9/FIVE
      RRX = R2*X
      RRY = R2*Y
      RRZ = R2*Z
      CFXXX = FIVE*XXX-THREE*RRX
      CFYYY = FIVE*YYY-THREE*RRY
      CFZZZ = FIVE*ZZZ-THREE*RRZ
      CFXXY = FIVE*XXY-RRY
      CFXXZ = FIVE*XXZ-RRZ
      CFXYY = FIVE*XYY-RRX
      CFYYZ = FIVE*YYZ-RRZ
      CFXZZ = FIVE*XZZ-RRX
      CFYZZ = FIVE*YZZ-RRY
      CFXYZ = FIVE*XYZ
C
C.... CHARGE(JM) - OCTUPOLE(IM)
C
               TERM = DUM9*(XXX1*CFXXX + YYY1*CFYYY + ZZZ1*CFZZZ
     1              + THREE*(XXY1*CFXXY + XXZ1*CFXXZ + XYY1*CFXYY)
     1              + THREE*(YYZ1*CFYYZ + XZZ1*CFXZZ + YZZ1*CFYZZ)
     1              + SIX*XYZ1*CFXYZ)
               TERMX = TERM*X
               TERMY = TERM*Y
               TERMZ = TERM*Z
        TMX1 = (XXX1*FIFTEN*XX
     1      + THREE*(XXY1*TEN*XY + XXZ1*TEN*XZ + XYY1*FIVE*YY
     1      + XZZ1*FIVE*ZZ) + THIRTY*XYZ1*YZ)*DUM
        TMX2 = (-XXX1*SIX*XX - YYY1*SIX*XY - ZZZ1*SIX*XZ
     1      + THREE*(-XXY1*TWO*XY - XXZ1*TWO*XZ - XYY1*TWO*XX
     1      - XZZ1*TWO*XX - YYZ1*TWO*XZ - YZZ1*TWO*XY))*DUM
        TMY1 = (YYY1*FIFTEN*YY
     1      + THREE*(XYY1*TEN*XY + YYZ1*TEN*YZ + XXY1*FIVE*XX
     1      + YZZ1*FIVE*ZZ) + THIRTY*XYZ1*XZ)*DUM
        TMY2 = (-YYY1*SIX*YY - XXX1*SIX*XY - ZZZ1*SIX*YZ
     1      + THREE*(-XYY1*TWO*XY - YYZ1*TWO*YZ - XXY1*TWO*YY
     1      - YZZ1*TWO*YY - XXZ1*TWO*YZ - XZZ1*TWO*XY))*DUM
        TMZ1 = (ZZZ1*FIFTEN*ZZ
     1      + THREE*(YZZ1*TEN*YZ + XZZ1*TEN*XZ + YYZ1*FIVE*YY
     1      + XXZ1*FIVE*XX) + THIRTY*XYZ1*XY)*DUM
        TMZ2 = (-ZZZ1*SIX*ZZ - YYY1*SIX*YZ - XXX1*SIX*XZ
     1      + THREE*(-YZZ1*TWO*YZ - XZZ1*TWO*XZ - YYZ1*TWO*ZZ
     1      - XXZ1*TWO*ZZ - XYY1*TWO*XZ - XXY1*TWO*YZ))*DUM
        TMX = TMX1 + TMX2
        TMY = TMY1 + TMY2
        TMZ = TMZ1 + TMZ2
C           EF3(1,IC2)=EF3(1,IC2)+TMX-TERMX
C           EF3(2,IC2)=EF3(2,IC2)+TMY-TERMY
C           EF3(3,IC2)=EF3(3,IC2)+TMZ-TERMZ
C           EF3(1,IC1)=EF3(1,IC1)-TMX+TERMX
C           EF3(2,IC1)=EF3(2,IC1)-TMY+TERMY
C           EF3(3,IC1)=EF3(3,IC1)-TMZ+TERMZ
C     ATORQ(1,IM)=ATORQ(1,IM)+Y*TMZ1-Z*TMY1
C     ATORQ(2,IM)=ATORQ(2,IM)+Z*TMX1-X*TMZ1
C     ATORQ(3,IM)=ATORQ(3,IM)+X*TMY1-Y*TMX1
             CONX = TMX - TERMX
             CONY = TMY - TERMY
             CONZ = TMZ - TERMZ
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -(Y*TMZ1 - Z*TMY1)             )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -(Z*TMX1 - X*TMZ1)             )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -(X*TMY1 - Y*TMX1)             )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
      RETURN
      END
C*MODULE EFELEC  *DECK DDPQUD
      SUBROUTINE DDPQUD(QUA)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,*)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      DATA MD         /8HMD      /
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA FIFTEN/15.0D+00/
      DATA THREE,FIVE,SIX,SEVEN/3.0D+00,5.0D+00,6.0D+00,7.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
      DOT = DX2*X + DY2*Y + DZ2*Z
C
      DUM9 = SEVEN/R9
      DUMA = FIFTEN/R7
      AFXX = (TWO*DX2*X)*DUMA
      AFYY = (TWO*DY2*Y)*DUMA
      AFZZ = (TWO*DZ2*Z)*DUMA
      AFXY = (DX2*Y+DY2*X)*DUMA
      AFXZ = (DX2*Z+DZ2*X)*DUMA
      AFYZ = (DY2*Z+DZ2*Y)*DUMA
        TERM = XX1*AFXX + YY1*AFYY + ZZ1*AFZZ
     1       + TWO*(XY1*AFXY + XZ1*AFXZ + YZ1*AFYZ)
        TERM = TERM/3
C
      TERMX = TWO*(XX1*DX2+XY1*DY2+XZ1*DZ2)/R5
      TERMY = TWO*(YY1*DY2+XY1*DX2+YZ1*DZ2)/R5
      TERMZ = TWO*(ZZ1*DZ2+YZ1*DY2+XZ1*DX2)/R5
C
      TORQX = TWO*(XX1*X+XY1*Y+XZ1*Z)/R5
      TORQY = TWO*(YY1*Y+XY1*X+YZ1*Z)/R5
      TORQZ = TWO*(ZZ1*Z+YZ1*Y+XZ1*X)/R5
C
      DDOT=XX1*XX+YY1*YY+ZZ1*ZZ+TWO*(XY1*XY+XZ1*XZ+YZ1*YZ)
      TERMC = FIVE*DOT*DUM9*DDOT
      TORQC = FIVE*DDOT/R7
C
      TERMDX = FIVE*(XX1*(TWO*X*DOT+XX*DX2)+YY1*YY*DX2+ZZ1*ZZ*DX2
     $     +TWO*(XY1*(Y*DOT+XY*DX2)+XZ1*(Z*DOT+XZ*DX2)+YZ1*YZ*DX2))/R7
      TERMDY = FIVE*(YY1*(TWO*Y*DOT+YY*DY2)+XX1*XX*DY2+ZZ1*ZZ*DY2
     $     +TWO*(XY1*(X*DOT+XY*DY2)+YZ1*(Z*DOT+YZ*DY2)+XZ1*XZ*DY2))/R7
      TERMDZ = FIVE*(ZZ1*(TWO*Z*DOT+ZZ*DZ2)+XX1*XX*DZ2+YY1*YY*DZ2
     $     +TWO*(YZ1*(Y*DOT+YZ*DZ2)+XZ1*(X*DOT+XZ*DZ2)+XY1*XY*DZ2))/R7
C
      FXX = DUMA*DOT*XX-SIX*DX2*X/R5
      FYY = DUMA*DOT*YY-SIX*DY2*Y/R5
      FZZ = DUMA*DOT*ZZ-SIX*DZ2*Z/R5
      FXY = DUMA*DOT*XY-THREE*(DX2*Y+DY2*X)/R5
      FXZ = DUMA*DOT*XZ-THREE*(DX2*Z+DZ2*X)/R5
      FYZ = DUMA*DOT*YZ-THREE*(DZ2*Y+DY2*Z)/R5
C
C
C           EF3(1,IC2)=EF3(1,IC2)-(TERM-TERMC)*X+TERMX-TERMDX
C           EF3(2,IC2)=EF3(2,IC2)-(TERM-TERMC)*Y+TERMY-TERMDY
C           EF3(3,IC2)=EF3(3,IC2)-(TERM-TERMC)*Z+TERMZ-TERMDZ
C           EF3(1,IC1)=EF3(1,IC1)+(TERM-TERMC)*X-TERMX+TERMDX
C           EF3(2,IC1)=EF3(2,IC1)+(TERM-TERMC)*Y-TERMY+TERMDY
C           EF3(3,IC1)=EF3(3,IC1)+(TERM-TERMC)*Z-TERMZ+TERMDZ
C
      TDX = TORQY*DZ2-TORQZ*DY2+TORQC*(Z*DY2-Y*DZ2)
      TDY = TORQZ*DX2-TORQX*DZ2+TORQC*(X*DZ2-Z*DX2)
      TDZ = TORQX*DY2-TORQY*DX2+TORQC*(Y*DX2-X*DY2)
C     ATORQ(1,JM)=ATORQ(1,JM)+TDX
C     ATORQ(2,JM)=ATORQ(2,JM)+TDY
C     ATORQ(3,JM)=ATORQ(3,JM)+TDZ
C     ATORQ(1,IM)=ATORQ(1,IM)-TWO*(YZ1*FYY+ZZ1*FYZ+XZ1*FXY
C    $                       -YY1*FYZ-YZ1*FZZ-XY1*FXZ)/THREE
C     ATORQ(2,IM)=ATORQ(2,IM)-TWO*(XZ1*FZZ+XX1*FXZ+XY1*FYZ
C    $                       -ZZ1*FXZ-XZ1*FXX-YZ1*FXY)/THREE
C     ATORQ(3,IM)=ATORQ(3,IM)-TWO*(XY1*FXX+YY1*FXY+YZ1*FXZ
C    $                       -XX1*FXY-XY1*FYY-XZ1*FYZ)/THREE
C     ATORQ(1,IM)=ATORQ(1,IM)-Z*(TERMY-TERMDY)+Y*(TERMZ-TERMDZ)-TDX
C     ATORQ(2,IM)=ATORQ(2,IM)-X*(TERMZ-TERMDZ)+Z*(TERMX-TERMDX)-TDY
C     ATORQ(3,IM)=ATORQ(3,IM)-Y*(TERMX-TERMDX)+X*(TERMY-TERMDY)-TDZ
             CONX = -(TERM-TERMC)*X+TERMX-TERMDX
             CONY = -(TERM-TERMC)*Y+TERMY-TERMDY
             CONZ = -(TERM-TERMC)*Z+TERMZ-TERMDZ
             TORQX= -TWO*(YZ1*FYY+ZZ1*FYZ+XZ1*FXY
     $              -YY1*FYZ-YZ1*FZZ-XY1*FXZ)/THREE
             TORQY= -TWO*(XZ1*FZZ+XX1*FXZ+XY1*FYZ
     $              -ZZ1*FXZ-XZ1*FXX-YZ1*FXY)/THREE
             TORQZ= -TWO*(XY1*FXX+YY1*FXY+YZ1*FXZ
     $              -XX1*FXY-XY1*FYY-XZ1*FYZ)/THREE
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                      +TDX       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                      +TDY       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                      +TDZ       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -TORQX       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -TORQY       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -TORQZ       )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DQDQD
      SUBROUTINE DQDQD(QUA)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION NINE
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,*)
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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      DATA MD         /8HMD      /
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA THREE,NINE/3.0D+00,9.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      TOTHR=TWO/THREE
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
               IF (IM.GE.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOQUAD(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  XX2 = QUA(1,IC2)
                  YY2 = QUA(2,IC2)
                  ZZ2 = QUA(3,IC2)
                  XY2 = QUA(4,IC2)
                  XZ2 = QUA(5,IC2)
                  YZ2 = QUA(6,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
                  R11 = R2*R9
C
                  QUAD1 = XX1*XX2 + TWO*XY1*XY2 + TWO*XZ1*XZ2
                  QUAD1 = QUAD1 + YY1*YY2 + TWO*YZ1*YZ2 + ZZ1*ZZ2
                  DQU1 = QUAD1 * 30.0D+00 / R7
                  VAL2X = X*XX2 + Y*XY2 + Z*XZ2
                  VAL2Y = X*XY2 + Y*YY2 + Z*YZ2
                  VAL2Z = X*XZ2 + Y*YZ2 + Z*ZZ2
                  VAL2 = X*VAL2X + Y*VAL2Y + Z*VAL2Z
                  VAL1X = X*XX1+Y*XY1+Z*XZ1
                  VAL1Y = X*XY1+Y*YY1+Z*YZ1
                  VAL1Z = X*XZ1+Y*YZ1+Z*ZZ1
                  VAL1 = X*VAL1X + Y*VAL1Y + Z*VAL1Z
                  FACT1X = X*XX1 + Y*XY1 + Z*XZ1
                  FACT2X = X*XX2 + Y*XY2 + Z*XZ2
                  FACT1Y = X*XY1 + Y*YY1 + Z*YZ1
                  FACT2Y = X*XY2 + Y*YY2 + Z*YZ2
                  FACT1Z = X*XZ1 + Y*YZ1 + Z*ZZ1
                  FACT2Z = X*XZ2 + Y*YZ2 + Z*ZZ2
                  DQU2 =  VAL1*VAL2*945.0D+00 / R11
                  DQU2X =  (FACT1X*VAL2+FACT2X*VAL1) * 210.0D+00 / R9
                  DQU2Y =  (FACT1Y*VAL2+FACT2Y*VAL1) * 210.0D+00 / R9
                  DQU2Z =  (FACT1Z*VAL2+FACT2Z*VAL1) * 210.0D+00 / R9
                  DQU3 = FACT1X*FACT2X+FACT1Y*FACT2Y+FACT1Z*FACT2Z
                  DQU3 = DQU3 * 420.0D+00 / R9
                  DQU3X = (XX1*FACT2X + XX2*FACT1X
     1                  + XY1*FACT2Y + XY2*FACT1Y
     1                  + XZ1*FACT2Z + XZ2*FACT1Z) * 60.0D+00 / R7
                  DQU3Y = (XY1*FACT2X + XY2*FACT1X
     1                  + YY1*FACT2Y + YY2*FACT1Y
     1                  + YZ1*FACT2Z + YZ2*FACT1Z) * 60.0D+00 / R7
                  DQU3Z = (XZ1*FACT2X + XZ2*FACT1X
     1                  + YZ1*FACT2Y + YZ2*FACT1Y
     1                  + ZZ1*FACT2Z + ZZ2*FACT1Z) * 60.0D+00 / R7
       F1XX = TWO*XX1/R5-20.0D+00*X*VAL1X/R7+35.0D+00*XX*VAL1/R9
       F1YY = TWO*YY1/R5-20.0D+00*Y*VAL1Y/R7+35.0D+00*YY*VAL1/R9
       F1ZZ = TWO*ZZ1/R5-20.0D+00*Z*VAL1Z/R7+35.0D+00*ZZ*VAL1/R9
       F1XY = TWO*XY1/R5-10.0D+00*(Y*VAL1X+X*VAL1Y)/R7
     *                  +35.0D+00*XY*VAL1/R9
       F1XZ = TWO*XZ1/R5-10.0D+00*(Z*VAL1X+X*VAL1Z)/R7
     *                  +35.0D+00*XZ*VAL1/R9
       F1YZ = TWO*YZ1/R5-10.0D+00*(Z*VAL1Y+Y*VAL1Z)/R7
     *                  +35.0D+00*YZ*VAL1/R9
C
       F2XX = TWO*XX2/R5-20.0D+00*X*VAL2X/R7+35.0D+00*XX*VAL2/R9
       F2YY = TWO*YY2/R5-20.0D+00*Y*VAL2Y/R7+35.0D+00*YY*VAL2/R9
       F2ZZ = TWO*ZZ2/R5-20.0D+00*Z*VAL2Z/R7+35.0D+00*ZZ*VAL2/R9
       F2XY = TWO*XY2/R5-10.0D+00*(Y*VAL2X+X*VAL2Y)/R7
     *                  +35.0D+00*XY*VAL2/R9
       F2XZ = TWO*XZ2/R5-10.0D+00*(Z*VAL2X+X*VAL2Z)/R7
     *                  +35.0D+00*XZ*VAL2/R9
       F2YZ = TWO*YZ2/R5-10.0D+00*(Z*VAL2Y+Y*VAL2Z)/R7
     *                  +35.0D+00*YZ*VAL2/R9
C
C        EF3(1,IC2)=EF3(1,IC2)+(X*(DQU1+DQU2-DQU3)-DQU2X+DQU3X)/NINE
C        EF3(2,IC2)=EF3(2,IC2)+(Y*(DQU1+DQU2-DQU3)-DQU2Y+DQU3Y)/NINE
C        EF3(3,IC2)=EF3(3,IC2)+(Z*(DQU1+DQU2-DQU3)-DQU2Z+DQU3Z)/NINE
C        EF3(1,IC1)=EF3(1,IC1)+(-X*(DQU1+DQU2-DQU3)+DQU2X-DQU3X)/NINE
C        EF3(2,IC1)=EF3(2,IC1)+(-Y*(DQU1+DQU2-DQU3)+DQU2Y-DQU3Y)/NINE
C        EF3(3,IC1)=EF3(3,IC1)+(-Z*(DQU1+DQU2-DQU3)+DQU2Z-DQU3Z)/NINE
C     ATORQ(1,JM)=ATORQ(1,JM)+(YY2*F1YZ+YZ2*F1ZZ+XY2*F1XZ
C    1            -(YZ2*F1YY+ZZ2*F1YZ+XZ2*F1XY))*TOTHR
C     ATORQ(2,JM)=ATORQ(2,JM)+(ZZ2*F1XZ+XZ2*F1XX+YZ2*F1XY
C    1            -(XZ2*F1ZZ+XX2*F1XZ+XY2*F1YZ))*TOTHR
C     ATORQ(3,JM)=ATORQ(3,JM)+(XX2*F1XY+XY2*F1YY+XZ2*F1YZ
C    1            -(XY2*F1XX+YY2*F1XY+YZ2*F1XZ))*TOTHR
C
C     ATORQ(1,IM)=ATORQ(1,IM)+(YY1*F2YZ+YZ1*F2ZZ+XY1*F2XZ
C    1            -(YZ1*F2YY+ZZ1*F2YZ+XZ1*F2XY))*TOTHR
C     ATORQ(2,IM)=ATORQ(2,IM)+(ZZ1*F2XZ+XZ1*F2XX+YZ1*F2XY
C    1            -(XZ1*F2ZZ+XX1*F2XZ+XY1*F2YZ))*TOTHR
C     ATORQ(3,IM)=ATORQ(3,IM)+(XX1*F2XY+XY1*F2YY+XZ1*F2YZ
C    1            -(XY1*F2XX+YY1*F2XY+YZ1*F2XZ))*TOTHR
             CONX = (X*(DQU1+DQU2-DQU3)-DQU2X+DQU3X)/NINE
             CONY = (Y*(DQU1+DQU2-DQU3)-DQU2Y+DQU3Y)/NINE
             CONZ = (Z*(DQU1+DQU2-DQU3)-DQU2Z+DQU3Z)/NINE
             TORQJX= (YY2*F1YZ+YZ2*F1ZZ+XY2*F1XZ
     *              -(YZ2*F1YY+ZZ2*F1YZ+XZ2*F1XY))*TOTHR
             TORQJY= (ZZ2*F1XZ+XZ2*F1XX+YZ2*F1XY
     *              -(XZ2*F1ZZ+XX2*F1XZ+XY2*F1YZ))*TOTHR
             TORQJZ= (XX2*F1XY+XY2*F1YY+XZ2*F1YZ
     *              -(XY2*F1XX+YY2*F1XY+YZ2*F1XZ))*TOTHR
             TORQIX= (YY1*F2YZ+YZ1*F2ZZ+XY1*F2XZ
     *              -(YZ1*F2YY+ZZ1*F2YZ+XZ1*F2XY))*TOTHR
             TORQIY= (ZZ1*F2XZ+XZ1*F2XX+YZ1*F2XY
     *              -(XZ1*F2ZZ+XX1*F2XZ+XY1*F2YZ))*TOTHR
             TORQIZ= (XX1*F2XY+XY1*F2YY+XZ1*F2YZ
     *              -(XY1*F2XX+YY1*F2XY+YZ1*F2XZ))*TOTHR
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                      +TORQJX       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                      +TORQJY       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                      +TORQJZ       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -TORQIX       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -TORQIY       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -TORQIZ       )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
C
      RETURN
      END
C*MODULE EFELEC  *DECK DCHIND
      SUBROUTINE DCHIND
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      DATA MD         /8HMD      /
C
      DATA ONE,TWO/1.0D+00,2.0D+00/
      DATA PT5/0.5D+00/
      DATA THREE,FOUR/3.0D+00,4.0D+00/
      DATA ZERO/0.0D+00/
C
      IC1=0
C
C      DO I=1,10
C      WRITE(6,*) 'DIND,DINDD = ',DIND(1,I),DINDD(1,I)
C      ENDDO
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
C           DX1 = DIND(1,IC1)
C           DY1 = DIND(2,IC1)
C           DZ1 = DIND(3,IC1)
            DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
            DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
            DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               CFR = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     EX = ZERO
                     CF = ZERO
                  ELSE
                     EX = EFATRM(IC2)
                     CF = EFBTRM(IC2)
                  END IF
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R3
      DOT = DX1*X + DY1*Y + DZ1*Z
      IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
         CFR =  DUM
         CN1 = (THREE/R5)*DOT*Q2
      ELSE
         EX2=EXP(-EX*R2)
         SCREEN=1.0D+00-CF*EX2
         CFR =  DUM*SCREEN - TWO*Q2*CF*EX*EX2/R
         CN1 = (THREE*SCREEN/R5 - FOUR*CF*EX*EX2*(ONE/R3 + EX/R))*DOT*Q2
      END IF
      CONX = DX1*CFR - X*CN1
      CONY = DY1*CFR - Y*CN1
      CONZ = DZ1*CFR - Z*CN1
C
C     IIC1=IC1+NMTTPT
C     EF3(1,IC2) = EF3(1,IC2) + CONX
C     EF3(2,IC2) = EF3(2,IC2) + CONY
C     EF3(3,IC2) = EF3(3,IC2) + CONZ
C     EF3(1,IIC1) = EF3(1,IIC1) - CONX
C     EF3(2,IIC1) = EF3(2,IIC1) - CONY
C     EF3(3,IIC1) = EF3(3,IIC1) - CONZ
C     ATORQ(1,IM) = ATORQ(1,IM) - CFR*(DY1*Z-DZ1*Y)
C     ATORQ(2,IM) = ATORQ(2,IM) - CFR*(DZ1*X-DX1*Z)
C     ATORQ(3,IM) = ATORQ(3,IM) - CFR*(DX1*Y-DY1*X)
C
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                      +CFR*(DY1*Z-DZ1*Y)             )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                      +CFR*(DZ1*X-DX1*Z)             )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +CFR*(DX1*Y-DY1*X)             )
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DININ
      SUBROUTINE DININ
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
C
      DATA FIFTEN/15.0D+00/, THREE/3.0D+00/, ZERO/0.0D+00/
C
      IC1=0
C
      IF (GOPARR) THEN
         DO I=1,NLOW-1
            IC1 = IC1 + NPPTS(I)
         ENDDO
      ENDIF
C
C       PARALLELIZE THE ORIGINAL LOOP: DO 400 IM = 1,NFRG
C
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            DX1 = 0.50D+00*DIND(1,IC1)
            DY1 = 0.50D+00*DIND(2,IC1)
            DZ1 = 0.50D+00*DIND(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
C              WE NEED TO DO BOTH IM*JM AND JM*IM
C              BECAUSE DIND AND DINDD ARE DIFFERENT
C              FOR ASYMMETRIC POLARIZABILITY TENSORS
C
               IF (IM.EQ.JM) THEN
                  IC2=IC2+NPPTS(JM)
                  GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                  COMX2 = EFCENT(1,JM)
                  COMY2 = EFCENT(2,JM)
                  COMZ2 = EFCENT(3,JM)
C
                  COMX = COMX1 - COMX2
                  COMY = COMY1 - COMY2
                  COMZ = COMZ1 - COMZ2
C
                  PBCX = BOXL * ANINT(COMX * BOXLI)
                  PBCY = BOXL * ANINT(COMY * BOXLI)
                  PBCZ = BOXL * ANINT(COMZ * BOXLI)
               END  IF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DFX2 = ZERO
               DFY2 = ZERO
               DFZ2 = ZERO
               DFX1 = ZERO
               DFY1 = ZERO
               DFZ1 = ZERO
C
               DO 370 JP = 1,NPPTS(JM)
                  IC2=IC2+1
                  X2 = EFP(1,IC2)
                  Y2 = EFP(2,IC2)
                  Z2 = EFP(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = DINDD(1,IC2)
                  DY2 = DINDD(2,IC2)
                  DZ2 = DINDD(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                  IF ( RUNTYP .EQ. MD ) THEN
                     X = X - PBCX
                     Y = Y - PBCY
                     Z = Z - PBCZ
                  END IF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R  = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
                  DOT1 = DX1*X + DY1*Y + DZ1*Z
                  DOT2 = DX2*X + DY2*Y + DZ2*Z
                  DOTM = DX2*DX1 + DY2*DY1 + DZ2*DZ1
                  DOTXY= DY2*DX1+DY1*DX2
                  DOTXZ= DZ2*DX1+DZ1*DX2
                  DOTYZ= DY2*DZ1+DY1*DZ2
                  DOTX = 2.0D+00*DX2*DX1*X+DOTXY*Y+DOTXZ*Z
                  DOTY = 2.0D+00*DY2*DY1*Y+DOTXY*X+DOTYZ*Z
                  DOTZ = 2.0D+00*DZ2*DZ1*Z+DOTXZ*X+DOTYZ*Y
                  DUM = THREE/R5
                  DUM2= DUM*DOT2
                  DUM1= DUM*DOT1
                  TEMP = DX1*DX2*XX + DY1*DY2*YY + DZ1*DZ2*ZZ
     *                 +(DX1*DY2+DY1*DX2)*XY
     *                 +(DX1*DZ2+DZ1*DX2)*XZ
     *                 +(DY1*DZ2+DZ1*DY2)*YZ
                  DUM7 = FIFTEN*TEMP/R7
                  DFX2 = -DX2/R3 + X*DUM2
                  DFY2 = -DY2/R3 + Y*DUM2
                  DFZ2 = -DZ2/R3 + Z*DUM2
                  DFX1 = -DX1/R3 + X*DUM1
                  DFY1 = -DY1/R3 + Y*DUM1
                  DFZ1 = -DZ1/R3 + Z*DUM1
                  CONX = DUM*(DOTM*X+DOTX)-DUM7*X
                  CONY = DUM*(DOTM*Y+DOTY)-DUM7*Y
                  CONZ = DUM*(DOTM*Z+DOTZ)-DUM7*Z
C
C                 IIC1=IC1+NMTTPT
C                 IIC2=IC2+NMTTPT
C
C                 EF3(1,IIC2)=EF3(1,IIC2)+CONX
C                 EF3(2,IIC2)=EF3(2,IIC2)+CONY
C                 EF3(3,IIC2)=EF3(3,IIC2)+CONZ
C                 EF3(1,IIC1)=EF3(1,IIC1)-CONX
C                 EF3(2,IIC1)=EF3(2,IIC1)-CONY
C                 EF3(3,IIC1)=EF3(3,IIC1)-CONZ
C
C                 ATORQ(1,IM)=ATORQ(1,IM)-DY1*DFZ2+DZ1*DFY2
C                 ATORQ(2,IM)=ATORQ(2,IM)-DZ1*DFX2+DX1*DFZ2
C                 ATORQ(3,IM)=ATORQ(3,IM)-DX1*DFY2+DY1*DFX2
C                 ATORQ(1,JM)=ATORQ(1,JM)-DY2*DFZ1+DZ2*DFY1
C                 ATORQ(2,JM)=ATORQ(2,JM)-DZ2*DFX1+DX2*DFZ1
C                 ATORQ(3,JM)=ATORQ(3,JM)-DX2*DFY1+DY2*DFX1
C
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFP(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFP(3,IC2)-EFCENT(3,JM))
     *                      -(DY2*DFZ1-DZ2*DFY1)       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFP(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFP(1,IC2)-EFCENT(1,JM))
     *                      -(DZ2*DFX1-DX2*DFZ1)       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFP(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFP(2,IC2)-EFCENT(2,JM))
     *                      -(DX2*DFY1-DY2*DFX1)       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                      +(DY1*DFZ2-DZ1*DFY2)       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                      +(DZ1*DFX2-DX1*DFZ2)       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +(DX1*DFY2-DY1*DFX2)       )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
C     - APPLY SWITCHING FUNCTION CORRECTIONS TO INDUCED DIPOLE GRADIENTS
C
      IF((XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO).AND.
     *   (SWR1.LE.1000.0D+00 .AND. SWR2.LE.1000.0D+00)) THEN
         CALL INDCHG
         CALL INDDPL
         CALL INDIND
         CALL INDQUA
      END IF
C
      RETURN
      END
C*MODULE EFELEC  *DECK DDPIND
      SUBROUTINE DDPIND
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      DATA THREE/3.0D+00/, ZERO/0.0D+00/
      DATA PT5/0.5D+00/
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
C           DX1 = (DIND(1,IC1))
C           DY1 = (DIND(2,IC1))
C           DZ1 = (DIND(3,IC1))
            DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
            DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
            DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DFX2 = ZERO
               DFY2 = ZERO
               DFZ2 = ZERO
               DFX1 = ZERO
               DFY1 = ZERO
               DFZ1 = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
                  IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
                  DOT1 = DX1*X + DY1*Y + DZ1*Z
                  DOT2 = DX2*X + DY2*Y + DZ2*Z
                  DOTM = DX2*DX1 + DY2*DY1 + DZ2*DZ1
                  DOTXY=DY2*DX1+DY1*DX2
                  DOTXZ=DZ2*DX1+DZ1*DX2
                  DOTYZ=DY2*DZ1+DY1*DZ2
                  DOTX = 2.0D+00*DX2*DX1*X+DOTXY*Y+DOTXZ*Z
                  DOTY = 2.0D+00*DY2*DY1*Y+DOTXY*X+DOTYZ*Z
                  DOTZ = 2.0D+00*DZ2*DZ1*Z+DOTXZ*X+DOTYZ*Y
                  DUM = THREE/R5
                  DUM2=DUM*DOT2
                  DUM1=DUM*DOT1
                  TEMP = DX1*DX2*XX+DY1*DY2*YY+DZ1*DZ2*ZZ
     *             +(DX1*DY2+DY1*DX2)*XY+(DX1*DZ2+DZ1*DX2)*XZ
     *             +(DY1*DZ2+DZ1*DY2)*YZ
                  DUM7 = 15.0D+00*TEMP/R7
                  DFX2 = -DX2/R3 + X*DUM2
                  DFY2 = -DY2/R3 + Y*DUM2
                  DFZ2 = -DZ2/R3 + Z*DUM2
                  DFX1 = -DX1/R3 + X*DUM1
                  DFY1 = -DY1/R3 + Y*DUM1
                  DFZ1 = -DZ1/R3 + Z*DUM1
                  CONX = DUM*(DOTM*X+DOTX)-DUM7*X
                  CONY = DUM*(DOTM*Y+DOTY)-DUM7*Y
                  CONZ = DUM*(DOTM*Z+DOTZ)-DUM7*Z
C
C                 IIC1=IC1+NMTTPT
C                 EF3(1,IC2)=EF3(1,IC2)+CONX
C                 EF3(2,IC2)=EF3(2,IC2)+CONY
C                 EF3(3,IC2)=EF3(3,IC2)+CONZ
C                 EF3(1,IIC1)=EF3(1,IIC1)-CONX
C                 EF3(2,IIC1)=EF3(2,IIC1)-CONY
C                 EF3(3,IIC1)=EF3(3,IIC1)-CONZ
C
C                 ATORQ(1,IM)=ATORQ(1,IM)-DY1*DFZ2+DZ1*DFY2
C                 ATORQ(2,IM)=ATORQ(2,IM)-DZ1*DFX2+DX1*DFZ2
C                 ATORQ(3,IM)=ATORQ(3,IM)-DX1*DFY2+DY1*DFX2
C                 ATORQ(1,JM)=ATORQ(1,JM)-DY2*DFZ1+DZ2*DFY1
C                 ATORQ(2,JM)=ATORQ(2,JM)-DZ2*DFX1+DX2*DFZ1
C                 ATORQ(3,JM)=ATORQ(3,JM)-DX2*DFY1+DY2*DFX1
C
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -(DY2*DFZ1-DZ2*DFY1)       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -(DZ2*DFX1-DX2*DFZ1)       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                      -(DX2*DFY1-DY2*DFX1)       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                      +(DY1*DFZ2-DZ1*DFY2)       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                      +(DZ1*DFX2-DX1*DFZ2)       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +(DX1*DFY2-DY1*DFX2)       )
C
  370          CONTINUE
  380       CONTINUE
  390    CONTINUE
  400 CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DQDIND
      SUBROUTINE DQDIND(QUA)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD,MDTYP
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,*)
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 /EFPAR / LOCNFG,NLOW,NUP
      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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA FIFTEN/15.0D+00/
      DATA THREE,FIVE,SIX,SEVEN/3.0D+00,5.0D+00,6.0D+00,7.0D+00/
      DATA ZERO/0.0D+00/
C
C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C.... EQUATION 15.                                          ....
C
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
C     DO 400 IM = 1,NFRG
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
               DO 370 JP = 1,NPPTS(JM)
                  IC2=IC2+1
                  X2 = EFP(1,IC2)
                  Y2 = EFP(2,IC2)
                  Z2 = EFP(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
C                 DX2 = (DIND(1,IC2))
C                 DY2 = (DIND(2,IC2))
C                 DZ2 = (DIND(3,IC2))
                  DX2 = PT5*(DIND(1,IC2)+DINDD(1,IC2))
                  DY2 = PT5*(DIND(2,IC2)+DINDD(2,IC2))
                  DZ2 = PT5*(DIND(3,IC2)+DINDD(3,IC2))
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
      DOT = DX2*X + DY2*Y + DZ2*Z
C
      DUM9 = SEVEN/R9
      DUMA = FIFTEN/R7
      AFXX = (TWO*DX2*X)*DUMA
      AFYY = (TWO*DY2*Y)*DUMA
      AFZZ = (TWO*DZ2*Z)*DUMA
      AFXY = (DX2*Y+DY2*X)*DUMA
      AFXZ = (DX2*Z+DZ2*X)*DUMA
      AFYZ = (DY2*Z+DZ2*Y)*DUMA
        TERM = XX1*AFXX + YY1*AFYY + ZZ1*AFZZ
     1       + TWO*(XY1*AFXY + XZ1*AFXZ + YZ1*AFYZ)
        TERM = TERM/THREE
C
      TERMX = TWO*(XX1*DX2+XY1*DY2+XZ1*DZ2)/R5
      TERMY = TWO*(YY1*DY2+XY1*DX2+YZ1*DZ2)/R5
      TERMZ = TWO*(ZZ1*DZ2+YZ1*DY2+XZ1*DX2)/R5
C
      TORQX = TWO*(XX1*X+XY1*Y+XZ1*Z)/R5
      TORQY = TWO*(YY1*Y+XY1*X+YZ1*Z)/R5
      TORQZ = TWO*(ZZ1*Z+YZ1*Y+XZ1*X)/R5
C
      DDOT=XX1*XX+YY1*YY+ZZ1*ZZ+TWO*(XY1*XY+XZ1*XZ+YZ1*YZ)
      TERMC = FIVE*DOT*DUM9*DDOT
      TORQC = FIVE*DDOT/R7
C
      TERMDX = FIVE*(XX1*(TWO*X*DOT+XX*DX2)+YY1*YY*DX2+ZZ1*ZZ*DX2
     $     +TWO*(XY1*(Y*DOT+XY*DX2)+XZ1*(Z*DOT+XZ*DX2)+YZ1*YZ*DX2))/R7
      TERMDY = FIVE*(YY1*(TWO*Y*DOT+YY*DY2)+XX1*XX*DY2+ZZ1*ZZ*DY2
     $     +TWO*(XY1*(X*DOT+XY*DY2)+YZ1*(Z*DOT+YZ*DY2)+XZ1*XZ*DY2))/R7
      TERMDZ = FIVE*(ZZ1*(TWO*Z*DOT+ZZ*DZ2)+XX1*XX*DZ2+YY1*YY*DZ2
     $     +TWO*(YZ1*(Y*DOT+YZ*DZ2)+XZ1*(X*DOT+XZ*DZ2)+XY1*XY*DZ2))/R7
C
      FXX = DUMA*DOT*XX-SIX*DX2*X/R5
      FYY = DUMA*DOT*YY-SIX*DY2*Y/R5
      FZZ = DUMA*DOT*ZZ-SIX*DZ2*Z/R5
      FXY = DUMA*DOT*XY-THREE*(DX2*Y+DY2*X)/R5
      FXZ = DUMA*DOT*XZ-THREE*(DX2*Z+DZ2*X)/R5
      FYZ = DUMA*DOT*YZ-THREE*(DZ2*Y+DY2*Z)/R5
C
C           IIC2=IC2+NMTTPT
C           EF3(1,IIC2)=EF3(1,IIC2)-(TERM-TERMC)*X+TERMX-TERMDX
C           EF3(2,IIC2)=EF3(2,IIC2)-(TERM-TERMC)*Y+TERMY-TERMDY
C           EF3(3,IIC2)=EF3(3,IIC2)-(TERM-TERMC)*Z+TERMZ-TERMDZ
C           EF3(1,IC1)=EF3(1,IC1)+(TERM-TERMC)*X-TERMX+TERMDX
C           EF3(2,IC1)=EF3(2,IC1)+(TERM-TERMC)*Y-TERMY+TERMDY
C           EF3(3,IC1)=EF3(3,IC1)+(TERM-TERMC)*Z-TERMZ+TERMDZ
C
      TDX = TORQY*DZ2-TORQZ*DY2+TORQC*(Z*DY2-Y*DZ2)
      TDY = TORQZ*DX2-TORQX*DZ2+TORQC*(X*DZ2-Z*DX2)
      TDZ = TORQX*DY2-TORQY*DX2+TORQC*(Y*DX2-X*DY2)
C
C     ATORQ(1,JM)=ATORQ(1,JM)+TDX
C     ATORQ(2,JM)=ATORQ(2,JM)+TDY
C     ATORQ(3,JM)=ATORQ(3,JM)+TDZ
C     ATORQ(1,IM)=ATORQ(1,IM)-TWO*(YZ1*FYY+ZZ1*FYZ+XZ1*FXY
C    $                       -YY1*FYZ-YZ1*FZZ-XY1*FXZ)/THREE
C     ATORQ(2,IM)=ATORQ(2,IM)-TWO*(XZ1*FZZ+XX1*FXZ+XY1*FYZ
C    $                       -ZZ1*FXZ-XZ1*FXX-YZ1*FXY)/THREE
C     ATORQ(3,IM)=ATORQ(3,IM)-TWO*(XY1*FXX+YY1*FXY+YZ1*FXZ
C    $                       -XX1*FXY-XY1*FYY-XZ1*FYZ)/THREE
C
             CONX = -(TERM-TERMC)*X+TERMX-TERMDX
             CONY = -(TERM-TERMC)*Y+TERMY-TERMDY
             CONZ = -(TERM-TERMC)*Z+TERMZ-TERMDZ
             TORQX= -TWO*(YZ1*FYY+ZZ1*FYZ+XZ1*FXY
     $              -YY1*FYZ-YZ1*FZZ-XY1*FXZ)/THREE
             TORQY= -TWO*(XZ1*FZZ+XX1*FXZ+XY1*FYZ
     $              -ZZ1*FXZ-XZ1*FXX-YZ1*FXY)/THREE
             TORQZ= -TWO*(XY1*FXX+YY1*FXY+YZ1*FXZ
     $              -XX1*FXY-XY1*FYY-XZ1*FYZ)/THREE
             DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
             DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
             DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
             DESFRG(4,JM) = DESFRG(4,JM) + SWF*
     *                      (CONZ*(EFP(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFP(3,IC2)-EFCENT(3,JM))
     *                      +TDX       )
             DESFRG(5,JM) = DESFRG(5,JM) + SWF*
     *                      (CONX*(EFP(3,IC2)-EFCENT(3,JM))
     *                      -CONZ*(EFP(1,IC2)-EFCENT(1,JM))
     *                      +TDY       )
             DESFRG(6,JM) = DESFRG(6,JM) + SWF*
     *                      (CONY*(EFP(1,IC2)-EFCENT(1,JM))
     *                      -CONX*(EFP(2,IC2)-EFCENT(2,JM))
     *                      +TDZ       )
             DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
             DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
             DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
             DESFRG(4,IM) = DESFRG(4,IM) - SWF*
     *                      (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -TORQX       )
             DESFRG(5,IM) = DESFRG(5,IM) - SWF*
     *                      (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                      -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -TORQY       )
             DESFRG(6,IM) = DESFRG(6,IM) - SWF*
     *                      (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                      -TORQZ       )
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK EREPUL
      SUBROUTINE EREPUL(ELTOT,AREL,CREL,MXRPTS,NDFG2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION AREL(MXRPTS,MXRPTS,NDFG2),CREL(MXRPTS,MXRPTS,NDFG2)
C
      CHARACTER*8 REPNAM
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO = 0.00D+00)
C
      ELTOT = ZERO
C
      I=0
C
      IF (GOPARR) THEN
        DO IM=1,NLOW-1
          I = I + NRPTS(IM)
        ENDDO
      ENDIF
C
C     DO 200 IFRG = 1,NFRG
      DO 200 IFRG = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IFRG)
           COMY1 = EFCENT(2,IFRG)
           COMZ1 = EFCENT(3,IFRG)
         ENDIF
C
       IDX=ISET(IFRG)
       DO 100 IPR=1,NRPTS(IFRG)+1
        IF(IPR.LE.NRPTS(IFRG))I=I+1
      J=0
      DO 90 JFRG=1,NFRG
C
       IF(JFRG.LE.IFRG) THEN
        J=J+NRPTS(JFRG)
        GO TO 90
       END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JFRG)
                COMY2 = EFCENT(2,JFRG)
                COMZ2 = EFCENT(3,JFRG)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IFRG) - EFCENT(1,JFRG)
               Y12  = EFCENT(2,IFRG) - EFCENT(2,JFRG)
               Z12  = EFCENT(3,IFRG) - EFCENT(3,JFRG)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - XADD)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - YADD)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IFRG)-EFCENT(1,JFRG)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IFRG)-EFCENT(1,JFRG)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-ZADD)
                 END IF
               END IF
C
               END IF
C
       JDX=ISET(JFRG)
       IF (JDX.GE.IDX) THEN
          INDEX=JDX*(JDX-1)/2+IDX
       ELSE
          INDEX=IDX*(IDX-1)/2+JDX
       ENDIF
       DO 80 JPR=1,NRPTS(JFRG)+1
          IF(JPR.LE.NRPTS(JFRG)) J = J + 1
          IF(IPR.LE.NRPTS(IFRG)) THEN
            IF(JPR.LE.NRPTS(JFRG)) THEN
              XI = CREP(1,I)
              YI = CREP(2,I)
              ZI = CREP(3,I)
              XJ = CREP(1,J)
              YJ = CREP(2,J)
              ZJ = CREP(3,J)
            ELSE
              XI = CREP(1,I)
              YI = CREP(2,I)
              ZI = CREP(3,I)
              XJ = EFCENT(1,JFRG)
              YJ = EFCENT(2,JFRG)
              ZJ = EFCENT(3,JFRG)
            END IF
          ELSE
            IF(JPR.LE.NRPTS(JFRG)) THEN
              XI = EFCENT(1,IFRG)
              YI = EFCENT(2,IFRG)
              ZI = EFCENT(3,IFRG)
              XJ = CREP(1,J)
              YJ = CREP(2,J)
              ZJ = CREP(3,J)
            ELSE
              XI = EFCENT(1,IFRG)
              YI = EFCENT(2,IFRG)
              ZI = EFCENT(3,IFRG)
              XJ = EFCENT(1,JFRG)
              YJ = EFCENT(2,JFRG)
              ZJ = EFCENT(3,JFRG)
            END IF
          END IF
C
          XJ = XJ + XADD
          YJ = YJ + YADD
          ZJ = ZJ + ZADD
          IF ( RUNTYP .EQ. MD ) THEN
            XJ = XJ + PBCX
            YJ = YJ + PBCY
            ZJ = ZJ + PBCZ
          END IF
C
          RR = (XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
          RVAL = SQRT(RR)
          IF (JDX.GE.IDX) THEN
             EPAIR = CREL(JPR,IPR,INDEX)
     *               * EXP(-AREL(JPR,IPR,INDEX)*RVAL)
          ELSE
             EPAIR = CREL(IPR,JPR,INDEX)
     *               * EXP(-AREL(IPR,JPR,INDEX)*RVAL)
          END IF
C
          ELTOT = ELTOT + SWF*EPAIR
          DESFRG(1,JFRG) = DESFRG(1,JFRG) - EPAIR*SWFDX
          DESFRG(2,JFRG) = DESFRG(2,JFRG) - EPAIR*SWFDY
          DESFRG(3,JFRG) = DESFRG(3,JFRG) - EPAIR*SWFDZ
          DESFRG(1,IFRG) = DESFRG(1,IFRG) + EPAIR*SWFDX
          DESFRG(2,IFRG) = DESFRG(2,IFRG) + EPAIR*SWFDY
          DESFRG(3,IFRG) = DESFRG(3,IFRG) + EPAIR*SWFDZ
   80  CONTINUE
   90  CONTINUE
  100  CONTINUE
  200 CONTINUE
C
      IF(GOPARR) CALL DDI_GSUMF(667,ELTOT,1)
C
      RETURN
      END
C*MODULE EFELEC  *DECK DREPUL
      SUBROUTINE DREPUL(AREL,CREL,MXRPTS,NDFG2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION AREL(MXRPTS,MXRPTS,NDFG2),CREL(MXRPTS,MXRPTS,NDFG2)
C
      CHARACTER*8 REPNAM
C
      DOUBLE PRECISION  MD,MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
C
      COMMON /INTFRG/ EFF(3,MXFRG),EFF2(3,MXFRG)
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO = 0.0D+00)
C
      DO 17 II=1,NFRG
      DO 17 K=1,3
      EFF(K,II)=ZERO
 17   CONTINUE
C
      I=0
C
      IF (GOPARR) THEN
        DO IM=1,NLOW-1
          I = I + NRPTS(IM)
        ENDDO
      ENDIF
C
C      DO 200 IFRG = 1,NFRG
      DO 200 IFRG = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IFRG)
           COMY1 = EFCENT(2,IFRG)
           COMZ1 = EFCENT(3,IFRG)
         ENDIF
C
       IDX=ISET(IFRG)
       DO 100 IPR=1,NRPTS(IFRG)+1
        IF(IPR.LE.NRPTS(IFRG))I=I+1
        II=I+NMTTPT+NPTTPT
      J=0
      DO 90 JFRG=1,NFRG
C
       IF(JFRG.LE.IFRG) THEN
        J=J+NRPTS(JFRG)
        GO TO 90
       END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JFRG)
                COMY2 = EFCENT(2,JFRG)
                COMZ2 = EFCENT(3,JFRG)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IFRG) - EFCENT(1,JFRG)
               Y12  = EFCENT(2,IFRG) - EFCENT(2,JFRG)
               Z12  = EFCENT(3,IFRG) - EFCENT(3,JFRG)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - XADD)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - YADD)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 J=J+NRPTS(JFRG)
                 GO TO 90
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
      JDX=ISET(JFRG)
      DO 80 JPR=1,NRPTS(JFRG)+1
         IF(JPR.LE.NRPTS(JFRG))J=J+1
         IF (JDX.GE.IDX) THEN
            INDEX=JDX*(JDX-1)/2+IDX
            CF = CREL(JPR,IPR,INDEX)
            AE = AREL(JPR,IPR,INDEX)
         ELSE
            INDEX=IDX*(IDX-1)/2+JDX
            CF = CREL(IPR,JPR,INDEX)
            AE = AREL(IPR,JPR,INDEX)
         END IF
         IF(IPR.LE.NRPTS(IFRG)) THEN
               IF(JPR.LE.NRPTS(JFRG)) THEN
                 XI = CREP(1,I)
                 YI = CREP(2,I)
                 ZI = CREP(3,I)
                 BXJ= CREP(1,J)
                 BYJ= CREP(2,J)
                 BZJ= CREP(3,J)
               ELSE
                 XI = CREP(1,I)
                 YI = CREP(2,I)
                 ZI = CREP(3,I)
                 BXJ = EFCENT(1,JFRG)
                 BYJ = EFCENT(2,JFRG)
                 BZJ = EFCENT(3,JFRG)
               END IF
         ELSE
               IF(JPR.LE.NRPTS(JFRG)) THEN
                 XI = EFCENT(1,IFRG)
                 YI = EFCENT(2,IFRG)
                 ZI = EFCENT(3,IFRG)
                 BXJ = CREP(1,J)
                 BYJ = CREP(2,J)
                 BZJ = CREP(3,J)
               ELSE
                 XI = EFCENT(1,IFRG)
                 YI = EFCENT(2,IFRG)
                 ZI = EFCENT(3,IFRG)
                 BXJ = EFCENT(1,JFRG)
                 BYJ = EFCENT(2,JFRG)
                 BZJ = EFCENT(3,JFRG)
               END IF
         END IF
C
             XJ = BXJ + XADD
             YJ = BYJ + YADD
             ZJ = BZJ + ZADD
             IF ( RUNTYP .EQ. MD ) THEN
                XJ = XJ + PBCX
                YJ = YJ + PBCY
                ZJ = ZJ + PBCZ
             END IF
C
             RR = (XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
             RVAL = SQRT(RR)
             DUMY = (-CF*EXP(-AE*RVAL)*AE)/RVAL
             CONX = DUMY*(XI-XJ)
             CONY = DUMY*(YI-YJ)
             CONZ = DUMY*(ZI-ZJ)
             DESFRG(1,IFRG) = DESFRG(1,IFRG) + SWF*CONX
             DESFRG(2,IFRG) = DESFRG(2,IFRG) + SWF*CONY
             DESFRG(3,IFRG) = DESFRG(3,IFRG) + SWF*CONZ
             DESFRG(4,IFRG) = DESFRG(4,IFRG) + SWF*
     *                      (CONZ*(YI-EFCENT(2,IFRG))
     *                      -CONY*(ZI-EFCENT(3,IFRG)))
             DESFRG(5,IFRG) = DESFRG(5,IFRG) + SWF*
     *                      (CONX*(ZI-EFCENT(3,IFRG))
     *                      -CONZ*(XI-EFCENT(1,IFRG)))
             DESFRG(6,IFRG) = DESFRG(6,IFRG) + SWF*
     *                      (CONY*(XI-EFCENT(1,IFRG))
     *                      -CONX*(YI-EFCENT(2,IFRG)))
             DESFRG(1,JFRG) = DESFRG(1,JFRG) - SWF*CONX
             DESFRG(2,JFRG) = DESFRG(2,JFRG) - SWF*CONY
             DESFRG(3,JFRG) = DESFRG(3,JFRG) - SWF*CONZ
             DESFRG(4,JFRG) = DESFRG(4,JFRG) - SWF*
     *                      (CONZ*(BYJ-EFCENT(2,JFRG))
     *                      -CONY*(BZJ-EFCENT(3,JFRG)))
             DESFRG(5,JFRG) = DESFRG(5,JFRG) - SWF*
     *                      (CONX*(BZJ-EFCENT(3,JFRG))
     *                      -CONZ*(BXJ-EFCENT(1,JFRG)))
             DESFRG(6,JFRG) = DESFRG(6,JFRG) - SWF*
     *                      (CONY*(BXJ-EFCENT(1,JFRG))
     *                      -CONX*(BYJ-EFCENT(2,JFRG)))
   80   CONTINUE
   90   CONTINUE
  100   CONTINUE
  200 CONTINUE
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK SPCEG
      SUBROUTINE SPCEG
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      CHARACTER*8 FRGNME
C
      PARAMETER (MXATM=2000, MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION EF3(3,MXFGPT)
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
C
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /FUNCT / E,EG(3*MXATM)
C
      PARAMETER (ZERO=0.0D+00)
      PARAMETER (ONE=1.00D+00, UNITS=ONE/0.52917724924D+00)
      PARAMETER (FACTOR=ONE/627.510D+00)
C
C EPSILON UNITS = KCAL/MOL * FACTOR = AU
C SIGMA UNITS = ANG. * FACTOR = BOHR
C
C      FACTOR2 = UNITS/FACTOR
C      EPSILON = ZERO
      EPSILON = 0.155394444D+00*FACTOR
      EPSILON4 = 4.0D+00*EPSILON
      SIGMA = 3.16555725812893D+00*UNITS
      SIGMASQ = SIGMA*SIGMA
      RUPPER = 5.5D+00*UNITS
      RLOWER = 5.0D+00*UNITS
      RUPPER2 = RUPPER*RUPPER
C      RLOWER2 = RLOWER*RLOWER
C
CC FOLLOWING ARE COEFF. OF POLYN. IN Z (=R**2-RLOWER**2)
C THAT DESCRIBES THE POTENTIAL SWITCHING FUNCTION IN THE RANNGE
C FROM Z=0 (R=RLOWER) TO Z=RUPPER**2-RLOWER**2. FOR R LESS THAN
C RLOWER, THE SWITCH FUNCTION IS ONE; FOR R GREATER THAN RUPPER
C THE SWITCH FUNCTION IS ZERO.
C T.A. ANDREA, W.C. SWOPE, H.C. ANDERSON, J.CHEM.PHYS. 79,P4576 (1983).
C
C S(Z) = 1+A*(Z**3)+B*(Z**4)+C*(Z**5)
C WITH A=-10/D**3,  B=15/D**4,   C=-6/D**5
C AND D=RUPPER**2-RLOWER**2
C
C THIS FUNCTION IS MEANT TO BE USED FOR Z IN THE RANGE FROM 0 TO D
C AND IS CONTINUOUS AND HAS TWO CONTINUOUS DERIVATIVES AT THE
C ENDPOINTS OF THIS INTERVAL.
C
      IF(RUPPER.GT.RLOWER) THEN
       DS = RUPPER**2 - RLOWER**2
       AS = -10.0D+00/DS**3
       BS = 15.0D+00/DS**4
       CS = -6.0D+00/DS**5
      ELSE
C
C TAKE THIS SITUATION TO MEAN A SHARP CUTOFF AT RUPPER
C
       AS=0.0D+00
       BS=0.0D+00
       CS=0.0D+00
      ENDIF
C
      ULJ = ZERO
      UCOUL = ZERO
      CALL VCLR(EF3,1,3*MXFGPT)
      CALL VCLR(DEF,1,3*MXFGPT)
C
      ICI=0
      KMASS=0
      DO 280 IM = 1,NFRG-1
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         ICJ=ICI + NMPTS(IM)
C
         KMASS2=0
         DO 270 JM = IM+1,NFRG
C
               UCOULIJ=ZERO
               ULJIJ=ZERO
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               RIMJM2=(COMX-PBCX)**2+(COMY-PBCY)**2+(COMZ-PBCZ)**2
C
               IF(RIMJM2.LE.RUPPER2) THEN
                 ZCHK=RIMJM2-RLOWER**2
                 IF(ZCHK.LE.0.0D+00) THEN
                  S=1.0D+00
                  SP=0.0D+00
                 ELSE
                  S=1.0D+00+ZCHK*(AS*(ZCHK**2)+ZCHK*(BS*(ZCHK**2) +
     *               CS*(ZCHK**3)))
                  SP=ZCHK*((6.0D+00*AS)*ZCHK+ZCHK*((8.0D+00*BS)*ZCHK+
     *               (10.0D+00*CS)*(ZCHK**2)))
                 ENDIF
C
          IC1=ICI
C
          DO 260 IP=1,NMPTS(IM)
            IC1=IC1+1
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
C            Q1 = ZERO
            Q1 = EFCHG(1,IC1)
            IC2=ICJ
C
C
               DO 250 JP = 1,NMPTS(JM)
                  IC2=IC2+1
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
C                  Q2 = ZERO
                  Q2 = EFCHG(1,IC2)
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  R2 = X*X + Y*Y + Z*Z
                  R2I = ONE/R2
                  R = SQRT(R2)
                  ULJT = ZERO
                  PRELJ = ZERO
                  PRECO = ZERO
                  IF(IP.EQ.1.AND.JP.EQ.1) THEN
                    SIGR = SIGMASQ*R2I
                    SIGR6 = SIGR*SIGR*SIGR
C
                        ULJT = EPSILON4*SIGR6*(SIGR6-ONE)
C
                    PRELJ = -6.0D+00*S*(ULJT+ EPSILON4*SIGR6*SIGR6)*R2I
                  ENDIF
C
                      UCOULT = Q1*Q2/R
C
C
                  PRECO = -S*UCOULT/R2
C
                  EF3(1,IC1) = EF3(1,IC1) + (PRELJ + PRECO)*X
                  EF3(2,IC1) = EF3(2,IC1) + (PRELJ + PRECO)*Y
                  EF3(3,IC1) = EF3(3,IC1) + (PRELJ + PRECO)*Z
                  EF3(1,IC2) = EF3(1,IC2) - (PRELJ + PRECO)*X
                  EF3(2,IC2) = EF3(2,IC2) - (PRELJ + PRECO)*Y
                  EF3(3,IC2) = EF3(3,IC2) - (PRELJ + PRECO)*Z
C
                  UCOULIJ = UCOULIJ + UCOULT
                  ULJIJ = ULJIJ + ULJT
C
250         CONTINUE
260         CONTINUE
C
            UCOUL = UCOUL+S*UCOULIJ
            ULJ = ULJ + S*ULJIJ
C
            FIMJMX=(ULJIJ+UCOULIJ)*SP*(COMX-PBCX)
            FIMJMY=(ULJIJ+UCOULIJ)*SP*(COMY-PBCY)
            FIMJMZ=(ULJIJ+UCOULIJ)*SP*(COMZ-PBCZ)
C
            IC1=ICI
            IC2=ICJ
            DO IP=1,NMPTS(IM)
             IC1=IC1+1
                  SCR1=FMASS(IP+KMASS)/FRGMAS(IM)
                  EF3(1,IC1)= EF3(1,IC1) + FIMJMX*SCR1
                  EF3(2,IC1)= EF3(2,IC1) + FIMJMY*SCR1
                  EF3(3,IC1)= EF3(3,IC1) + FIMJMZ*SCR1
            ENDDO
C
            DO JP=1,NMPTS(JM)
             IC2=IC2+1
                  SCR2=FMASS(JP+KMASS2)/FRGMAS(JM)
                  EF3(1,IC2)= EF3(1,IC2) - FIMJMX*SCR2
                  EF3(2,IC2)= EF3(2,IC2) - FIMJMY*SCR2
                  EF3(3,IC2)= EF3(3,IC2) - FIMJMZ*SCR2
            ENDDO
C
             ENDIF
            ICJ=ICJ+NMPTS(JM)
            KMASS2=KMASS2 + NMPTS(JM)
270      CONTINUE
         ICI=ICI+NMPTS(IM)
         KMASS=KMASS + NMPTS(IM)
C
280   CONTINUE
C
      E = ULJ + UCOUL
C      COMMON /CONVMD/ AU2KCAL, EK2KCAL, AU2ANG, AU2SEC, AU2AMU
C      WRITE(6,*) 'ELJ,ECOUL, AND ETOT = ',ULJ*AU2KCAL,UCOUL*AU2KCAL,
C     *            E*AU2KCAL
C
      DO I = 1,NMTTPT
         DO J = 1,3
            DEF(J,I) = DEF(J,I) + EF3(J,I)
         ENDDO
      ENDDO
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK SPCTGT
      SUBROUTINE SPCTGT
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      CHARACTER*8 FRGNME
C
      PARAMETER (MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      PARAMETER (ZERO = 0.0D+00)
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      DO IM = 1,NFRG
         DO J = 1,3
           DEFT(J,IM) = ZERO
           TORQ(J,IM) = ZERO
         ENDDO
      ENDDO
C
C  GET TORQUE ON EACH FRAGMENT
C      WRITE(6,*)'IM,II,III,DEF(2,II),EFD(1,III),
C     $ EFCENT(1,INF),TORQ(3,INF)'
C
      II=0
      III=0
      DO 550 INF=1,NFRG
       DO 540 IM=1,NMPTS(INF)
        II=II+1
        III=III+1
        TORQ(1,INF)=TORQ(1,INF)+DEF(3,II)*(EFC(2,III)-EFCENT(2,INF))
     $      -DEF(2,II)*(EFC(3,III)-EFCENT(3,INF))
        TORQ(2,INF)=TORQ(2,INF)+DEF(1,II)*(EFC(3,III)-EFCENT(3,INF))
     $      -DEF(3,II)*(EFC(1,III)-EFCENT(1,INF))
        TORQ(3,INF)=TORQ(3,INF)+DEF(2,II)*(EFC(1,III)-EFCENT(1,INF))
     $      -DEF(1,II)*(EFC(2,III)-EFCENT(2,INF))
        DEFT(1,INF)=DEFT(1,INF)+DEF(1,II)
        DEFT(2,INF)=DEFT(2,INF)+DEF(2,II)
        DEFT(3,INF)=DEFT(3,INF)+DEF(3,II)
 540   CONTINUE
 550  CONTINUE
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK EDISPR
      SUBROUTINE EDISPR(ELTOT,AREL,DREL,CREL,MXDPTS,NDFG2,CN)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION AREL(MXDPTS,MXDPTS,NDFG2),CREL(MXDPTS,MXDPTS,NDFG2)
      DIMENSION DREL(MXDPTS,MXDPTS,NDFG2)
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
      CHARACTER*8 DNAME,DPSNAM
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
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
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR, MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO = 0.00D+00)
C
C--   IF(MASWRK) WRITE(6,*) 'EDISPR: RUNNING FOR CN=',CN
C
      ELTOT = ZERO
C
      I=0
      IF (GOPARR) THEN
        DO IM=1,NLOW-1
          I = I + NDPTS(IM)
        ENDDO
      ENDIF
C
C     PARALLELIZATION OF ORIGINAL LOOP: DO 200 IFRG = 1,NFRG
C
      DO 200 IFRG = NLOW,NUP
C
        IF(RUNTYP .EQ. MD) THEN
          COMX1 = EFCENT(1,IFRG)
          COMY1 = EFCENT(2,IFRG)
          COMZ1 = EFCENT(3,IFRG)
        ENDIF
C
        IDX=ISET(IFRG)
        DO 100 IPR=1,NDPTS(IFRG)+1
          IF(IPR.LE.NDPTS(IFRG))I=I+1
          J=0
          DO 90 JFRG=1,NFRG
C
            IF(JFRG.LE.IFRG) THEN
               J=J+NDPTS(JFRG)
               GO TO 90
            END IF
C
            IF(RUNTYP .EQ. MD) THEN
               COMX2 = EFCENT(1,JFRG)
               COMY2 = EFCENT(2,JFRG)
               COMZ2 = EFCENT(3,JFRG)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = BOXL * ANINT(COMX * BOXLI)
               PBCY = BOXL * ANINT(COMY * BOXLI)
               PBCZ = BOXL * ANINT(COMZ * BOXLI)
             ENDIF
C
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IFRG) - EFCENT(1,JFRG)
               Y12  = EFCENT(2,IFRG) - EFCENT(2,JFRG)
               Z12  = EFCENT(3,IFRG) - EFCENT(3,JFRG)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - XADD)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - YADD)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                    SWFDX = DSWF*(EFCENT(1,IFRG)-EFCENT(1,JFRG)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IFRG)-EFCENT(1,JFRG)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-ZADD)
                 END IF
               END IF
C
               END IF
C
             JDX=ISET(JFRG)
             IF (JDX.GE.IDX) THEN
                INDEX=JDX*(JDX-1)/2+IDX
             ELSE
                INDEX=IDX*(IDX-1)/2+JDX
             ENDIF
             DO 80 JPR=1,NDPTS(JFRG)+1
                IF(JPR.LE.NDPTS(JFRG)) J=J+1
                IF(IPR.LE.NDPTS(IFRG)) THEN
                   IF(JPR.LE.NDPTS(JFRG)) THEN
                      XI = CDIS(1,I)
                      YI = CDIS(2,I)
                      ZI = CDIS(3,I)
                      XJ = CDIS(1,J)
                      YJ = CDIS(2,J)
                      ZJ = CDIS(3,J)
                   ELSE
                      XI = CDIS(1,I)
                      YI = CDIS(2,I)
                      ZI = CDIS(3,I)
                      XJ = EFCENT(1,JFRG)
                      YJ = EFCENT(2,JFRG)
                      ZJ = EFCENT(3,JFRG)
                   END IF
                ELSE
                   IF(JPR.LE.NDPTS(JFRG)) THEN
                      XI = EFCENT(1,IFRG)
                      YI = EFCENT(2,IFRG)
                      ZI = EFCENT(3,IFRG)
                      XJ = CDIS(1,J)
                      YJ = CDIS(2,J)
                      ZJ = CDIS(3,J)
                   ELSE
                      XI = EFCENT(1,IFRG)
                      YI = EFCENT(2,IFRG)
                      ZI = EFCENT(3,IFRG)
                      XJ = EFCENT(1,JFRG)
                      YJ = EFCENT(2,JFRG)
                      ZJ = EFCENT(3,JFRG)
                   END IF
                END IF
C
                XJ = XJ + XADD
                YJ = YJ + YADD
                ZJ = ZJ + ZADD
                IF ( RUNTYP .EQ. MD ) THEN
                  XJ = XJ + PBCX
                  YJ = YJ + PBCY
                  ZJ = ZJ + PBCZ
                END IF
C
                RR = (XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
                RVAL = SQRT(RR)
                R4 = RR*RR
                R6 = RR*R4
                R8 = R4*R4
                RCN= R6
                IF(CN.EQ.8.0D+00) RCN = R8
                IF (JDX.GE.IDX) THEN
                   CR = CREL(JPR,IPR,INDEX)
                   AR = AREL(JPR,IPR,INDEX)
                   DR = DREL(JPR,IPR,INDEX)
                ELSE
                   CR = CREL(IPR,JPR,INDEX)
                   AR = AREL(IPR,JPR,INDEX)
                   DR = DREL(IPR,JPR,INDEX)
                ENDIF
C
                EPAIR = CR*(1.0D+00-DR*EXP(-AR*RVAL))/RCN
                ELTOT = ELTOT + SWF*EPAIR
                DESFRG(1,JFRG) = DESFRG(1,JFRG) - EPAIR*SWFDX
                DESFRG(2,JFRG) = DESFRG(2,JFRG) - EPAIR*SWFDY
                DESFRG(3,JFRG) = DESFRG(3,JFRG) - EPAIR*SWFDZ
                DESFRG(1,IFRG) = DESFRG(1,IFRG) + EPAIR*SWFDX
                DESFRG(2,IFRG) = DESFRG(2,IFRG) + EPAIR*SWFDY
                DESFRG(3,IFRG) = DESFRG(3,IFRG) + EPAIR*SWFDZ
C
C--             IF(MASWRK  .AND.  IFRG.EQ.1  .AND.  JFRG.EQ.2) THEN
C--                WRITE(6,3) RVAL,CR,DR,AR,ELTOT
C--             END IF
C
   80        CONTINUE
   90     CONTINUE
  100   CONTINUE
  200 CONTINUE
C
      IF(GOPARR) CALL DDI_GSUMF(667,ELTOT,1)
C
      RETURN
C-- 3 FORMAT(1X,'R=',F10.5,' C,D,AREL=',3F13.4,' ELTOT=',F11.6)
      END
C
C*MODULE EFELEC  *DECK DDISPR
      SUBROUTINE DDISPR(AREL,DREL,CREL,MXDPTS,NDFG2,CN)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION AREL(MXDPTS,MXDPTS,NDFG2),
     *          DREL(MXDPTS,MXDPTS,NDFG2),
     *          CREL(MXDPTS,MXDPTS,NDFG2)
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
      CHARACTER*8 DNAME,DPSNAM
C
      PARAMETER (MXPT=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT,
     *                SWR1,SWR2,ISWF
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR, MDTYP
      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)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO = 0.0D+00)
C
      I=0
C
      IF (GOPARR) THEN
        DO IM=1,NLOW-1
          I = I + NDPTS(IM)
        ENDDO
      ENDIF
C
C      DO 200 IFRG = 1,NFRG
      DO 200 IFRG = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IFRG)
           COMY1 = EFCENT(2,IFRG)
           COMZ1 = EFCENT(3,IFRG)
         ENDIF
C
       IDX=ISET(IFRG)
       DO 100 IPR=1,NDPTS(IFRG)+1
        IF(IPR.LE.NDPTS(IFRG))I=I+1
C
      J=0
      DO 90 JFRG=1,NFRG
C
       IF(JFRG.LE.IFRG) THEN
        J=J+NDPTS(JFRG)
        GO TO 90
       END IF
C
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JFRG)
                COMY2 = EFCENT(2,JFRG)
                COMZ2 = EFCENT(3,JFRG)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWF   = 1.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IFRG) - EFCENT(1,JFRG)
               Y12  = EFCENT(2,IFRG) - EFCENT(2,JFRG)
               Z12  = EFCENT(3,IFRG) - EFCENT(3,JFRG)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - XADD)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - YADD)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 J=J+NDPTS(JFRG)
                 GO TO 90
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    VUMY5 = VUMY2*VUMY3
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
     *                              + 15.0D+00*DUMY4*VUMY4
     *                              -  6.0D+00*DUMY5*VUMY5
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
                 END IF
               END IF
C
               END IF
C
       JDX=ISET(JFRG)
       DO 80 JPR=1,NDPTS(JFRG)+1
        IF(JPR.LE.NDPTS(JFRG))J=J+1
        IF (JDX.GE.IDX) THEN
          INDEX=JDX*(JDX-1)/2+IDX
          CF = CREL(JPR,IPR,INDEX)
          DF = DREL(JPR,IPR,INDEX)
          AE = AREL(JPR,IPR,INDEX)
       ELSE
          INDEX=IDX*(IDX-1)/2+JDX
          CF = CREL(IPR,JPR,INDEX)
          DF = DREL(IPR,JPR,INDEX)
          AE = AREL(IPR,JPR,INDEX)
       ENDIF
       IF(IPR.LE.NDPTS(IFRG)) THEN
              IF(JPR.LE.NDPTS(JFRG)) THEN
                 XI = CDIS(1,I)
                 YI = CDIS(2,I)
                 ZI = CDIS(3,I)
                 BXJ= CDIS(1,J)
                 BYJ= CDIS(2,J)
                 BZJ= CDIS(3,J)
              ELSE
                 XI = CDIS(1,I)
                 YI = CDIS(2,I)
                 ZI = CDIS(3,I)
                 BXJ = EFCENT(1,JFRG)
                 BYJ = EFCENT(2,JFRG)
                 BZJ = EFCENT(3,JFRG)
              ENDIF
       ELSE
              IF(JPR.LE.NDPTS(JFRG)) THEN
                 XI = EFCENT(1,IFRG)
                 YI = EFCENT(2,IFRG)
                 ZI = EFCENT(3,IFRG)
                 BXJ = CDIS(1,J)
                 BYJ = CDIS(2,J)
                 BZJ = CDIS(3,J)
              ELSE
                 XI = EFCENT(1,IFRG)
                 YI = EFCENT(2,IFRG)
                 ZI = EFCENT(3,IFRG)
                 BXJ = EFCENT(1,JFRG)
                 BYJ = EFCENT(2,JFRG)
                 BZJ = EFCENT(3,JFRG)
              END IF
       END IF
C
             XJ = BXJ + XADD
             YJ = BYJ + YADD
             ZJ = BZJ + ZADD
             IF ( RUNTYP .EQ. MD ) THEN
                XJ = XJ + PBCX
                YJ = YJ + PBCY
                ZJ = ZJ + PBCZ
             END IF
C
             RR = (XI-XJ)*(XI-XJ)+(YI-YJ)*(YI-YJ)+(ZI-ZJ)*(ZI-ZJ)
             RVAL = SQRT(RR)
             R4 = RR*RR
             R6 = RR*R4
             R8 = R4*R4
             RCN= R6
             IF(CN.EQ.8.0D+00) RCN = R8
             DUMY = -(CF/RCN)*
     *              (CN/RVAL-DF*EXP(-AE*RVAL)*(CN/RVAL+AE))/RVAL
             CONX = DUMY*(XI-XJ)
             CONY = DUMY*(YI-YJ)
             CONZ = DUMY*(ZI-ZJ)
             DESFRG(1,IFRG) = DESFRG(1,IFRG) + SWF*CONX
             DESFRG(2,IFRG) = DESFRG(2,IFRG) + SWF*CONY
             DESFRG(3,IFRG) = DESFRG(3,IFRG) + SWF*CONZ
             DESFRG(4,IFRG) = DESFRG(4,IFRG) + SWF*
     *                      (CONZ*(YI-EFCENT(2,IFRG))
     *                      -CONY*(ZI-EFCENT(3,IFRG)))
             DESFRG(5,IFRG) = DESFRG(5,IFRG) + SWF*
     *                      (CONX*(ZI-EFCENT(3,IFRG))
     *                      -CONZ*(XI-EFCENT(1,IFRG)))
             DESFRG(6,IFRG) = DESFRG(6,IFRG) + SWF*
     *                      (CONY*(XI-EFCENT(1,IFRG))
     *                      -CONX*(YI-EFCENT(2,IFRG)))
             DESFRG(1,JFRG) = DESFRG(1,JFRG) - SWF*CONX
             DESFRG(2,JFRG) = DESFRG(2,JFRG) - SWF*CONY
             DESFRG(3,JFRG) = DESFRG(3,JFRG) - SWF*CONZ
             DESFRG(4,JFRG) = DESFRG(4,JFRG) - SWF*
     *                      (CONZ*(BYJ-EFCENT(2,JFRG))
     *                      -CONY*(BZJ-EFCENT(3,JFRG)))
             DESFRG(5,JFRG) = DESFRG(5,JFRG) - SWF*
     *                      (CONX*(BZJ-EFCENT(3,JFRG))
     *                      -CONZ*(BXJ-EFCENT(1,JFRG)))
             DESFRG(6,JFRG) = DESFRG(6,JFRG) - SWF*
     *                      (CONY*(BXJ-EFCENT(1,JFRG))
     *                      -CONX*(BYJ-EFCENT(2,JFRG)))
   80   CONTINUE
   90   CONTINUE
  100   CONTINUE
  200 CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK INDIND
      SUBROUTINE INDIND
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00)
C
C     COMPUTE THE INTERACTION ENERGY BETWEEN INDUCED DIPOLES
C     AND INDUCED DIPOLES. THE ENERGY IS NOT COLLECTED AS
C     POLARIZATION ENERGY. WHEN A SWITCHING FUNCTION IS USED,
C     THE ENERGY IS MULTIPLIED BY THE DERIVATIVES OF THE SF
C     TO PRODUCED PART OF THE GRADIENTS.
C
C     HUI LI, IOWA STATE UNIVERSITY, DEC 4, 2005
C
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
C
C           MUST BE 0.5*DIND
C
            DX1 = 0.50D+00*DIND(1,IC1)
            DY1 = 0.50D+00*DIND(2,IC1)
            DZ1 = 0.50D+00*DIND(3,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
C
C              WE NEED TO DO BOTH IM*JM AND JM*IM
C              BECAUSE DIND AND DINDD ARE DIFFERENT
C              FOR ASYMMETRIC POLARIZABILITY TENSORS
C
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               DFX = ZERO
               DFY = ZERO
               DFZ = ZERO
               DO 370 JP = 1,NPPTS(JM)
                  IC2=IC2+1
                  X2 = EFP(1,IC2)
                  Y2 = EFP(2,IC2)
                  Z2 = EFP(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
C
C                 MUST BE DINDD
C
                  DX2 = DINDD(1,IC2)
                  DY2 = DINDD(2,IC2)
                  DZ2 = DINDD(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
C
      DOT = DX2*X + DY2*Y + DZ2*Z
      DUM = DOT*THREE/R5
      DFX = DFX - DX2/R3 + X*DUM
      DFY = DFY - DY2/R3 + Y*DUM
      DFZ = DFZ - DZ2/R3 + Z*DUM
C
370            CONTINUE
C
C.... IND. DIPOLE(JM) - IND. DIPOLE(IM)
C
               TERM = -(DX1*DFX+DY1*DFY+DZ1*DFZ)
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK INDCHG
      SUBROUTINE INDCHG
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00)
C
C     COMPUTE THE INTERACTION ENERGY BETWEEN INDUCED DIPOLES
C     AND STATIC MONOPOLES. THE ENERGY IS NOT COLLECTED AS
C     POLARIZATION ENERGY. WHEN A SWITCHING FUNCTION IS USED,
C     THE ENERGY IS MULTIPLIED BY THE DERIVATIVES OF THE SF
C     TO PRODUCED PART OF THE GRADIENTS.
C
C     HUI LI, IOWA STATE UNIVERSITY, DEC 4, 2005
C
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
            DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
            DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
C
               CFX = ZERO
               CFY = ZERO
               CFZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DOMONO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     EX = ZERO
                     CF = ZERO
                  ELSE
                     EX = EFATRM(IC2)
                     CF = EFBTRM(IC2)
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IP' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
                  DUM = Q2/R3
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.2) THEN
                     CFX = CFX + X*DUM
                     CFY = CFY + Y*DUM
                     CFZ = CFZ + Z*DUM
                  ELSE
                     EX2=EXP(-EX*R2)
                     SCREEN=1.0D+00-CF*EX2
                     CFX = CFX + X*DUM*SCREEN - 2.0D+00*Q2*CF*X*EX*EX2/R
                     CFY = CFY + Y*DUM*SCREEN - 2.0D+00*Q2*CF*Y*EX*EX2/R
                     CFZ = CFZ + Z*DUM*SCREEN - 2.0D+00*Q2*CF*Z*EX*EX2/R
                  END IF
C
C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
370            CONTINUE
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, ETC. AT POINT 'IP' IN
C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IP'
C     WITH THESE FIELDS TO THE 'IM' WITH 'JM' INTERACTION.
C
C
C.... CHARGE(JM) - INDUCED DIPOLE(IM)
C
               TERM = -(DX1*CFX+DY1*CFY+DZ1*CFZ)
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK INDDPL
      SUBROUTINE INDDPL
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
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 /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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (PT5=0.5D+00, ZERO=0.0D+00, THREE=3.0D+00)
C
C     COMPUTE THE INTERACTION ENERGY BETWEEN INDUCED DIPOLES
C     AND STATIC DIPOLES. THE ENERGY IS NOT COLLECTED AS
C     POLARIZATION ENERGY. WHEN A SWITCHING FUNCTION IS USED,
C     THE ENERGY IS MULTIPLIED BY THE DERIVATIVES OF THE SF
C     TO PRODUCED PART OF THE GRADIENTS.
C
C     HUI LI, IOWA STATE UNIVERSITY, DEC 4, 2005
C
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
            DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
            DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            IC2=0
            DO 380 JM = 1,NFRG
C
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               ENDIF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               DFX = ZERO
               DFY = ZERO
               DFZ = ZERO
               DO 370 JP = 1,NMPTS(JM)
                  IC2=IC2+1
            IF(.NOT.DODIPO(IC2)) GO TO 370
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
C
      DOT = DX2*X + DY2*Y + DZ2*Z
      DUM = DOT*THREE/R5
      DFX = DFX - DX2/R3 + X*DUM
      DFY = DFY - DY2/R3 + Y*DUM
      DFZ = DFZ - DZ2/R3 + Z*DUM
C
370            CONTINUE
C
C.... DIPOLE(JM) - INDUCED DIPOLE(IM)
C
               TERM = -(DX1*DFX+DY1*DFY+DZ1*DFZ)
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK INDQUA
      SUBROUTINE INDQUA
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      DOUBLE PRECISION  MD
      DOUBLE PRECISION  MDTYP
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION QUA(6,MXFGPT)
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 /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 /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
     *                ,SWR1,SWR2,ISWF
      COMMON /EFPGES/ DESFRG(6,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
C
      COMMON /MDSIM/  DT, BOXL, BOXLI, BATHT, EKINT, EKINR,
     *                  MDTYP
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      DATA MD         /8HMD      /
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00, PT5=0.5D+00,
     *           ONEPT5=1.5D+00, TWO=2.0D+00, FIFTEN=1.5D+01)
C
C     COMPUTE THE INTERACTION ENERGY BETWEEN INDUCED DIPOLES
C     AND STATIC QUADRUPOLES. THE ENERGY IS NOT COLLECTED AS
C     POLARIZATION ENERGY. WHEN A SWITCHING FUNCTION IS USED,
C     THE ENERGY IS MULTIPLIED BY THE DERIVATIVES OF THE SF
C     TO PRODUCED PART OF THE GRADIENTS.
C
C     HUI LI, IOWA STATE UNIVERSITY, DEC 4, 2005
C
C
      DO 210 I = 1,NMTTPT
        IF(.NOT.DOQUAD(I)) GO TO 210
        XX = EFQAD(1,I)
        YY = EFQAD(2,I)
        ZZ = EFQAD(3,I)
        XY = EFQAD(4,I)
        XZ = EFQAD(5,I)
        YZ = EFQAD(6,I)
        DUM = XX + YY + ZZ
        QUA(1,I) = PT5 * (THREE * XX - DUM)
        QUA(2,I) = PT5 * (THREE * YY - DUM)
        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
        QUA(4,I) = ONEPT5 * XY
        QUA(5,I) = ONEPT5 * XZ
        QUA(6,I) = ONEPT5 * YZ
210   CONTINUE
C
      IC1=0
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
C
         IF(RUNTYP .EQ. MD) THEN
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
         ENDIF
C
         DO 390 IP = 1,NMPTS(IM)
            IC1=IC1+1
            IF(.NOT.DOQUAD(IC1)) GO TO 390
            X1 = EFC(1,IC1)
            Y1 = EFC(2,IC1)
            Z1 = EFC(3,IC1)
            XX1 = QUA(1,IC1)
            YY1 = QUA(2,IC1)
            ZZ1 = QUA(3,IC1)
            XY1 = QUA(4,IC1)
            XZ1 = QUA(5,IC1)
            YZ1 = QUA(6,IC1)
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               END IF
C
               IF(RUNTYP .EQ. MD) THEN
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
                PBCX = BOXL * ANINT(COMX * BOXLI)
                PBCY = BOXL * ANINT(COMY * BOXLI)
                PBCZ = BOXL * ANINT(COMZ * BOXLI)
               ENDIF
C
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
C
               XADD=ZERO
               YADD=ZERO
               ZADD=ZERO
               IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
               X12  = EFCENT(1,IM) - EFCENT(1,JM)
               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
               XADD = XBOX * ANINT(X12/XBOX)
               YADD = YBOX * ANINT(Y12/YBOX)
               ZADD = ZBOX * ANINT(Z12/ZBOX)
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               END IF
               R12  = X12*X12+Y12*Y12+Z12*Z12
               IF(R12.GT.RCUT)THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               END IF
C
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NPPTS(JM)
                 GO TO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF(ISWF.EQ.1) THEN
                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
                    DUMY2 = DUMY1*DUMY1
                    DUMY3 = DUMY2*DUMY1
                    DUMY4 = DUMY2*DUMY2
                    DUMY5 = DUMY2*DUMY3
                    VUMY1 = R12 - SWR1*SWR1
                    VUMY2 = VUMY1*VUMY1
                    VUMY3 = VUMY2*VUMY1
                    VUMY4 = VUMY2*VUMY2
                    DSWF  = -30.0D+00*DUMY3*VUMY2
     *                      +60.0D+00*DUMY4*VUMY3
     *                      -30.0D+00*DUMY5*VUMY4
                    DSWF  = 2.0D+00*DSWF
                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 ELSE IF(ISWF.EQ.2) THEN
                    R12   = SQRT(R12)
                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
                    DUMY  = (R12 - SWR1) * PIL
                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
                 END IF
               END IF
C
               END IF
C
               DFXX = ZERO
               DFYY = ZERO
               DFZZ = ZERO
               DFXY = ZERO
               DFXZ = ZERO
               DFYZ = ZERO
               DO 370 JP = 1,NPPTS(JM)
                  IC2=IC2+1
                  X2 = EFP(1,IC2)
                  Y2 = EFP(2,IC2)
                  Z2 = EFP(3,IC2)
                  X2 = X2 + XADD
                  Y2 = Y2 + YADD
                  Z2 = Z2 + ZADD
                  DX2 = PT5*(DIND(1,IC2)+DINDD(1,IC2))
                  DY2 = PT5*(DIND(2,IC2)+DINDD(2,IC2))
                  DZ2 = PT5*(DIND(3,IC2)+DINDD(3,IC2))
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
C
                   IF ( RUNTYP .EQ. MD ) THEN
                    X = X - PBCX
                    Y = Y - PBCY
                    Z = Z - PBCZ
                  ENDIF
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  XY = X*Y
                  XZ = X*Z
                  YZ = Y*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
                  R5 = R2*R3
                  R7 = R2*R5
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
      DOT = DX2*X + DY2*Y + DZ2*Z
C
      DUM = THREE/R5
      DFXX = DFXX + (TWO*DX2*X)*DUM - FIFTEN*XX*DOT/R7
      DFYY = DFYY + (TWO*DY2*Y)*DUM - FIFTEN*YY*DOT/R7
      DFZZ = DFZZ + (TWO*DZ2*Z)*DUM - FIFTEN*ZZ*DOT/R7
      DFXY = DFXY + (DX2*Y+DY2*X)*DUM - FIFTEN*XY*DOT/R7
      DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*DOT/R7
      DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*DOT/R7
C
 370           CONTINUE
C
C.... INDUCED DIPOLE(JM) - QUADRUPOLE(IM)
C
               TERM = XX1*DFXX + YY1*DFYY + ZZ1*DFZZ
     *              + TWO*(XY1*DFXY + XZ1*DFXZ + YZ1*DFYZ)
               TERM = -TERM/THREE
              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
