C 20 AUG 07 - LVS - PBC-EFP CLEANED
C 24 MAR 07 - LVS - FFELEC REPLACES CHGCHG,CHGDIP,CHGQUA,CHGOCT,DPLDPL,
C                   DPQUAD, AND QUDQUD; DIP-QUAD ELECTROSATIC DAMPING;
C                   SCREENING OF POLARIZATION ADDED.
C 10 JUL 06 - MWS - USE IPX INSTEAD OF IP LOOP INDICES
C  8 MAY 06 - LVS - HIGH-ORDER ELECTROSTATIC FRAG-FRAG. SCREENING
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---C*MODULE EFELEC  *DECK CHGCHG
C---      SUBROUTINE CHGCHG(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, ZERO=0.0D+00)
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C---C
C---      CALL VCLR(DESFRG,1,6*MXFRG)
C---      PI=4*ATAN(1.0D+00)
C---      ELTOT=ZERO
C---      IC1=0
C---C
C---      CALL EFCM
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 280 IM = 1,NFRG
C---      DO 280 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 270 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            Q1 = EFCHG(1,IC1)
C---            Q1N = EFCHG(2,IC1)
C---            IC2=0
C---            DO 260 JM = 1,NFRG
C---C
C---               IF (IM.GE.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 260
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 260
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 260
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 260
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               EPAIR = 0.0D+00
C---               DO 250 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  Q2 = EFCHG(1,IC2)
C---                  Q2N = EFCHG(2,IC2)
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                  IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  R2 = X*X + Y*Y + Z*Z
C---                  R = SQRT(R2)
C---                  IF(ICHGP.NE.1) THEN
C---                     AI=ZERO
C---                     AJ=ZERO
C---                     CF1 = ZERO
C---                     CF2 = ZERO
C---                     ALPHAA = EFATRM2(IC1)
C---                     BETAA = EFBTRM2(IC1)
C---                     ALPHAB = EFATRM2(IC2)
C---                  ELSE
C---                     AI=EFATRM(IC1)
C---                     AJ=EFATRM(IC2)
C---                     CF1 = EFBTRM(IC1)
C---                     CF2 = EFBTRM(IC2)
C---                     ALPHAA = ZERO
C---                     BETAA = ZERO
C---                     ALPHAB = ZERO
C---                  END IF
C---                  EX1 = EXP(-AI*R2)
C---                  EX2 = EXP(-AJ*R2)
C---            IF(Q1N.NE.ZERO.OR.Q2N.NE.ZERO) THEN
C---            SCREEN1 = 1.0D+00 - CF1*EX1
C---            SCREEN2 = 1.0D+00 - CF2*EX2
C---              EPAIR=EPAIR+(Q1N*Q2*SCREEN2
C---     *                    +Q2N*Q1*SCREEN1+Q1N*Q2N)/R
C---            END IF
C---            EPAIR=EPAIR+Q1*Q2*(1/R
C---     *                 -CF1*EX1/R
C---     *                 -CF2*EX2/R)
C---           IF(CF1*CF2.NE.ZERO)EPAIR=EPAIR+Q1*Q2*
C---     *                  CF1*CF2*(AI*AJ*SQRT(PI/(AI+AJ)**3)*
C---     *                  EXP(-R2*AI*AJ/(AI+AJ))*(1-ERRF(R*AI/SQRT(AI+
C---     *                  AJ))-ERRF(R*AJ/SQRT(AI+AJ)))+(AI*EX1+
C---     *                  AJ*EX2)/R/(AI+AJ))
C---C
C---      IF(ICHGP.EQ.1.OR.R.GT.ELEVEN.OR.BETAA.EQ.ZERO) GOTO 250
C---C
C---C     -------  CALCULATE CHARGE PENETRATION --------
C---C     THIS FORMULA INVOLVES FRAGMENT/FRAGMENT EXPONENTIAL SCREENING
C---C
C---               AP=ALPHAA*R
C---               BP=ALPHAB*R
C---               AA2=ALPHAA*ALPHAA
C---               AB2=ALPHAB*ALPHAB
C---               DIFF=ABS(ALPHAA-ALPHAB)
C---               TPCHPE=ZERO
C---C
C---               IF(ICHGP.EQ.2.OR.ICHGP.EQ.3) THEN
C---C
C---C          ALPHAA = ALPHAB
C---               IF(DIFF.LT.SMALL) THEN
C---                  TPCHPE=-(EXP(-AP)/R)*(Q1*Q2*(ONE+(AP/TWO))
C---     *                   +Q1*Q2N+Q2*Q1N)
C---               ELSE
C---                  TPCHPE=-(ONE/(TWO*R))*(Q1*(Q2+TWO*Q2N)*EXP(-AP)
C---     *              +Q2*(Q1+TWO*Q1N)*EXP(-BP)
C---     *           +Q1*Q2*((AA2+AB2)/(AA2-AB2))*(EXP(-BP)-EXP(-AP)))
C---               ENDIF
C---              END IF
C---C
C---               IF(ICHGP.EQ.4.OR.ICHGP.EQ.5) THEN
C---C
C---               IF(DIFF.LT.SMALL) THEN
C---C                 TPCHPE1=-EXP(-AP)/R*(Q1*Q2N+Q2*Q1N)*(ONE+(AP/TWO))
C---               TPCHPE=-EXP(-AP)/R*(Q1*Q2*(ONE+11.0D+00/16.0D+00*AP+
C---     *                3.0D+00/16.0D+00*AP*AP+ONE/48.0D+00*AP*AP*AP)
C---     *                +(Q1*Q2N+Q2*Q1N)*(ONE+(AP/TWO)))
C---               ELSE
C---                  TPCHPE1=-ONE/R*(Q1*Q2N*EXP(-AP)*(ONE+AP/TWO)+
C---     *                   Q2*Q1N*EXP(-BP)*(ONE+BP/TWO))
C---C
C---                  TPCHAA=-ONE/R*Q1*Q2*
C---     *                   EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
C---     *                   (ONE+AP/TWO-TWO*AA2/(-AA2+AB2))
C---C
C---                  TPCHBB=-ONE/R*Q1*Q2*
C---     *                   EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
C---     *                   (ONE+BP/TWO-TWO*AB2/(AA2-AB2))
C---C
C---                  TPCHPE=TPCHPE1+TPCHAA+TPCHBB
C---               END IF
C---             END IF
C---C
C---C
C---C INCORPORATE INTO ELECTROSTATIC ENERGY
C---C
C---                EPAIR=EPAIR+TPCHPE
C---C
C---250         CONTINUE
C---              ELTOT = ELTOT + SWF*EPAIR
C---              DESFRG(1,JM) = DESFRG(1,JM) - EPAIR*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - EPAIR*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - EPAIR*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + EPAIR*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + EPAIR*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + EPAIR*SWFDZ
C---260         CONTINUE
C---270      CONTINUE
C---280   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK CHGDIP
C---      SUBROUTINE CHGDIP(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,HALF=0.5D+00,TWO=2.0D+00)
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C---C
C---      ELTOT=ZERO
C---C
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DODIPO(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            DX1 = EFDIP(1,IC1)
C---            DY1 = EFDIP(2,IC1)
C---            DZ1 = EFDIP(3,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---               IF (IM.EQ.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---C
C---               CFX = ZERO
C---               CFY = ZERO
C---               CFZ = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DOMONO(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C---                  Q = EFCHG(1,IC2)
C---                  QN = EFCHG(2,IC2)
C---                  IF(ICHGP.NE.1) THEN
C---                     EX = ZERO
C---                     CF = ZERO
C---                     ALPHAA = EFATRM2(IC1)
C---                     ALPHAB = EFATRM2(IC2)
C---                  ELSE
C---                     EX = EFATRM(IC2)
C---                     CF = EFBTRM(IC2)
C---                  END IF
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---C
C---C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C---C AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C---C
C---                  DUM = Q2/R3
C---                  SCREEN = ONE*Q2
C---C
C---C    -------  FRAGMENT-FRAGMENT EXPONENTIAL SCREENING ------
C---C    -------  INCLUDES CHARGE-DIPOLE AND NUCLEUS-DIPOLE TERMS ------
C---C
C---                 IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
C---                     IF(R.LE.ELEVEN) THEN
C---C     ----  ALPHAA - DIPOLE, ALPHAB-CHARGE
C---                       AP=ALPHAA*R
C---                       BP=ALPHAB*R
C---                       AA2=ALPHAA*ALPHAA
C---                       AB2=ALPHAB*ALPHAB
C---                       DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C     ----  OLD CODE WITH OLD POTENTIAL
C---                       IF(ICHGP.EQ.3) THEN
C---C     ---- ALPHAA = ALPHAB
C---                         IF(DIFF.LT.SMALL) THEN
C---                            SCREEN=ONE*Q2-
C---     *                      EXP(-AP)*(ONE+AP+HALF*AP*AP)*Q-
C---     *                      EXP(-AP)*(ONE+AP)*QN
C---                         ELSE
C---                            SCREEN=ONE*Q2-
C---     *                      EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2)*Q)-
C---     *                      EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2)*Q)-
C---     *                      EXP(-AP)*(ONE+AP)*QN
C---                         END IF
C---C                  WRITE(IW,*)'CH_DIP: R= ',R,' SCREEN= ',SCREEN/Q2
C---                       ELSE
C---C    ----  FORMULA FOR NEW POTENTIAL
C---                         IF(DIFF.LT.SMALL) THEN
C---                            SCREEN=ONE*Q2-
C---     *                      EXP(-AP)*(ONE+AP+AP*AP/TWO+
C---     *                      7.0D+00/48.0D+00*AP*AP*AP+
C---     *                      ONE/48.0D+00*AP*AP*AP*AP)*Q-
C---     *                      EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
C---                         ELSE
C---                            SCREEN=ONE*Q2-
C---     *                 EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
C---     *              ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)-
C---     *              EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
C---     *              ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)-
C---     *              EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
C---                         END IF
C---                       END IF
C---                     END IF
C---                  END IF
C---C
C---                 IF(ICHGP.NE.1) THEN
C---                     CFX = CFX + X/R3*SCREEN
C---                     CFY = CFY + Y/R3*SCREEN
C---                     CFZ = CFZ + Z/R3*SCREEN
C---                 ELSE
C---                     EX2=EXP(-EX*R2)
C---                     SCREEN=1.0D+00-CF*EX2
C---                     CFX = CFX
C---     *                   + X*DUM*SCREEN - 2.0D+00*Q2*CF*X*EX*EX2/R
C---                     CFY = CFY
C---     *                   + Y*DUM*SCREEN - 2.0D+00*Q2*CF*Y*EX*EX2/R
C---                     CFZ = CFZ
C---     *                   + Z*DUM*SCREEN - 2.0D+00*Q2*CF*Z*EX*EX2/R
C---                 END IF
C---C
C---C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
C---370            CONTINUE
C---C
C---C.... POTENTIAL, FIELD, FIELD GRADIENT, ETC. AT POINT 'IPX' IN
C---C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C---C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IPX'
C---C     WITH THESE FIELDS TO THE 'IM' WITH 'JM' INTERACTION.
C---C
C---C
C---C.... CHARGE(JM) - DIPOLE(IM)
C---C
C---               TERM = -(DX1*CFX+DY1*CFY+DZ1*CFZ)
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---380         CONTINUE
C---390      CONTINUE
C---400   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK CHGQUA
C---      SUBROUTINE CHGQUA(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      DIMENSION QUA(6,MXFGPT)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00,
C---     *           THREE=3.0D+00, PT5=0.5D+00, ONEPT5=1.5D+00)
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C---C
C---C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C---C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C---C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C---C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C---C.... EQUATION 15.                                          ....
C---C
C---      ELTOT=ZERO
C---      DO 210 I = 1,NMTTPT
C---        IF(.NOT.DOQUAD(I)) GO TO 210
C---        XX = EFQAD(1,I)
C---        YY = EFQAD(2,I)
C---        ZZ = EFQAD(3,I)
C---        XY = EFQAD(4,I)
C---        XZ = EFQAD(5,I)
C---        YZ = EFQAD(6,I)
C---        DUM = XX + YY + ZZ
C---        QUA(1,I) = PT5 * (THREE * XX - DUM)
C---        QUA(2,I) = PT5 * (THREE * YY - DUM)
C---        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
C---        QUA(4,I) = ONEPT5 * XY
C---        QUA(5,I) = ONEPT5 * XZ
C---        QUA(6,I) = ONEPT5 * YZ
C---210   CONTINUE
C---C
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DOQUAD(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            XX1 = QUA(1,IC1)
C---            YY1 = QUA(2,IC1)
C---            ZZ1 = QUA(3,IC1)
C---            XY1 = QUA(4,IC1)
C---            XZ1 = QUA(5,IC1)
C---            YZ1 = QUA(6,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---               IF (IM.EQ.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               CFXX = ZERO
C---               CFYY = ZERO
C---               CFZZ = ZERO
C---               CFXY = ZERO
C---               CFXZ = ZERO
C---               CFYZ = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DOMONO(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C---                  Q  = EFCHG(1,IC2)
C---                  QN = EFCHG(2,IC2)
C---                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
C---                     ALPHAA = EFATRM2(IC1)
C---                     ALPHAB = EFATRM2(IC2)
C---                  END IF
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  XY = X*Y
C---                  XZ = X*Z
C---                  YZ = Y*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---                  R5 = R2*R3
C---C
C---C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C---C AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C---C
C---      DUM = Q2/R5
C---C
C---C         NO SCREENING
C---      IF(ICHGP.NE.3 .AND. ICHGP.NE.5) THEN
C---         CFXX = CFXX - (THREE*XX-R2)*DUM
C---         CFYY = CFYY - (THREE*YY-R2)*DUM
C---         CFZZ = CFZZ - (THREE*ZZ-R2)*DUM
C---         CFXY = CFXY - THREE*XY*DUM
C---         CFXZ = CFXZ - THREE*XZ*DUM
C---         CFYZ = CFYZ - THREE*YZ*DUM
C---      ELSE
C---C          FRAGMENT-FRAGMENT SCREENING
C---         SCREEN1=ONE*Q2
C---         SCREEN2=ZERO
C---         DUM1=ONE/R5
C---         IF(R.LE.ELEVEN) THEN
C---C
C---            AP=ALPHAA*R
C---            BP=ALPHAB*R
C---            AA2=ALPHAA*ALPHAA
C---            AB2=ALPHAB*ALPHAB
C---            DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C---C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C---C
C---            IF(ICHGP.EQ.3) THEN
C---C                   CODE DUE OLD POTENTIAL
C---C               ALPHAA = ALPHAB
C---               IF(DIFF.LT.SMALL) THEN
C---                  SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP+PT5*AP*AP)*Q
C---     *                       -EXP(-AP)*(ONE+AP)*QN
C---                  SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)*Q
C---     *                 -EXP(-AP)*(AP*AP)*QN
C---               ELSE
C---                  SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))*Q
C---     *                       -EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))*Q
C---     *                       -EXP(-AP)*(ONE+AP)*QN
C---                  SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))*Q
C---     *                 -EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))*Q
C---     *                 -EXP(-AP)*(AP*AP)*QN
C---               END IF
C---C
C---             ELSE
C---C                 CODE DUE NEW POTENTIAL
C---C
C---               IF(DIFF.LT.SMALL) THEN
C---                  SCREEN1=ONE*Q2-
C---     *                    EXP(-AP)*(ONE+AP+AP*AP/TWO+
C---     *                      7.0D+00/48.0D+00*AP*AP*AP+
C---     *                      ONE/48.0D+00*AP*AP*AP*AP)*Q-
C---     *                    EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
C---                  SCREEN2=-EXP(-AP)*ONE/48.0D+00*
C---     *                    (THREE*AP*AP*AP+THREE*AP*AP*AP*AP+
C---     *                     AP*AP*AP*AP*AP)*Q
C---     *                    -EXP(-AP)*(AP*AP*AP/TWO)*QN
C---               ELSE
C---             SCREEN1=ONE*Q2-
C---     *             EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
C---     *              ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)-
C---     *             EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
C---     *              ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)-
C---     *             EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
C---             SCREEN2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
C---     *              (AP*AP*(-TWO*AA2/(-AA2+AB2))+AP*AP*AP/TWO)-
C---     *             EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
C---     *              (BP*BP*(-TWO*AB2/(AA2-AB2))+BP*BP*BP/TWO)-
C---     *             EXP(-AP)*(AP*AP*AP/TWO)*QN
C---               END IF
C---             END IF
C---C
C---         END IF
C---C         WRITE(IW,*)'CH_QUAD: R=',R,'SCR1=',SCREEN1,'SCR2=',SCREEN2
C---C
C---         CFXX = CFXX - DUM1*((THREE*XX-R2)*SCREEN1+XX*SCREEN2)
C---         CFYY = CFYY - DUM1*((THREE*YY-R2)*SCREEN1+YY*SCREEN2)
C---         CFZZ = CFZZ - DUM1*((THREE*ZZ-R2)*SCREEN1+ZZ*SCREEN2)
C---         CFXY = CFXY - DUM1*(THREE*XY*SCREEN1+XY*SCREEN2)
C---         CFXZ = CFXZ - DUM1*(THREE*XZ*SCREEN1+XZ*SCREEN2)
C---         CFYZ = CFYZ - DUM1*(THREE*YZ*SCREEN1+YZ*SCREEN2)
C---      END IF
C---C
C---C
C---370            CONTINUE
C---C
C---C.... CHARGE(JM) - QUADRUPOLE(IM)
C---C
C---               TERM = XX1*CFXX + YY1*CFYY + ZZ1*CFZZ
C---     1               +TWO*(XY1*CFXY + XZ1*CFXZ + YZ1*CFYZ)
C---               TERM = -TERM/3
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---380         CONTINUE
C---390      CONTINUE
C---400   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK CHGOCT
C---      SUBROUTINE CHGOCT(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      DIMENSION OCT(10,MXFGPT)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      DATA PT5/0.5D+00/
C---C      DATA ONE,TWO/1.0D+00,2.0D+00/
C---      DATA THREE,FIVE,SIX/3.0D+00,5.0D+00,6.0D+00/
C---      DATA ZERO/0.0D+00/
C---C      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C---C
C---C.... REPLACE THIRD MOMENTS WITH OCTUPOLE MOMENTS           ....
C---C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C---C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C---C.... EQUATION 15.                                          ....
C---C
C---      ELTOT=ZERO
C---      DO 242 I = 1,NMTTPT
C---        IF(.NOT.DOOCTU(I)) GO TO 242
C---         XXX = EFOCT(1,I) * PT5
C---         YYY = EFOCT(2,I) * PT5
C---         ZZZ = EFOCT(3,I) * PT5
C---         XXY = EFOCT(4,I) * PT5
C---         XXZ = EFOCT(5,I) * PT5
C---         XYY = EFOCT(6,I) * PT5
C---         YYZ = EFOCT(7,I) * PT5
C---         XZZ = EFOCT(8,I) * PT5
C---         YZZ = EFOCT(9,I) * PT5
C---         XYZ = EFOCT(10,I) * PT5
C---         DUMX = XXX + XYY + XZZ
C---         DUMY = XXY + YYY + YZZ
C---         DUMZ = XXZ + YYZ + ZZZ
C---         OCT(1,I) = FIVE * XXX - THREE * DUMX
C---         OCT(2,I) = FIVE * YYY - THREE * DUMY
C---         OCT(3,I) = FIVE * ZZZ - THREE * DUMZ
C---         OCT(4,I) = FIVE * XXY - DUMY
C---         OCT(5,I) = FIVE * XXZ - DUMZ
C---         OCT(6,I) = FIVE * XYY - DUMX
C---         OCT(7,I) = FIVE * YYZ - DUMZ
C---         OCT(8,I) = FIVE * XZZ - DUMX
C---         OCT(9,I) = FIVE * YZZ - DUMY
C---         OCT(10,I) = FIVE * XYZ
C---242   CONTINUE
C---C
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DOOCTU(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            XXX1 = OCT(1,IC1)
C---            YYY1 = OCT(2,IC1)
C---            ZZZ1 = OCT(3,IC1)
C---            XXY1 = OCT(4,IC1)
C---            XXZ1 = OCT(5,IC1)
C---            XYY1 = OCT(6,IC1)
C---            YYZ1 = OCT(7,IC1)
C---            XZZ1 = OCT(8,IC1)
C---            YZZ1 = OCT(9,IC1)
C---            XYZ1 = OCT(10,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---               IF (IM.EQ.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               CFXXX = ZERO
C---               CFYYY = ZERO
C---               CFZZZ = ZERO
C---               CFXXY = ZERO
C---               CFXXZ = ZERO
C---               CFXYY = ZERO
C---               CFYYZ = ZERO
C---               CFXZZ = ZERO
C---               CFYZZ = ZERO
C---               CFXYZ = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DOMONO(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
C---C                  Q  = EFCHG(1,IC2)
C---C                  QN = EFCHG(2,IC2)
C---C                  IF(ICHGP.EQ.3) THEN
C---C                     ALPHAA = EFATRM2(IC1)
C---C                     ALPHAB = EFATRM2(IC2)
C---C                  END IF
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  XY = X*Y
C---                  XZ = X*Z
C---                  YZ = Y*Z
C---                  XXX = XX*X
C---                  YYY = YY*Y
C---                  ZZZ = ZZ*Z
C---                  XXY = XX*Y
C---                  XXZ = XX*Z
C---                  XYY = XY*Y
C---                  YYZ = YY*Z
C---                  XZZ = XZ*Z
C---                  YZZ = YZ*Z
C---                  XYZ = XY*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---                  R5 = R2*R3
C---                  R7 = R2*R5
C---C
C---C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C---C  AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C---C
C---      DUM = Q2/R7
C---      RRX = R2*X
C---      RRY = R2*Y
C---      RRZ = R2*Z
C---C
C---C         NO SCREENING
C---         CFXXX = CFXXX + (FIVE*XXX-THREE*RRX)*DUM
C---         CFYYY = CFYYY + (FIVE*YYY-THREE*RRY)*DUM
C---         CFZZZ = CFZZZ + (FIVE*ZZZ-THREE*RRZ)*DUM
C---         CFXXY = CFXXY + (FIVE*XXY-RRY)*DUM
C---         CFXXZ = CFXXZ + (FIVE*XXZ-RRZ)*DUM
C---         CFXYY = CFXYY + (FIVE*XYY-RRX)*DUM
C---         CFYYZ = CFYYZ + (FIVE*YYZ-RRZ)*DUM
C---         CFXZZ = CFXZZ + (FIVE*XZZ-RRX)*DUM
C---         CFYZZ = CFYZZ + (FIVE*YZZ-RRY)*DUM
C---         CFXYZ = CFXYZ + (FIVE*XYZ)*DUM
C---         WRITE(6,*)'IC1',IC1,IC2,(FIVE*XXX-THREE*RRX)*DUM/Q2,
C---     *    (FIVE*YYY-THREE*RRY)*DUM/Q2
C---C
C---C------  FRAGMENT-FRAGMENT SCREENING --------
C---C             CODE BY LVS
C---C             KEEP FOR A WHILE
C---CC      ELSE
C---CC          FRAGMENT-FRAGMENT SCREENING
C---C         SCREEN1=ONE*Q2
C---C         SCREEN2=ZERO
C---C         SCREEN3=ZERO
C---C         DUM1=ONE/R7
C---CC           DO NOT USE CH-OCT SCREENING FOR NOW
C---CC         IF(R.LE.ELEVEN) THEN
C---C         IF(R.LE.ZERO) THEN
C---CC
C---C            AP=ALPHAA*R
C---C            BP=ALPHAB*R
C---C            AA2=ALPHAA*ALPHAA
C---C            AB2=ALPHAB*ALPHAB
C---C            DIFF=ABS(ALPHAA-ALPHAB)
C---CC
C---CC      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C---CC      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C---CC
C---CC               ALPHAA = ALPHAB
C---C            IF(DIFF.LT.SMALL) THEN
C---C               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP+PT5*AP*AP)*Q
C---C     *                       -EXP(-AP)*(ONE+AP)*QN
C---C               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)*Q
C---C     *                 -EXP(-AP)*(AP*AP)*QN
C---C               SCREEN3=-EXP(-AP)*(PT5*AP*AP*AP*(AP-ONE))*Q
C---C     *                 -EXP(-AP)*(AP*AP*AP)*QN
C---C            ELSE
C---C               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))*Q
C---C     *                       -EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))*Q
C---C     *                       -EXP(-AP)*(ONE+AP)*QN
C---C               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))*Q
C---C     *                 -EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))*Q
C---C     *                 -EXP(-AP)*(AP*AP)*QN
C---C               SCREEN3=-EXP(-AP)*(AP*AP*AP)*(AB2/(AB2-AA2))*Q
C---C     *                 -EXP(-BP)*(BP*BP*BP)*(AA2/(AA2-AB2))*Q
C---C     *                 -EXP(-AP)*(AP*AP*AP)*QN
C---C            END IF
C---C         END IF
C---CC
C---C         DAMP1=SCREEN1+0.4D+00*SCREEN2+ONE/15.0D+00*SCREEN3
C---C         DAMP2=SCREEN1+ONE/THREE*SCREEN2
C---CC
C---C         CFXXX = CFXXX + (FIVE*XXX*DAMP1-THREE*RRX*DAMP2)*DUM1
C---C         CFYYY = CFYYY + (FIVE*YYY*DAMP1-THREE*RRY*DAMP2)*DUM1
C---C         CFZZZ = CFZZZ + (FIVE*ZZZ*DAMP1-THREE*RRZ*DAMP2)*DUM1
C---C         CFXXY = CFXXY + (FIVE*XXY*DAMP1-RRY*DAMP2)*DUM1
C---C         CFXXZ = CFXXZ + (FIVE*XXZ*DAMP1-RRZ*DAMP2)*DUM1
C---C         CFXYY = CFXYY + (FIVE*XYY*DAMP1-RRX*DAMP2)*DUM1
C---C         CFYYZ = CFYYZ + (FIVE*YYZ*DAMP1-RRZ*DAMP2)*DUM1
C---C         CFXZZ = CFXZZ + (FIVE*XZZ*DAMP1-RRX*DAMP2)*DUM1
C---C         CFYZZ = CFYZZ + (FIVE*YZZ*DAMP1-RRY*DAMP2)*DUM1
C---C         CFXYZ = CFXYZ + (FIVE*XYZ*DAMP1)*DUM1
C---C      END IF
C---C
C---C------ END OF SCREENING CODE ---------
C---C
C---C.... POTENTIAL, FIELD, AND FIELD GRAD DUE TO DIPOLE MOMENTS ON JM
C---C
C---C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
C---370            CONTINUE
C---C
C---C
C---C.... POTENTIAL, FIELD, FIELD GRADIENT, ETC. AT POINT 'IPX' IN
C---C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C---C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IPX'
C---C     WITH THESE FIELDS TO THE 'IM' WITH 'JM' INTERACTION.
C---C
C---C.... CHARGE(JM) - OCTUPOLE(IM)
C---C
C---               TERM = XXX1*CFXXX + YYY1*CFYYY + ZZZ1*CFZZZ
C---     1              + THREE*(XXY1*CFXXY + XXZ1*CFXXZ + XYY1*CFXYY)
C---     1              + THREE*(YYZ1*CFYYZ + XZZ1*CFXZZ + YZZ1*CFYZZ)
C---     1              + SIX*XYZ1*CFXYZ
C---               TERM = -TERM/FIVE
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---C.... END OF 'JM' MOLECULE LOOP
C---380         CONTINUE
C---C
C---C.... END OF 'IPX' LOOP IN 'IM' MOLECULE
C---390      CONTINUE
C---C
C---C
C---C.... END OF 'IM' MOLECULE LOOP
C---400   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK DPLDPL
C---      SUBROUTINE DPLDPL(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00, THREE=3.0D+00)
C---      PARAMETER (ONE=1.0D+00,HALF=0.5D+00)
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C---C
C---      ELTOT=ZERO
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DODIPO(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            DX1 = EFDIP(1,IC1)
C---            DY1 = EFDIP(2,IC1)
C---            DZ1 = EFDIP(3,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---C
C---               IF (IM.GE.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               DFX = ZERO
C---               DFY = ZERO
C---               DFZ = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DODIPO(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  DX2 = EFDIP(1,IC2)
C---                  DY2 = EFDIP(2,IC2)
C---                  DZ2 = EFDIP(3,IC2)
C---                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
C---                     ALPHAA = EFATRM2(IC1)
C---                     ALPHAB = EFATRM2(IC2)
C---                  END IF
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---                  R5 = R2*R3
C---C
C---      DOT = DX2*X + DY2*Y + DZ2*Z
C---      DUM = DOT*THREE/R5
C---C
C---C         NO SCREENING
C---      IF(ICHGP.NE.3 .AND. ICHGP.NE.5) THEN
C---         DFX = DFX - DX2/R3 + X*DUM
C---         DFY = DFY - DY2/R3 + Y*DUM
C---         DFZ = DFZ - DZ2/R3 + Z*DUM
C---C
C---      ELSE
C---         SCREEN1=ONE
C---         SCREEN2=ZERO
C---         IF(R.LE.ELEVEN) THEN
C---C         FRAGMENT-FRAGMENT SCREENING
C---C
C---            AP=ALPHAA*R
C---            BP=ALPHAB*R
C---            AA2=ALPHAA*ALPHAA
C---            AB2=ALPHAB*ALPHAB
C---            DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C---C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C---C
C---C            FORMULA DUE OLD POTENTIAL
C---           IF(ICHGP.EQ.3) THEN
C---C               ALPHAA = ALPHAB
C---              IF(DIFF.LT.SMALL) THEN
C---                 SCREEN1=ONE-EXP(-AP)*(ONE+AP+HALF*AP*AP)
C---                 SCREEN2=-EXP(-AP)*(HALF*AP*AP*AP)
C---               ELSE
C---                  SCREEN1=ONE-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))
C---                  SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))
C---               END IF
C---C
C---C            FORMULA DUE NEW POTENTIAL
C---           ELSE
C---              IF(DIFF.LT.SMALL) THEN
C---                 SCREEN1=ONE-EXP(-AP)*(ONE+AP+AP*AP/TWO+
C---     *                      7.0D+00/48.0D+00*AP*AP*AP+
C---     *                      ONE/48.0D+00*AP*AP*AP*AP)
C---                 SCREEN2=-EXP(-AP)*ONE/48.0D+00*
C---     *            (THREE*AP*AP*AP+THREE*AP*AP*AP*AP+AP*AP*AP*AP*AP)
C---              ELSE
C---             SCREEN1=ONE-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
C---     *               ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)-
C---     *             EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
C---     *               ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)
C---             SCREEN2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
C---     *              (AP*AP*(-TWO*AA2/(-AA2+AB2))+AP*AP*AP/TWO)-
C---     *              EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
C---     *              (BP*BP*(-TWO*AB2/(AA2-AB2))+BP*BP*BP/TWO)
C---                END IF
C---             END IF
C---C
C---         END IF
C---C         WRITE(IW,*)'DPL_DPL: R=',R,'SCR1=',SCREEN1,'SCR2=',SCREEN2
C---C
C---         DFX =DFX-DX2/R3*SCREEN1+X*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---         DFY =DFY-DY2/R3*SCREEN1+Y*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---         DFZ =DFZ-DZ2/R3*SCREEN1+Z*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---      END IF
C---C
C---370            CONTINUE
C---C
C---C.... DIPOLE(JM) - DIPOLE(IM)
C---C
C---               TERM = -(DX1*DFX+DY1*DFY+DZ1*DFZ)
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---380         CONTINUE
C---390      CONTINUE
C---400   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK DPQUAD
C---      SUBROUTINE DPQUAD(ELTOT)
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      DIMENSION QUA(6,MXFGPT)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      DATA MD         /8HMD      /
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---C
C---      PARAMETER (ZERO=0.0D+00, THREE=3.0D+00, PT5=0.5D+00,
C---     *           ONEPT5=1.5D+00, TWO=2.0D+00, FIFTEN=1.5D+01)
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5, ONE=1.0D+00)
C---C
C---C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C---C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C---C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C---C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C---C.... EQUATION 15.                                          ....
C---C
C---      ELTOT=ZERO
C---      DO 210 I = 1,NMTTPT
C---        IF(.NOT.DOQUAD(I)) GO TO 210
C---        XX = EFQAD(1,I)
C---        YY = EFQAD(2,I)
C---        ZZ = EFQAD(3,I)
C---        XY = EFQAD(4,I)
C---        XZ = EFQAD(5,I)
C---        YZ = EFQAD(6,I)
C---        DUM = XX + YY + ZZ
C---        QUA(1,I) = PT5 * (THREE * XX - DUM)
C---        QUA(2,I) = PT5 * (THREE * YY - DUM)
C---        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
C---        QUA(4,I) = ONEPT5 * XY
C---        QUA(5,I) = ONEPT5 * XZ
C---        QUA(6,I) = ONEPT5 * YZ
C---210   CONTINUE
C---C
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DOQUAD(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            XX1 = QUA(1,IC1)
C---            YY1 = QUA(2,IC1)
C---            ZZ1 = QUA(3,IC1)
C---            XY1 = QUA(4,IC1)
C---            XZ1 = QUA(5,IC1)
C---            YZ1 = QUA(6,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---               IF (IM.EQ.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               DFXX = ZERO
C---               DFYY = ZERO
C---               DFZZ = ZERO
C---               DFXY = ZERO
C---               DFXZ = ZERO
C---               DFYZ = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DODIPO(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  DX2 = EFDIP(1,IC2)
C---                  DY2 = EFDIP(2,IC2)
C---                  DZ2 = EFDIP(3,IC2)
C---C
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  XY = X*Y
C---                  XZ = X*Z
C---                  YZ = Y*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---                  R5 = R2*R3
C---                  R7 = R2*R5
C---C
C---C  ----  FRAGMENT-FRAGMENT SCREENING
C---                  IF(ICHGP.EQ.3) THEN
C---                     ALPHAB = EFATRM2(IC2)
C---                     ALPHAA = EFATRM2(IC1)
C---                     BETAA = EFBTRM2(IC1)
C---                   END IF
C---C
C---C
C---C.... POTENTIAL, FIELD, AND FIELD GRAD DUE TO DIPOLE MOMENTS ON JM
C---C
C---      DOT = DX2*X + DY2*Y + DZ2*Z
C---C
C---      DUM = THREE/R5
C---C
C---C          NEXT IF CANNOT POSSIBLY BE TRUE
C---      IF (RUNTYP.EQ.ZERO) THEN
C---C  ----  THIS IS OLD CODE, WITHOUT AND WITH FRAG-FRAG ELECTROSTATIC
C---C  ----  SCREENING. KEEP FOR A WHILE FOR DEBUG PURPOSES
C---C         NO SCREENING
C---C      IF(ICHGP.NE.3) THEN
C---         DFXX = DFXX + (TWO*DX2*X)*DUM - FIFTEN*XX*DOT/R7
C---         DFYY = DFYY + (TWO*DY2*Y)*DUM - FIFTEN*YY*DOT/R7
C---         DFZZ = DFZZ + (TWO*DZ2*Z)*DUM - FIFTEN*ZZ*DOT/R7
C---         DFXY = DFXY + (DX2*Y+DY2*X)*DUM - FIFTEN*XY*DOT/R7
C---         DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*DOT/R7
C---         DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*DOT/R7
C---C
C---C      ELSE
C---C
C---C------FRAGMENT-FRAGMENT SCREENING BY LVS
C---C        KEEP FOR A WHILE
C---         SCREEN1=ONE
C---         SCREEN2=ZERO
C---         SCREEN3=ZERO
C---         IF(R.LE.ELEVEN) THEN
C---C
C---            AP=ALPHAA*R
C---            BP=ALPHAB*R
C---            AA2=ALPHAA*ALPHAA
C---            AB2=ALPHAB*ALPHAB
C---            DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C               ALPHAA = ALPHAB
C---            IF(DIFF.LT.SMALL) THEN
C---               SCREEN1=ONE-EXP(-AP)*(ONE+AP+PT5*AP*AP)
C---               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)
C---               SCREEN3=-EXP(-AP)*(PT5*AP*AP*AP*(AP-ONE))
C---            ELSE
C---               SCREEN1=ONE-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))
C---               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))
C---               SCREEN3=-EXP(-AP)*(AP*AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP*BP)*(AA2/(AA2-AB2))
C---            END IF
C---         END IF
C---C         WRITE(IW,*)'DPL_QUAD: R=',R,'SCR1=',SCREEN1,
C---C     *     'SCR2=',SCREEN2,'SCR3=',SCREEN3
C---C
C---         DFXX = DFXX + (TWO*DX2*X)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*XX*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         DFYY = DFYY + (TWO*DY2*Y)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*YY*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         DFZZ = DFZZ + (TWO*DZ2*Z)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*ZZ*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         DFXY = DFXY + (DX2*Y+DY2*X)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*XY*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*XZ*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM*(SCREEN1+ONE/THREE*SCREEN2)
C---     *   -FIFTEN*YZ*DOT/R7
C---     *      *(SCREEN1+0.4D+00*SCREEN2+ONE/FIFTEN*SCREEN3)
C---C
C---         END IF
C---C  ---- THIS IS A NEW CODE. IT IS BETTER STRUCTURED.
C---C  ---- IT GIVES THE SAME RESULTS AS THE OLD CODE
C---C
C---C         IF(1.EQ.0) THEN
C---C  ----  FRAGMENT-FRAGMENT SCREENING
C---C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
C---                     P1 = ZERO
C---                     P1D = ZERO
C---                     P2 = ZERO
C---                     P3 = ZERO
C---C
C---                  IF(ICHGP.EQ.3) THEN
C---C                  IF(1.EQ.0) THEN
C---                     ALPHAB = EFATRM2(IC2)
C---                     ALPHAA = EFATRM2(IC1)
C---                     BETAA = EFBTRM2(IC1)
C---C
C---C  ----  IF TURN ON FRAGMENT-FGARMENT SCREENING
C---                    IF(R.LE.ELEVEN.AND.BETAA.NE.ZERO) THEN
C---                       AP=ALPHAA*R
C---                       BP=ALPHAB*R
C---                       AA2=ALPHAA*ALPHAA
C---                       AB2=ALPHAB*ALPHAB
C---                       DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
C---                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,
C---     *                             P1,P1_N1,P1_N2)
C---                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
C---     *                            P1D,P1D_N1,P1D_N2)
C---                    P2 =  -P1D/R3
C---                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
C---     *                             P3,P3_N1,P3_N2)
C---                    END IF
C---                 END IF
C---C
C---               RMU2 = X*DX2 + Y*DY2 + Z*DZ2
C---               DUM = THREE/R5
C---          DFXX =DFXX + (ONE+P1)*((TWO*DX2*X)*DUM +
C---     *             (-FIFTEN*XX+THREE*R2)*RMU2/R7) +
C---     *            TWO*P2*DX2*X + P1D*RMU2*(THREE*XX-R2)/R5 +
C---     *            P3*RMU2*XX
C---          DFYY =DFYY + (ONE+P1)*((TWO*DY2*Y)*DUM +
C---     *             (-FIFTEN*YY+THREE*R2)*RMU2/R7) +
C---     *            TWO*P2*DY2*Y + P1D*RMU2*(THREE*YY-R2)/R5 +
C---     *            P3*RMU2*YY
C---          DFZZ =DFZZ + (ONE+P1)*((TWO*DZ2*Z)*DUM +
C---     *             (-FIFTEN*ZZ+THREE*R2)*RMU2/R7) +
C---     *            TWO*P2*DZ2*Z + P1D*RMU2*(THREE*ZZ-R2)/R5 +
C---     *            P3*RMU2*ZZ
C---          DFXY =DFXY
C---     *         +(ONE+P1)*((DX2*Y+DY2*X)*DUM - FIFTEN*XY*RMU2/R7)+
C---     *            P2*(DX2*Y+DY2*X)+ P1D*RMU2*(THREE*XY)/R5 +
C---     *            P3*RMU2*XY
C---          DFXZ =DFXZ
C---     *         +(ONE+P1)*((DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*RMU2/R7)+
C---     *            P2*(DX2*Z+DZ2*X)+ P1D*RMU2*(THREE*XZ)/R5 +
C---     *            P3*RMU2*XZ
C---          DFYZ =DFYZ
C---     *         +(ONE+P1)*((DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*RMU2/R7)+
C---     *            P2*(DY2*Z+DZ2*Y)+ P1D*RMU2*(THREE*YZ)/R5 +
C---     *            P3*RMU2*YZ
C---C
C---C      END IF
C---C
C---C------ END OF FRAGMENT-FRAGMENT SCREENING -------
C---C
C---C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
C---370            CONTINUE
C---C
C---C.... DIPOLE(JM) - QUADRUPOLE(IM)
C---C
C---               TERM = XX1*DFXX + YY1*DFYY + ZZ1*DFZZ
C---     1              + TWO*(XY1*DFXY + XZ1*DFXZ + YZ1*DFYZ)
C---               TERM = -TERM/THREE
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---380         CONTINUE
C---390      CONTINUE
C---400   CONTINUE
C---C
C---      RETURN
C---      END
C---C*MODULE EFELEC  *DECK QUDQUD
C---      SUBROUTINE QUDQUD(ELTOT)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
C---      LOGICAL GOPARR,DSKWRK,MASWRK
C---C
C---      CHARACTER*8 FRGNME
C---C
C---      DOUBLE PRECISION  MD
C---      DOUBLE PRECISION  MDTYP
C---C
C---      PARAMETER (MXFRG=1050, MXFGPT=12000,
C---     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C---C
C---      COMMON /DOMULT/ DOMONO(MXFGPT),DODIPO(MXFGPT),DOQUAD(MXFGPT),
C---     *                DOOCTU(MXFGPT)
C---      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
C---     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),
C---     *                EFBTRM2(MXFGPT),
C---     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C---     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C---      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C---     *                ,SWR1,SWR2,ISWF
C---      COMMON /EFPGES/ DESFRG(6,MXFRG)
C---      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C---     *                NPPTS(MXFRG),NPTTPT,IEFP,
C---     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C---     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C---C     DIMENSION QUAQUA(MXFRG,MXFRG),ASUM(MXFRG,MXFRG),QUA(6,MXFGPT)
C---      DIMENSION QUA(6,MXFGPT)
C---C
C---      COMMON /MDSIM/  DT, BATHT, EKINT, EKINR, MDTYP
C---      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C---      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C---     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
C---     *                ATORQ(3,MXFRG)
C---C
C---      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,
C---     *                GOPARR,DSKWRK,MASWRK
C---      COMMON /EFPAR / LOCNFG,NLOW,NUP
C---      DATA MD         /8HMD      /
C---C
C---      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
C---      DATA THREE,SIX/3.0D+00,6.0D+00/
C---      DATA ZERO/0.0D+00/
C---      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5,
C---     *            ONE=1.0D+00,SEVEN=7.0D+00)
C---C
C---C.... REPLACE THE SECOND MOMENTS OF THE CHARGE DISTRIBUTION ....
C---C.... WITH ELECTRIC QUADRUPOLE MOMENT TENSORS               ....
C---C.... SEE BUCKINGHAM, ET AL, "MOLECULAR QUADRUPOLE MOMENTS" ....
C---C.... QUART. REV. (LONDON) -13-, 183-214 (1959)             ....
C---C.... EQUATION 15.                                          ....
C---C
C---      ELTOT=ZERO
C---      DO 210 I = 1,NMTTPT
C---        IF(.NOT.DOQUAD(I)) GO TO 210
C---        XX = EFQAD(1,I)
C---        YY = EFQAD(2,I)
C---        ZZ = EFQAD(3,I)
C---        XY = EFQAD(4,I)
C---        XZ = EFQAD(5,I)
C---        YZ = EFQAD(6,I)
C---        DUM = XX + YY + ZZ
C---        QUA(1,I) = PT5 * (THREE * XX - DUM)
C---        QUA(2,I) = PT5 * (THREE * YY - DUM)
C---        QUA(3,I) = PT5 * (THREE * ZZ - DUM)
C---        QUA(4,I) = ONEPT5 * XY
C---        QUA(5,I) = ONEPT5 * XZ
C---        QUA(6,I) = ONEPT5 * YZ
C---210   CONTINUE
C---C
C---      IC1=0
C---C
C---      IF (GOPARR) THEN
C---        DO I=1,NLOW-1
C---          IC1 = IC1 + NMPTS(I)
C---        ENDDO
C---      ENDIF
C---C
C---C     DO 400 IM = 1,NFRG
C---      DO 400 IM = NLOW,NUP
C---C
C---         IF(RUNTYP .EQ. MD) THEN
C---           COMX1 = EFCENT(1,IM)
C---           COMY1 = EFCENT(2,IM)
C---           COMZ1 = EFCENT(3,IM)
C---         ENDIF
C---C
C---         DO 390 IPX = 1,NMPTS(IM)
C---            IC1=IC1+1
C---            IF(.NOT.DOQUAD(IC1)) GO TO 390
C---            X1 = EFC(1,IC1)
C---            Y1 = EFC(2,IC1)
C---            Z1 = EFC(3,IC1)
C---            XX1 = QUA(1,IC1)
C---            YY1 = QUA(2,IC1)
C---            ZZ1 = QUA(3,IC1)
C---            XY1 = QUA(4,IC1)
C---            XZ1 = QUA(5,IC1)
C---            YZ1 = QUA(6,IC1)
C---            IC2=0
C---            DO 380 JM = 1,NFRG
C---C
C---               IF (IM.GE.JM) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GO TO 380
C---               END IF
C---C
C---               IF(RUNTYP .EQ. MD) THEN
C---                COMX2 = EFCENT(1,JM)
C---                COMY2 = EFCENT(2,JM)
C---                COMZ2 = EFCENT(3,JM)
C---C
C---                COMX = COMX1 - COMX2
C---                COMY = COMY1 - COMY2
C---                COMZ = COMZ1 - COMZ2
C---C
C---                PBCX = BOXL * ANINT(COMX * BOXLI)
C---                PBCY = BOXL * ANINT(COMY * BOXLI)
C---                PBCZ = BOXL * ANINT(COMZ * BOXLI)
C---               ENDIF
C---C
C---               SWF   = 1.0D+00
C---               SWFDX = 0.0D+00
C---               SWFDY = 0.0D+00
C---               SWFDZ = 0.0D+00
C---C
C---               XADD=ZERO
C---               YADD=ZERO
C---               ZADD=ZERO
C---          IF(XBOX.NE.ZERO.AND.YBOX.NE.ZERO.AND.ZBOX.NE.ZERO)THEN
C---               X12  = EFCENT(1,IM) - EFCENT(1,JM)
C---               Y12  = EFCENT(2,IM) - EFCENT(2,JM)
C---               Z12  = EFCENT(3,IM) - EFCENT(3,JM)
C---               XADD = XBOX * ANINT(X12/XBOX)
C---               YADD = YBOX * ANINT(Y12/YBOX)
C---               ZADD = ZBOX * ANINT(Z12/ZBOX)
C---               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - XADD)
C---               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - YADD)
C---               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - ZADD)
C---               IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---               R12  = X12*X12+Y12*Y12+Z12*Z12
C---               IF(R12.GT.RCUT)THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               END IF
C---C
C---               IF(R12.GT.SWR2*SWR2) THEN
C---                 IC2=IC2+NMPTS(JM)
C---                 GOTO 380
C---               ELSE IF(R12.GT.SWR1*SWR1) THEN
C---                 IF(ISWF.EQ.1) THEN
C---                    DUMY1 = 1.0D+00/(SWR2*SWR2 - SWR1*SWR1)
C---                    DUMY2 = DUMY1*DUMY1
C---                    DUMY3 = DUMY2*DUMY1
C---                    DUMY4 = DUMY2*DUMY2
C---                    DUMY5 = DUMY2*DUMY3
C---                    VUMY1 = R12 - SWR1*SWR1
C---                    VUMY2 = VUMY1*VUMY1
C---                    VUMY3 = VUMY2*VUMY1
C---                    VUMY4 = VUMY2*VUMY2
C---                    VUMY5 = VUMY2*VUMY3
C---                    DSWF  = -30.0D+00*DUMY3*VUMY2
C---     *                      +60.0D+00*DUMY4*VUMY3
C---     *                      -30.0D+00*DUMY5*VUMY4
C---                    DSWF  = 2.0D+00*DSWF
C---                    SWF   = 1.0D+00 - 10.0D+00*DUMY3*VUMY3
C---     *                              + 15.0D+00*DUMY4*VUMY4
C---     *                              -  6.0D+00*DUMY5*VUMY5
C---                    SWFDX = DSWF*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 ELSE IF(ISWF.EQ.2) THEN
C---                    R12   = SQRT(R12)
C---                    PIL   = 3.1415926535897932D+00/(SWR2-SWR1)
C---                    DUMY  = (R12 - SWR1) * PIL
C---                    SWF   = 0.50D+00 * (COS(DUMY) + 1.0D+00)
C---                    DUMY2 =-0.50D+00 * SIN(DUMY) * PIL / R12
C---                    SWFDX = DUMY2*(EFCENT(1,IM)-EFCENT(1,JM)-XADD)
C---                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-YADD)
C---                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-ZADD)
C---                 END IF
C---               END IF
C---C
C---               END IF
C---C
C---               QUAD = ZERO
C---               DO 370 JP = 1,NMPTS(JM)
C---                  IC2=IC2+1
C---            IF(.NOT.DOQUAD(IC2)) GO TO 370
C---                  X2 = EFC(1,IC2)
C---                  Y2 = EFC(2,IC2)
C---                  Z2 = EFC(3,IC2)
C---                  X2 = X2 + XADD
C---                  Y2 = Y2 + YADD
C---                  Z2 = Z2 + ZADD
C---                  XX2 = QUA(1,IC2)
C---                  YY2 = QUA(2,IC2)
C---                  ZZ2 = QUA(3,IC2)
C---                  XY2 = QUA(4,IC2)
C---                  XZ2 = QUA(5,IC2)
C---                  YZ2 = QUA(6,IC2)
C---                  IF(ICHGP.EQ.3) THEN
C---                     ALPHAA = EFATRM2(IC1)
C---                     ALPHAB = EFATRM2(IC2)
C---                  END IF
C---C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
C---                  X = X1 - X2
C---                  Y = Y1 - Y2
C---                  Z = Z1 - Z2
C---C
C---                   IF ( RUNTYP .EQ. MD ) THEN
C---                    X = X - PBCX
C---                    Y = Y - PBCY
C---                    Z = Z - PBCZ
C---                  ENDIF
C---C
C---                  XX = X*X
C---                  YY = Y*Y
C---                  ZZ = Z*Z
C---                  XY = X*Y
C---                  XZ = X*Z
C---                  YZ = Y*Z
C---                  R2 = XX+YY+ZZ
C---                  R = SQRT(R2)
C---                  R3 = R2*R
C---                  R5 = R2*R3
C---                  R7 = R2*R5
C---                  R9 = R2*R7
C---C
C---C.... GET THE QUADRUPOLE(IM)-QUADRUPOLE CONTRIBUTION(JM) ....
C---C     THIS PART HANDLED SEPARATELY FROM REST UNTIL
C---C     FIELD GRADIENT DUE TO QUADRUPOLE IS DERIVED
C---C
C---C      NEXT IF WILL ALWAYS BE TRUE
C---          IF (RUNTYP.NE.ZERO) THEN
C---C                               NO SCREENING
C---                  VAL = ZERO
C---                  VAL = VAL + X*(X*XX2 + Y*XY2 + Z*XZ2)
C---                  VAL = VAL + Y*(X*XY2 + Y*YY2 + Z*YZ2)
C---                  VAL = VAL + Z*(X*XZ2 + Y*YZ2 + Z*ZZ2)
C---                  QUAD1 = XX1*XX2 + TWO*XY1*XY2 + TWO*XZ1*XZ2
C---                  QUAD1 = QUAD1 + YY1*YY2 + TWO*YZ1*YZ2 + ZZ1*ZZ2
C---                  QUAD = QUAD + QUAD1*SIX/R5
C---                  QUAD2 = X*(X*XX1+Y*XY1+Z*XZ1)
C---                  QUAD2 = Y*(X*XY1+Y*YY1+Z*YZ1) + QUAD2
C---                  QUAD2 = Z*(X*XZ1+Y*YZ1+Z*ZZ1) + QUAD2
C---                  QUAD = QUAD + QUAD2*VAL*105.0D+00 / R9
C---                  FACT1 = X*XX1 + Y*XY1 + Z*XZ1
C---                  FACT2 = X*XX2 + Y*XY2 + Z*XZ2
C---                  QUAD3 = FACT1 * FACT2
C---                  FACT1 = X*XY1 + Y*YY1 + Z*YZ1
C---                  FACT2 = X*XY2 + Y*YY2 + Z*YZ2
C---                  QUAD3 = QUAD3 + FACT1 * FACT2
C---                  FACT1 = X*XZ1 + Y*YZ1 + Z*ZZ1
C---                  FACT2 = X*XZ2 + Y*YZ2 + Z*ZZ2
C---                  QUAD3 = QUAD3 + FACT1 * FACT2
C---                  QUAD = QUAD - 60.0D+00 * QUAD3 / R7
C---C
C---         ELSE
C---C
C---C---------FRAGMENT-FRAGMENT SCREENING BY LVS -------
C---C         KEEP THIS CODE FOR A WHILE
C---         SCREEN1=ONE
C---         SCREEN2=ZERO
C---         SCREEN3=ZERO
C---         SCREEN4=ZERO
C---         IF(R.LE.ELEVEN) THEN
C---C           NEVER!
C---C         IF(R.LE.ZERO) THEN
C---C         FRAGMENT-FRAGMENT SCREENING
C---C
C---            AP=ALPHAA*R
C---            BP=ALPHAB*R
C---            AA2=ALPHAA*ALPHAA
C---            AB2=ALPHAB*ALPHAB
C---            DIFF=ABS(ALPHAA-ALPHAB)
C---C
C---C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C---C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C---C
C---C               ALPHAA = ALPHAB
C---            IF(DIFF.LT.SMALL) THEN
C---               SCREEN1=ONE-EXP(-AP)*(ONE+AP+PT5*AP*AP)
C---               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)
C---               SCREEN3=-EXP(-AP)*(PT5*AP*AP*AP*(AP-ONE))
C---               SCREEN4=-EXP(-AP)*(PT5*AP*AP*AP*AP*(AP-TWO))
C---            ELSE
C---               SCREEN1=ONE-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))
C---               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))
C---               SCREEN3=-EXP(-AP)*(AP*AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP*BP)*(AA2/(AA2-AB2))
C---               SCREEN4=-EXP(-AP)*(AP*AP*AP*AP)*(AB2/(AB2-AA2))-
C---     *                 EXP(-BP)*(BP*BP*BP*BP)*(AA2/(AA2-AB2))
C---            END IF
C---         END IF
C---C
C---C           DAMPING FOR DIFFERENT PARTS OF QUAD-QUAD ENERGY
C---        DAMP1=SCREEN1 + THREE/SEVEN*SCREEN2
C---     *       + TWO/(THREE*SEVEN)*SCREEN3
C---     *       + ONE/105.0D+00*SCREEN4
C---        DAMP2=SCREEN1+0.4D+00*SCREEN2 + ONE/15.0D+00*SCREEN3
C---        DAMP3=SCREEN1+ONE/THREE*SCREEN2
C---C
C---                  VAL = ZERO
C---                  VAL = VAL + X*(X*XX2 + Y*XY2 + Z*XZ2)
C---                  VAL = VAL + Y*(X*XY2 + Y*YY2 + Z*YZ2)
C---                  VAL = VAL + Z*(X*XZ2 + Y*YZ2 + Z*ZZ2)
C---                  QUAD1 = XX1*XX2 + TWO*XY1*XY2 + TWO*XZ1*XZ2
C---                  QUAD1 = QUAD1 + YY1*YY2 + TWO*YZ1*YZ2 + ZZ1*ZZ2
C---                  QUAD = QUAD + QUAD1*SIX/R5*DAMP3
C---                  QUAD2 = X*(X*XX1+Y*XY1+Z*XZ1)
C---                  QUAD2 = Y*(X*XY1+Y*YY1+Z*YZ1) + QUAD2
C---                  QUAD2 = Z*(X*XZ1+Y*YZ1+Z*ZZ1) + QUAD2
C---                  QUAD = QUAD + QUAD2*VAL*105.0D+00/R9*DAMP1
C---                  FACT1 = X*XX1 + Y*XY1 + Z*XZ1
C---                  FACT2 = X*XX2 + Y*XY2 + Z*XZ2
C---                  QUAD3 = FACT1 * FACT2
C---                  FACT1 = X*XY1 + Y*YY1 + Z*YZ1
C---                  FACT2 = X*XY2 + Y*YY2 + Z*YZ2
C---                  QUAD3 = QUAD3 + FACT1 * FACT2
C---                  FACT1 = X*XZ1 + Y*YZ1 + Z*ZZ1
C---                  FACT2 = X*XZ2 + Y*YZ2 + Z*ZZ2
C---                  QUAD3 = QUAD3 + FACT1 * FACT2
C---                  QUAD = QUAD - 60.0D+00*QUAD3/R7*DAMP2
C---C
C---C         WRITE(IW,*) 'DPL_QUAD: R=',R,'SCR1=',SCREEN1,
C---C     *                'SCR2=',SCREEN2,'SCR3=',SCREEN3
C---C
C---C------- END OF FRAGMENT-FRAGMENT SCREENING --------
C---C
C---       END IF
C---C
C---C     FIELD DUE TO QUADRUPOLE MOMENTS ON JM.
C---C
C---C.... END OF POINT 'JP' LOOP IN MOLECULE 'JM'
C---370            CONTINUE
C---C
C---C.... QUADRUPOLE(JM) - QUADRUPOLE(IM)
C---C
C---               TERM = TWO*QUAD/18.0D+00
C---               ELTOT = ELTOT + SWF*TERM
C---              DESFRG(1,JM) = DESFRG(1,JM) - TERM*SWFDX
C---              DESFRG(2,JM) = DESFRG(2,JM) - TERM*SWFDY
C---              DESFRG(3,JM) = DESFRG(3,JM) - TERM*SWFDZ
C---              DESFRG(1,IM) = DESFRG(1,IM) + TERM*SWFDX
C---              DESFRG(2,IM) = DESFRG(2,IM) + TERM*SWFDY
C---              DESFRG(3,IM) = DESFRG(3,IM) + TERM*SWFDZ
C---380         CONTINUE
C---390      CONTINUE
C---400   CONTINUE
C---C
C---C     RUNTYP=ENERGY
C---      RETURN
C---      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
      DIMENSION TMP(6)
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 /EFPAR / LOCNFG,NLOW,NUP
      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,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
C
      DATA MD         /8HMD      /
C
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      PI=4.0D+00 * ATAN(1.0D+00)
      IC1=0
C  ---- LVS: TEMPORARY!
      CCX = ZERO
C      CALL VCLR(DESFRG,1,6*MXFRG)
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      END DO
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 IPX = 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.GE.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)
               GTPCHPE=ZERO
C
C    THIS IS THE OLD FORMULA BY MARK FREITAG
           IF(ICHGP.EQ.2.OR.ICHGP.EQ.3) THEN
C
        IF(DIFF.LT.SMALL) THEN
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 IF ALPHAA NOT EQUAL TO ALPHAB:
        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
        END IF
C
           IF(ICHGP.EQ.4.OR.ICHGP.EQ.5) THEN
C           FORMULA DUE NEW POTENTIAL
C
        IF(DIFF.LT.SMALL) THEN
        GTPCHPE=-EXP(-AP)/R3*(Q1*Q2*(ONE+AP+ONE/TWO*AP*AP+
     *           7.0D+00/48.0D+00*AP*AP*AP+ONE/48.0D+00*AP*AP*AP*AP)
     *           +(Q1*Q2N+Q2*Q1N)*(ONE+AP+AP*AP/TWO))
C
        ELSE
C
        GTPCHPE1=-ONE/R3*(Q1*Q2N*EXP(-AP)*(ONE+AP+AP*AP/TWO)+
     *             Q2*Q1N*EXP(-BP)*(ONE+BP+BP*BP/TWO))
C
        GTPCHAA=-ONE/R3*Q1*Q2*
     *          EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *          ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)
C
        GTPCHBB=-ONE/R3*Q1*Q2*
     *           EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *           ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)
C
        GTPCHPE=GTPCHPE1+GTPCHAA+GTPCHBB
        END IF
        END IF
C
            CON1=CON1+GTPCHPE
C
  249       CONTINUE
            CONX=CON1*X
            CONY=CON1*Y
            CONZ=CON1*Z
       CCX = CCX + CONZ
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
        WRITE(6,*)'CCX',CCX
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      END DO
      WRITE(6,*)'TMP',TMP
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
      DIMENSION TMP(6)
C
      DOUBLE PRECISION  MD
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 /EFPAR / LOCNFG,NLOW,NUP
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,TWO=2.0D+00, THREE=3.0D+00,
     *           PT5=0.5D+00)
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      IC1=0
      CDX1 = ZERO
      CDX2 = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,2)
      END DO
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 IPX = 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)
                  Q = EFCHG(1,IC2)
                  QN = EFCHG(2,IC2)
                  EX = ZERO
                  CF = ZERO
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
                     ALPHAA = EFATRM2(IC1)
                     ALPHAB = EFATRM2(IC2)
                  END IF
                  IF(ICHGP.EQ.1) THEN
                     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 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R3
      DOT = DX1*X + DY1*Y + DZ1*Z
C
C        FRAGMENT-FRAGMENT DAMPING
      IF(ICHGP.GE.3) THEN
         DUM1 = ONE/R3
         SCREEN1=ONE*Q2
         SCREEN2=ZERO
         IF(R.LE.ELEVEN) THEN
C         FRAGMENT-FRAGMENT SCREENING
C
            AP=ALPHAA*R
            BP=ALPHAB*R
            AA2=ALPHAA*ALPHAA
            AB2=ALPHAB*ALPHAB
            DIFF=ABS(ALPHAA-ALPHAB)
C
C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C
          IF(ICHGP.EQ.3) THEN
C               ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP+PT5*AP*AP)*Q
     *                       -EXP(-AP)*(ONE+AP)*QN
               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)*Q
     *                 -EXP(-AP)*(AP*AP)*QN
            ELSE
               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))*Q
     *                       -EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))*Q
     *                       -EXP(-AP)*(ONE+AP)*QN
               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))*Q
     *                 -EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))*Q
     *                 -EXP(-AP)*(AP*AP)*QN
            END IF
          END IF
C
          IF(ICHGP.EQ.5) THEN
C               ALPHAA = ALPHAB
C                 CODE DUE NEW POTENTIAL
C
               IF(DIFF.LT.SMALL) THEN
                  SCREEN1=ONE*Q2-
     *                    EXP(-AP)*(ONE+AP+AP*AP/TWO+
     *                      7.0D+00/48.0D+00*AP*AP*AP+
     *                      ONE/48.0D+00*AP*AP*AP*AP)*Q-
     *                    EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
                  SCREEN2=-EXP(-AP)*ONE/48.0D+00*
     *             (THREE*AP*AP*AP+THREE*AP*AP*AP*AP+AP*AP*AP*AP*AP)*Q
     *                    -EXP(-AP)*(AP*AP*AP/TWO)*QN
               ELSE
                  SCREEN1=ONE*Q2-
     *                  EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
     *                   ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)-
     *                  EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
     *                   ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)-
     *                  EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
                  SCREEN2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
     *                   (AP*AP*(-TWO*AA2/(-AA2+AB2))+AP*AP*AP/TWO)-
     *                  EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
     *                   (BP*BP*(-TWO*AB2/(AA2-AB2))+BP*BP*BP/TWO)-
     *                  EXP(-AP)*(AP*AP*AP/TWO)*QN
               END IF
           END IF
         END IF
C
         CFR =  DUM1*SCREEN1
         CN1 = (3.0D+00/R5)*DOT*(SCREEN1+ONE/THREE*SCREEN2)
      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
       IF (IM.EQ.1) THEN
          CDX1 = CDX1 +CFR*(DY1*Z-DZ1*Y)
       ELSE
           CDX2 = CDX2 +CFR*(DY1*Z-DZ1*Y)
       END IF
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'CDX1,CDX2',CDX1,CDX2
      DO I=1,6
      TMP(I) = DESFRG(I,2)-TMP(I)
      END DO
      WRITE(6,*)'TMPCD',TMP
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
      DIMENSION TMP(6),TMP1(6)
C
      DOUBLE PRECISION  MD
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 /EFPAR / LOCNFG,NLOW,NUP
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00,THREE=3.0D+00, PT5=0.5D+00,
     *           ONE=1.0D+00)
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
C
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      IC1=0
      DDX1 = ZERO
      DDX2 = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      TMP1(I) = DESFRG(I,2)
      END DO
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 IPX = 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)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
                     ALPHAA = EFATRM2(IC1)
                     ALPHAB = EFATRM2(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
                  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           FRAGMENT-FRAGMENT SCREENING
      DAMP0=ONE
      DAMP1=ONE
      DAMP2=ONE
      DAMP3=ONE
C
      IF(ICHGP.EQ.3 .OR. ICHGP.EQ.5) THEN
         SCR1=ONE
         SCR2=ZERO
         SCREEN1=ONE
         SCREEN2=ZERO
         SCREEN3=ZERO
         IF(R.LE.ELEVEN) THEN
            AP=ALPHAA*R
            BP=ALPHAB*R
            AA2=ALPHAA*ALPHAA
            AB2=ALPHAB*ALPHAB
            DIFF=ABS(ALPHAA-ALPHAB)
C
C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C
         IF(ICHGP.EQ.3) THEN
C               ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               SCREEN1=ONE-EXP(-AP)*(ONE+AP+PT5*AP*AP)
               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)
               SCREEN3=-EXP(-AP)*(PT5*AP*AP*AP*(AP-ONE))
            ELSE
               SCREEN1=ONE-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))-
     *                 EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))
               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))-
     *                 EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))
               SCREEN3=-EXP(-AP)*(AP*AP*AP)*(AB2/(AB2-AA2))-
     *                 EXP(-BP)*(BP*BP*BP)*(AA2/(AA2-AB2))
            END IF
         DAMP0=SCREEN1
         DAMP1=SCREEN1+ONE/THREE*SCREEN2
         DAMP2=DAMP1
         DAMP3=SCREEN1+0.4D+00*SCREEN2+ONE/15.0D+00*SCREEN3
         ELSE
C               ALPHAA = ALPHAB
              IF(DIFF.LT.SMALL) THEN
C                   SCR1 AND SCR2 ARE DIPOLE-DIPOLE SCREENINGS
                SCR1=ONE-EXP(-AP)*(ONE+AP+AP*AP/TWO+
     *                      7.0D+00/48.0D+00*AP*AP*AP+
     *                      ONE/48.0D+00*AP*AP*AP*AP)
                SCR2=-EXP(-AP)*ONE/48.0D+00*
     *              (THREE*AP*AP*AP+THREE*AP*AP*AP*AP+AP*AP*AP*AP*AP)
C
                SCREEN1=ONE-EXP(-AP)*(ONE+AP+AP*AP/TWO+
     *                      AP*AP*AP/6.0D+00+
     *                      ONE/24.0D+00*AP*AP*AP*AP)
                 SCREEN2=-EXP(-AP)*(ONE/8.0D+00*AP*AP*AP*AP*AP+
     *                    ONE/48.0D+00*AP*AP*AP*AP*AP*AP)
              ELSE
                WA=-TWO*AA2/(-AA2+AB2)
                WB=-TWO*AB2/(AA2-AB2)
                SCR1=ONE-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                  ((ONE+AP)*(ONE+WA)+AP*AP/TWO)-
     *                EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                  ((ONE+BP)*(ONE+WB)+BP*BP/TWO)
                SCR2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                 (AP*AP*WA+AP*AP*AP/TWO)-
     *                 EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                 (BP*BP*WB+BP*BP*BP/TWO)
C
                SCREEN1=ONE-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                  ((ONE+AP)*(ONE+WA)+AP*AP/TWO+AP*AP*AP/6.0D+00+
     *                   WA*AP*AP/THREE)-
     *                EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                  ((ONE+BP)*(ONE+WB)+BP*BP/TWO+BP*BP*BP/6.0D+00+
     *                   WB*BP*BP/THREE)
                SCREEN2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                 (AP*AP*WA*(1+AP)+AP*AP*AP*AP/TWO)-
     *                 EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                 (BP*BP*WB*(1+BP)+BP*BP*BP*BP/TWO)
                END IF
         DAMP0=SCR1
         DAMP1=SCR1+ONE/THREE*SCR2
         DAMP2=SCREEN1
         DAMP3=SCREEN1+ONE/15.0D+00*SCREEN2
         END IF
      END IF
      END IF
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)
C
      DFX2 = -DX2/R3*DAMP0 + X*DUM2*DAMP1
      DFY2 = -DY2/R3*DAMP0 + Y*DUM2*DAMP1
      DFZ2 = -DZ2/R3*DAMP0 + Z*DUM2*DAMP1
      DFX1 = -DX1/R3*DAMP0 + X*DUM1*DAMP1
      DFY1 = -DY1/R3*DAMP0 + Y*DUM1*DAMP1
      DFZ1 = -DZ1/R3*DAMP0 + Z*DUM1*DAMP1
      CONX = DUM*(DOTM*X+DOTX)*DAMP2-DUM7*X*DAMP3
      CONY = DUM*(DOTM*Y+DOTY)*DAMP2-DUM7*Y*DAMP3
      CONZ = DUM*(DOTM*Z+DOTZ)*DAMP2-DUM7*Z*DAMP3
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
        DDX1 =       DDX1 + (DY1*DFZ2-DZ1*DFY2)
        DDX2 =       DDX1 + (DY2*DFZ1-DZ2*DFY1)
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'DDX1,DDX2',DDX1,DDX2
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      TMP1(I) = DESFRG(I,2)-TMP1(I)
      END DO
      WRITE(6,*)'TMPDDI',TMP
      WRITE(6,*)'TMPDDJ',TMP1
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
      DIMENSION TMP(6),TMP1(6)
C
      DOUBLE PRECISION  MD
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 /EFPAR / LOCNFG,NLOW,NUP
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /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 THREE/3.0D+00/, ZERO/0.0D+00/
      PARAMETER (ONE=1.0D+00)
      PARAMETER (ELEVEN=11.0D+00, SMALL=1.0D-5)
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
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      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
      CQX1 = ZERO
      CQX2 = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      TMP1(I) = DESFRG(I,2)
      END DO
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 IPX = 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)
                  Q  = EFCHG(1,IC2)
                  QN = EFCHG(2,IC2)
                  IF(ICHGP.EQ.3.OR.ICHGP.EQ.5) THEN
                     ALPHAA = EFATRM2(IC1)
                     ALPHAB = EFATRM2(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
                  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           FRAGMENT-FRAGMENT SCREENING
C      DAMP0=Q2
      DAMP1=Q2
      DAMP2=Q2
      DAMP3=Q2
C
      IF(ICHGP.EQ.3 .OR. ICHGP.EQ.5) THEN
         SCR1=Q2
         SCR2=ZERO
         SCREEN1=Q2
         SCREEN2=ZERO
         SCREEN3=ZERO
         IF(R.LE.ELEVEN) THEN
            AP=ALPHAA*R
            BP=ALPHAB*R
            AA2=ALPHAA*ALPHAA
            AB2=ALPHAB*ALPHAB
            DIFF=ABS(ALPHAA-ALPHAB)
C
C      SCREEN1 IS DAMPING PART WITH ANGLE-DEPENDANCE AS MAIN ENERGY
C      SCREEN2 HAS DIFFERENT ANGLE DEPENDANCE
C
         IF(ICHGP.EQ.3) THEN
C               ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP+PT5*AP*AP)*Q
     *                       -EXP(-AP)*(ONE+AP)*QN
               SCREEN2=-EXP(-AP)*(PT5*AP*AP*AP)*Q
     *                 -EXP(-AP)*(AP*AP)*QN
               SCREEN3=-EXP(-AP)*(PT5*AP*AP*AP*(AP-ONE))*Q
     *                 -EXP(-AP)*(AP*AP*AP)*QN
            ELSE
               SCREEN1=ONE*Q2-EXP(-AP)*(ONE+AP)*(AB2/(AB2-AA2))*Q-
     *                 EXP(-BP)*(ONE+BP)*(AA2/(AA2-AB2))*Q
     *                 -EXP(-AP)*(ONE+AP)*QN
               SCREEN2=-EXP(-AP)*(AP*AP)*(AB2/(AB2-AA2))*Q-
     *                 EXP(-BP)*(BP*BP)*(AA2/(AA2-AB2))*Q
     *                 -EXP(-AP)*(AP*AP)*QN
               SCREEN3=-EXP(-AP)*(AP*AP*AP)*(AB2/(AB2-AA2))*Q-
     *                 EXP(-BP)*(BP*BP*BP)*(AA2/(AA2-AB2))*Q
     *                 -EXP(-AP)*(AP*AP*AP)*QN
            END IF
C         DAMP0=SCREEN1
         DAMP1=SCREEN1+ONE/THREE*SCREEN2
         DAMP2=DAMP1
         DAMP3=SCREEN1+0.4D+00*SCREEN2+ONE/15.0D+00*SCREEN3
         ELSE
C               ALPHAA = ALPHAB
              IF(DIFF.LT.SMALL) THEN
C                   SCR1 AND SCR2 ARE DIPOLE-DIPOLE SCREENINGS
                SCR1=ONE*Q2-EXP(-AP)*(ONE+AP+AP*AP/TWO+
     *                      7.0D+00/48.0D+00*AP*AP*AP+
     *                      ONE/48.0D+00*AP*AP*AP*AP)*Q-
     *                    EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
                SCR2=-EXP(-AP)*ONE/48.0D+00*
     *            (THREE*AP*AP*AP+THREE*AP*AP*AP*AP+AP*AP*AP*AP*AP)*Q
     *             -EXP(-AP)*(AP*AP*AP/TWO)*QN
C
                SCREEN1=Q2-EXP(-AP)*(ONE+AP+AP*AP/TWO+
     *                 AP*AP*AP/6.0D+00+
     *                 ONE/24.0D+00*AP*AP*AP*AP)*Q-
     *                 EXP(-AP)*(ONE+AP+AP*AP/TWO+AP*AP*AP/6.0D+00)*QN
                 SCREEN2=-EXP(-AP)*(ONE/8.0D+00*AP*AP*AP*AP*AP+
     *                    ONE/48.0D+00*AP*AP*AP*AP*AP*AP)*Q
     *                    -EXP(-AP)*(AP*AP*AP*AP/TWO)*QN
              ELSE
                WA=-TWO*AA2/(-AA2+AB2)
                WB=-TWO*AB2/(AA2-AB2)
                SCR1=Q2-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                  ((ONE+AP)*(ONE+WA)+AP*AP/TWO)*Q-
     *                EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                  ((ONE+BP)*(ONE+WB)+BP*BP/TWO)*Q-
     *                  EXP(-AP)*(ONE+AP+AP*AP/TWO)*QN
                SCR2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*Q*
     *                 (AP*AP*WA+AP*AP*AP/TWO)-
     *                 EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*Q*
     *                 (BP*BP*WB+BP*BP*BP/TWO)-
     *                  EXP(-AP)*(AP*AP*AP/TWO)*QN
C
                SCREEN1=Q2-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                  ((ONE+AP)*(ONE+WA)+AP*AP/TWO+AP*AP*AP/6.0D+00+
     *                   WA*AP*AP/THREE)*Q-
     *                EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                  ((ONE+BP)*(ONE+WB)+BP*BP/TWO+BP*BP*BP/6.0D+00+
     *                   WB*BP*BP/THREE)*Q-
     *                EXP(-AP)*(ONE+AP+AP*AP/TWO+AP*AP*AP/6.0D+00)*QN
                SCREEN2=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
     *                 (AP*AP*WA*(1+AP)+AP*AP*AP*AP/TWO)*Q-
     *                 EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
     *                 (BP*BP*WB*(1+BP)+BP*BP*BP*BP/TWO)*Q
     *                  -EXP(-AP)*(AP*AP*AP*AP/TWO)*QN
                END IF
C         DAMP0=SCR1
         DAMP1=SCR1+ONE/THREE*SCR2
         DAMP2=SCREEN1
         DAMP3=SCREEN1+ONE/15.0D+00*SCREEN2
         END IF
      END IF
      END IF
C
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
C      DUM = 2.0D+00*Q2/R5
C      DUM7 = 5.0D+00*Q2/R7/3.0D+00
      DUM = 2.0D+00/R5
C      DUM7 = 5.0D+00/R7/3.0D+00
      DUM7 = 1.0D+00/R7
      CFXX = (5.0D+00*XX*DAMP3-R2*DAMP2)*DUM7
      CFYY = (5.0D+00*YY*DAMP3-R2*DAMP2)*DUM7
      CFZZ = (5.0D+00*ZZ*DAMP3-R2*DAMP2)*DUM7
      CFXY =  5.0D+00*XY*DAMP3*DUM7
      CFXZ =  5.0D+00*XZ*DAMP3*DUM7
      CFYZ =  5.0D+00*YZ*DAMP3*DUM7
C
      TMX = (XX1*X+XY1*Y+XZ1*Z)*DAMP1*DUM
      TMY = (XY1*X+YY1*Y+YZ1*Z)*DAMP1*DUM
      TMZ = (XZ1*X+YZ1*Y+ZZ1*Z)*DAMP1*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
C                 WRITE(6,*)'IC1,IC2,TMX,TERM',IC1,IC2,TMX,TERM
C                 WRITE(6,*)'CFXX',CFXX/Q2,CFYY/Q2,CFZZ/Q2,CFXY/Q2,
C     *                   CFXZ/Q2,CFYZ/Q2
             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)             )
         IF (IM.EQ.1) THEN
         CQX1 = CQX1 + (Y*TMZ - Z*TMY)
         ELSE
         CQX2 = CQX2 + (Y*TMZ - Z*TMY)
         END IF
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'CQX1,CQX2',CQX1,CQX2
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      TMP1(I) = DESFRG(I,2)-TMP1(I)
      END DO
      WRITE(6,*)'TMPCQ1',TMP
      WRITE(6,*)'TMPCQ2',TMP1
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
      DIMENSION TMP(6),TMP1(6)
C
      DOUBLE PRECISION  MD
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 /EFPAR / LOCNFG,NLOW,NUP
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      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
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      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
      COX1 = ZERO
      COX2 = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      TMP1(I) = DESFRG(I,2)
      END DO
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 IPX = 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)             )
       IF (IM.EQ.1) THEN
       COX1 = COX1 + (Y*TMZ1 - Z*TMY1)
       ELSE
       COX2 = COX2 + (Y*TMZ1 - Z*TMY1)
       END IF
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'COX1,COX2',COX1,COX2
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      TMP1(I) = DESFRG(I,2)-TMP1(I)
      END DO
      WRITE(6,*)'TMPCO1',TMP
      WRITE(6,*)'TMPCO2',TMP1
      RETURN
      END
C
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
      DIMENSION TMP(6),TMP1(6)
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 /EFPAR / LOCNFG,NLOW,NUP
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /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/,D105/105.0D+00/
      DATA THREE,FIVE,SIX,SEVEN/3.0D+00,5.0D+00,6.0D+00,7.0D+00/
      DATA ZERO,ONE/0.0D+00,1.0D+00/
      DATA ELEVEN/11.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
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      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
      DQX1Q = ZERO
      DQX2Q = ZERO
      DQX1D = ZERO
      DQX2D = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      TMP1(I) = DESFRG(I,2)
      END DO
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 IPX = 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  ---- ORIGINAL CODE, MADE IMPOSSIBLE BY AN IF STATEMENT,
C       KEPT FOR DEBUG PURPOSES
C
      IF (RUNTYP.EQ.0.0D+00) THEN
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
      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)
             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
C
C               WRITE(IW,*) 'TORQ_ORIG:',TORQX1,TORQY1,TORQZ1
C
C
      ELSE
C   ----  NEW CODE FOR CHARGE-PENETRATION
C
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                     P1_E = ZERO
                     P1D_E = ZERO
                     P2_E = ZERO
                     P3_E = ZERO
                     P4 = ZERO
                     P5 = ZERO
                     P6 = ZERO
C
                  IF(ICHGP.EQ.3) THEN
C                  IF(1.EQ.0) THEN
                     ALPHAB = EFATRM2(IC2)
                     ALPHAA = EFATRM2(IC1)
                     BETAA = EFBTRM2(IC1)
C
C  ----  IF DO FRAGMENT-FGARMENT SCREENING
                    IF(R.LE.ELEVEN.AND.BETAA.NE.ZERO) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3_E,P3_N1,P3_N2)
                    CALL EPENP4(AP,BP,AA2,AB2,DIFF,R2,P4)
                    CALL EPENP5(AP,BP,AA2,AB2,DIFF,R7,P5)
                    CALL EPENP6(AP,BP,AA2,AB2,DIFF,R9,P6)
                    END IF
                 END IF
C
C   ----  T_AB TENSOR
C               TXX = (THREE*XX-R2)/R5
C               TYY = (THREE*YY-R2)/R5
C               TZZ = (THREE*ZZ-R2)/R5
               TXX = (THREE*XX)/R5
               TYY = (THREE*YY)/R5
               TZZ = (THREE*ZZ)/R5
               TXY = THREE*XY/R5
               TXZ = THREE*XZ/R5
               TYZ = THREE*YZ/R5
C
C   ----  S_AB TENSOR (DIMINISHED T_ABC TENSOR)
C               SXX = -(FIFTEN*XX-THREE*R2)/R7
C               SYY = -(FIFTEN*YY-THREE*R2)/R7
C               SZZ = -(FIFTEN*ZZ-THREE*R2)/R7
               SXX = -(FIFTEN*XX)/R7
               SYY = -(FIFTEN*YY)/R7
               SZZ = -(FIFTEN*ZZ)/R7
               SXY = -FIFTEN*XY/R7
               SXZ = -FIFTEN*XZ/R7
               SYZ = -FIFTEN*YZ/R7
C
C   ----  U_AB TENSOR (DIMINISHED T_ABCD TENSOR)
C               UXX = (D105*XX-FIFTEN*R2)/R9
C               UYY = (D105*YY-FIFTEN*R2)/R9
C               UZZ = (D105*ZZ-FIFTEN*R2)/R9
               UXX = (D105*XX)/R9
               UYY = (D105*YY)/R9
               UZZ = (D105*ZZ)/R9
               UXY = D105*XY/R9
               UXZ = D105*XZ/R9
               UYZ = D105*YZ/R9
C
C   ----  V_AB TENSOR (INTERMEDIATE)
               VXX = (ONE+P1_E)*UXX + TWO*P1D_E*SXX + P4*TXX + P6*XX
               VYY = (ONE+P1_E)*UYY + TWO*P1D_E*SYY + P4*TYY + P6*YY
               VZZ = (ONE+P1_E)*UZZ + TWO*P1D_E*SZZ + P4*TZZ + P6*ZZ
               VXY = (ONE+P1_E)*UXY + TWO*P1D_E*SXY + P4*TXY + P6*XY
               VXZ = (ONE+P1_E)*UXZ + TWO*P1D_E*SXZ + P4*TXZ + P6*XZ
               VYZ = (ONE+P1_E)*UYZ + TWO*P1D_E*SYZ + P4*TYZ + P6*YZ
C
C   ----  W_AB TENSOR (INTERMEDIATE)
               WXX = (ONE+P1_E)*SXX + P1D_E*TXX + P3_E*XX
               WYY = (ONE+P1_E)*SYY + P1D_E*TYY + P3_E*YY
               WZZ = (ONE+P1_E)*SZZ + P1D_E*TZZ + P3_E*ZZ
               WXY = (ONE+P1_E)*SXY + P1D_E*TXY + P3_E*XY
               WXZ = (ONE+P1_E)*SXZ + P1D_E*TXZ + P3_E*XZ
               WYZ = (ONE+P1_E)*SYZ + P1D_E*TYZ + P3_E*YZ
C
C   ---- CH-PEN INTERMEDIATES
               PY = TWO*((ONE+P1_E)*(-FIFTEN/R7)+P1D_E*THREE/R5+P3_E)
               PZ = TWO*((ONE+P1_E)*THREE/R5 + P2_E)
C
C   ---- R_A*QUAD_AX PRODUCT
               QUAX1 = X*XX1+Y*XY1+Z*XZ1
               QUAY1 = Y*YY1+X*XY1+Z*YZ1
               QUAZ1 = Z*ZZ1+X*XZ1+Y*YZ1
C
C   ---- MU_A*QUAD_AX PRODUCTS
               QUADX1 = DX2*XX1+DY2*XY1+DZ2*XZ1
               QUADY1 = DY2*YY1+DX2*XY1+DZ2*YZ1
               QUADZ1 = DZ2*ZZ1+DX2*XZ1+DY2*YZ1
C
C   ---- MU_A*R_B*QUAD_AB PRODUCTS
               DRQUAD2 = XX1*X*DX2 + YY1*Y*DY2 +
     *                 ZZ1*Z*DZ2 + XY1*(X*DY2+Y*DX2)+
     *               XZ1*(X*DZ2+Z*DX2)+YZ1*(Y*DZ2+Z*DY2)
C
C   ---- DONE WITH PREPARATIONAL STUFF,
C   ---- NOW DIFFERENT PARTS OF GRADIENT GO...
               GRAND = DOT*(XX1*VXX + YY1*VYY + ZZ1*VZZ +
     *                    TWO*(XY1*VXY + XZ1*VXZ + YZ1*VYZ))
C
               BIG = (XX1*WXX + YY1*WYY + ZZ1*WZZ +
     *                    TWO*(XY1*WXY + XZ1*WXZ + YZ1*WYZ))
C
               DQ2X = DOT*PY*QUAX1 + PZ*QUADX1 + BIG*DX2
               DQ2Y = DOT*PY*QUAY1 + PZ*QUADY1 + BIG*DY2
               DQ2Z = DOT*PY*QUAZ1 + PZ*QUADZ1 + BIG*DZ2
C
               TERM = PY*DRQUAD2 + GRAND
C
C  ---- FINAL EXPRESSION FOR FORCE
               CONX = ( DQ2X + X*TERM)/THREE
               CONY = ( DQ2Y + Y*TERM)/THREE
               CONZ = ( DQ2Z + Z*TERM)/THREE
C
C  ---- UFFF ... :)
C  ---- NEED A BIT MORE EFFORT FOR TORQUES
C   ----  F_AB TENSORS (FOR TORQUES DUE TO QUADRUPOLE)
               F2XX = DOT*WXX + PZ*X*DX2
               F2YY = DOT*WYY + PZ*Y*DY2
               F2ZZ = DOT*WZZ + PZ*Z*DZ2
               F2XY = DOT*WXY + PZ*PT5*(X*DY2+Y*DX2)
               F2XZ = DOT*WXZ + PZ*PT5*(X*DZ2+Z*DX2)
               F2YZ = DOT*WYZ + PZ*PT5*(Y*DZ2+Z*DY2)
C
C   ----  TORQUES ON FRAGMENTS DUE TO QUADRUPOLES
               TORQX = (XZ1*F2XY - XY1*F2XZ +
     *                     YZ1*F2YY - YY1*F2YZ +
     *                     ZZ1*F2YZ - YZ1*F2ZZ)*TWO/THREE
               TORQY = -(XZ1*F2XX - XX1*F2XZ +
     *                   YZ1*F2XY - XY1*F2YZ +
     *                   ZZ1*F2XZ - XZ1*F2ZZ)*TWO/THREE
               TORQZ = -(XX1*F2XY - XY1*F2XX +
     *                   XY1*F2YY - YY1*F2XY +
     *                   XZ1*F2YZ - YZ1*F2XZ)*TWO/THREE
C
C   ----  TORQUES DUE TO DIPOLES
               TDX = -((PZ*QUAZ1+BIG*Z)*DY2-(PZ*QUAY1+BIG*Y)*DZ2)/THREE
               TDY = -((PZ*QUAX1+BIG*X)*DZ2-(PZ*QUAZ1+BIG*Z)*DX2)/THREE
               TDZ = -((PZ*QUAY1+BIG*Y)*DX2-(PZ*QUAX1+BIG*X)*DY2)/THREE
C
C               WRITE(IW,*) 'TORQ:   ',TORQX,TORQY,TORQZ
C
      END IF
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))
     *                      +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       )
        IF (IM.EQ.1) THEN
        DQX1Q = DQX1Q + TORQX
        DQX1D = DQX1D + TDX
        ELSE
        DQX2Q = DQX2Q + TORQX
        DQX2D = DQX2D + TDX
        END IF
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'DQX1Q,DQX1D,DQX2Q,DQX2D',DQX1Q,DQX1D,DQX2Q,DQX2D
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      TMP1(I) = DESFRG(I,2)-TMP1(I)
      END DO
      WRITE(6,*)'TMPDQ1',TMP
      WRITE(6,*)'TMPDQ2',TMP1
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
      DIMENSION TMP(6),TMP1(6)
C
      DOUBLE PRECISION  MD
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 /EFPAR / LOCNFG,NLOW,NUP
      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,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA MD         /8HMD      /
      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
      BOXL  = 1.0D+00
      BOXLI = 1.0D+00
      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
      QQX1I = ZERO
      QQX2I  = ZERO
      QQX1J = ZERO
      QQX2J  = ZERO
      DO I=1,6
      TMP(I) = DESFRG(I,1)
      TMP1(I) = DESFRG(I,2)
      END DO
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 IPX = 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
             CONX = (X*(DQU1+DQU2-DQU3)-DQU2X+DQU3X)/NINE
             CONY = (Y*(DQU1+DQU2-DQU3)-DQU2Y+DQU3Y)/NINE
             CONZ = (Z*(DQU1+DQU2-DQU3)-DQU2Z+DQU3Z)/NINE
C        WRITE(6,*)'IC1,IC2,DQU1,DQU2,DQU3,DQU2X,DQU3X',
C     *            IC1,IC2,DQU1,DQU2,DQU3,DQU2X,DQU3X
             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       )
         IF(IM.EQ.1) THEN
         QQX1I = QQX1I + TORQIX
         QQX1J = QQX1J + TORQJX
         ELSE
         QQX2I = QQX2I + TORQJX
         QQX2J = QQX2J + TORQIX
         END IF
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
        WRITE(6,*)'QQX1I,QQX2I,QQX1J,QQX2J',QQX1I,QQX2I,QQX1J,QQX2J
      DO I=1,6
      TMP(I) = DESFRG(I,1)-TMP(I)
      TMP1(I) = DESFRG(I,2)-TMP1(I)
      END DO
      WRITE(6,*)'TMPQQ1',TMP
      WRITE(6,*)'TMPQQ2',TMP1
C
      RETURN
      END
C*MODULE EFELEC  *DECK DCHIND
      SUBROUTINE DCHIND(DIP1,DIP2,DFRG,IFMO)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL IFEWLD,TNFOIL,EWLDPL
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION DIP1(3,*), DIP2(3,*),DFRG(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 /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ,MXFGPT),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      COMMON /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,LSTMPTS(MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      COMMON /SCRPAR/ SCROFF
      COMMON /EWALD / IFEWLD,TNFOIL,BETA,ELCNST,EPSLN,CUTOFF,CUTLST,
     *                KMAX,NKVEC,LEVEL,EWLDPL
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/
      PI=4*ATAN(1.0D+00)
C
      IC1=0
      ISCR = INT(ICHGP/2.0D+00)
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
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            IF (IFMO .NE. 1) THEN
               DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
               DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
               DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            ELSE
               DX1 = PT5*(DIP1(1,IC1)+DIP2(1,IC1))
               DY1 = PT5*(DIP1(2,IC1)+DIP2(2,IC1))
               DZ1 = PT5*(DIP1(3,IC1)+DIP2(3,IC1))
            END IF
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF = 1.0D+00
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
C   ----- DO NOT USE SWITCHING FUNCTIONS IF EWALD SUMS ARE ON
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) GOTO 111
                 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
  111          CONTINUE             
               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)
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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)
                  Q_E = EFCHG(1,IC2)
                  Q_N = EFCHG(2,IC2)
C
C  ---- INFORMATION ABOUT ELECTROSTATIC & POLARIZATION SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
              P1_E = ZERO
              P1_N2 = ZERO
              P1D_E = ZERO
              P1D_N2 = ZERO
              P2_E = ZERO
              P2_N2 = ZERO
C
C  ----  AB INITIO-FRAGMENT SCREENING
                  IF(ISCR.EQ.1) THEN
                     EX = EFATRM2(IC2)
                     CF = EFBTRM2(IC2)
                  ELSE
                     EX = ZERO
                     CF = ZERO
                     IF(IPLSCR.EQ.1 .AND. ISCR.EQ.3
     *                      .AND. INDSCR.EQ.0) THEN
C                       IF(1.EQ.0) THEN
C
C  ----  IF DO FRAGMENT-FGARMENT SCREENING
C  ----  FRAGMENT-FRAGMENT SCREENING
                        ALPHAB = EFATRM2(IC2)
                        ALPHAA = POLSCR(IC1)
                              IF(R.LE.SCROFF) THEN
                                 AP=ALPHAA*R
                                 BP=ALPHAB*R
                                 AA2=ALPHAA*ALPHAA
                                 AB2=ALPHAB*ALPHAB
                                 DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                                  P2_E =  -P1D_E/R3
                                  P2_N2 = -P1D_N2/R3
                              END IF
                     END IF
                  END IF
C
C--------   SCREENING FUNCTIONS FOR EWALD DIRECT TERMS
                 F0 = ONE
                 F1 = ONE
                 F2 = ZERO
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) THEN
                    F0 = ERFC(BETA*R)
                    EXPBR = EXP(-BETA*BETA*R2)
                    F1 = TWO*BETA*R/SQRT(PI)*EXPBR + F0
                    F2 =4.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR/R2
                  END IF

C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
      DUM = Q2/R3
      DOT = DX1*X + DY1*Y + DZ1*Z
      IF(ISCR.EQ.1) THEN
         EX2=EXP(-EX*R2)
C         SCREEN=1.0D+00-CF*EX2
         SCREEN=F1-CF*EX2
         CFR =  DUM*SCREEN - TWO*Q2*CF*EX*EX2/R
         CN1 = (THREE*SCREEN/R5+F2-FOUR*CF*EX*EX2*(ONE/R3+EX/R))*DOT*Q2
      ELSE
         CFR = (Q2*F1 + P1_E*Q_E+P1_N2*Q_N)/R3
         CN1 = (THREE/R5)*DOT*(Q2*F1 + Q_E*(P1_E+ONE/THREE*R5*(P2_E+F2))
     *       +  Q_N*(P1_N2+ONE/THREE*R5*(P2_N2+F2)))
      END IF
C
      CONX = DX1*CFR - X*CN1
      CONY = DY1*CFR - Y*CN1
      CONZ = DZ1*CFR - Z*CN1
C
      IF (IFMO .NE. 1) THEN
             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)             )
      ELSE
             DFRG(1,JM) = DFRG(1,JM) + SWF*CONX
             DFRG(2,JM) = DFRG(2,JM) + SWF*CONY
             DFRG(3,JM) = DFRG(3,JM) + SWF*CONZ
             DFRG(4,JM) = DFRG(4,JM) + SWF*
     *                    (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                    -CONY*(EFC(3,IC2)-EFCENT(3,JM)))
             DFRG(5,JM) = DFRG(5,JM) + SWF*
     *                    (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                    -CONZ*(EFC(1,IC2)-EFCENT(1,JM)))
             DFRG(6,JM) = DFRG(6,JM) + SWF*
     *                    (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                    -CONX*(EFC(2,IC2)-EFCENT(2,JM)))
             DFRG(1,IM) = DFRG(1,IM) - SWF*CONX
             DFRG(2,IM) = DFRG(2,IM) - SWF*CONY
             DFRG(3,IM) = DFRG(3,IM) - SWF*CONZ
             DFRG(4,IM) = DFRG(4,IM) - SWF*
     *                    (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                    -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                    +CFR*(DY1*Z-DZ1*Y)             )
             DFRG(5,IM) = DFRG(5,IM) - SWF*
     *                    (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                    -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                    +CFR*(DZ1*X-DX1*Z)             )
             DFRG(6,IM) = DFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +CFR*(DX1*Y-DY1*X)             )
      END IF
C
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DININ
      SUBROUTINE DININ(DIP1,DIP2,DFRG,IFMO)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL IFEWLD,TNFOIL,EWLDPL
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 POLNAM,DPOLNAM
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION DIP1(3,*), DIP2(3,*),DFRG(6,*)
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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SCRPAR/ SCROFF
      COMMON /EWALD / IFEWLD,TNFOIL,BETA,ELCNST,EPSLN,CUTOFF,CUTLST,
     *                KMAX,NKVEC,LEVEL,EWLDPL
C
      DATA FIFTEN/15.0D+00/, THREE/3.0D+00/, ZERO/0.0D+00/
      DATA FIVE/5.0D+00/, ONE/1.0D+00/, TWO/2.0D+00/, PT5/0.5D+00/
      PI=4*ATAN(1.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
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            IF (IFMO .NE. 1) THEN
               DX1 = 0.50D+00*DIND(1,IC1)
               DY1 = 0.50D+00*DIND(2,IC1)
               DZ1 = 0.50D+00*DIND(3,IC1)
            ELSE
               DX1 = 0.50D+00*DIP1(1,IC1)
               DY1 = 0.50D+00*DIP1(2,IC1)
               DZ1 = 0.50D+00*DIP1(3,IC1)
            END IF
            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
               COMX2 = EFCENT(1,JM) 
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF = 1.0D+00
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NPPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) GOTO 111
                 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
  111          CONTINUE
               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)
                  DX2 = DINDD(1,IC2)
                  DY2 = DINDD(2,IC2)
                  DZ2 = DINDD(3,IC2)
                  IF (IFMO .NE. 1) THEN
                     DX2 = DINDD(1,IC2)
                     DY2 = DINDD(2,IC2)
                     DZ2 = DINDD(3,IC2)
                  ELSE
                     DX2 = DIP2(1,IC2)
                     DY2 = DIP2(2,IC2)
                     DZ2 = DIP2(3,IC2)
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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
C  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                     P1_E = ZERO
                     P1D_E = ZERO
                     P2_E = ZERO
                     P3_E = ZERO
C
                  IF(IPLSCR .EQ. 1) THEN
C                  IF(1.EQ.0) THEN
                     ALPHAB = POLSCR(IC2)
                     ALPHAA = POLSCR(IC1)
C
C  ----  IF DO FRAGMENT-FGARMENT SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3_E,P3_N1,P3_N2)
C    ---- LVS: DIFFERENT VARIANTS OF SCREENING
C                    CALL SCR5CHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
C                    CALL SCR5CHQU(AP,BP,AA2,AB2,DIFF,R2,
C     *                            P1D_E,P1D_N1,P1D_N2)
C                    P2_E =  -P1D_E/R3
C                    CALL SCR5CHOCT(AP,BP,AA2,AB2,DIFF,R7,
C     *                             P3_E,P3_N1,P3_N2)
                    END IF
                 END IF
C
C--------   SCREENING FUNCTIONS FOR EWALD DIRECT TERMS
                 F0 = ONE
                 F1 = ONE
                 F2 = ZERO
                 F3 = ZERO
                 F4 = ZERO
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) THEN
                    F0 = ERFC(BETA*R)
                    EXPBR = EXP(-BETA*BETA*R2)
                    F1 = TWO*BETA*R/SQRT(PI)*EXPBR + F0
                    F2 =4.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR/R2
                    F3 = R3*F2
                    F4 = 8.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR*
     *                       (BETA*BETA*R2+ONE)/(R2*R2)
                 END IF
C
C   ---- OLD CODE WITHOUT SCREENING
                  DOT1 = DX1*X + DY1*Y + DZ1*Z
                  DOT2 = DX2*X + DY2*Y + DZ2*Z
C
                  IF(IPLSCR .NE. 1 .AND. 
     *             .NOT.(IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL)) THEN
                  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                 WRITE(IW,*) 'CON: ',CONX,CONY,CONZ
C
C  ----   CODE WITH SCREENING FOR DIPOLE-DIPOLE GRADIENTS
                  ELSE
C   ----  T_AB TENSOR
               TXX = (THREE*X*X-R2)/R5
               TYY = (THREE*Y*Y-R2)/R5
               TZZ = (THREE*Z*Z-R2)/R5
               TXY = THREE*X*Y/R5
               TXZ = THREE*X*Z/R5
               TYZ = THREE*Y*Z/R5
C
               DDDXX = (F1+P1_E)*THREE*(-FIVE*X*X+R2)/R7+(P1D_E-F3)*TXX       
     *                    + (P3_E-F4)*X*X
               DDDYY = (F1+P1_E)*THREE*(-FIVE*Y*Y+R2)/R7+(P1D_E-F3)*TYY
     *                    + (P3_E-F4)*Y*Y
               DDDZZ = (F1+P1_E)*THREE*(-FIVE*Z*Z+R2)/R7+(P1D_E-F3)*TZZ
     *                    + (P3_E-F4)*Z*Z
               DDDXY = (F1+P1_E)*THREE*(-FIVE*X*Y)/R7+(P1D_E-F3)*TXY
     *                    + (P3_E-F4)*X*Y
               DDDXZ = (F1+P1_E)*THREE*(-FIVE*X*Z)/R7+(P1D_E-F3)*TXZ
     *                    + (P3_E-F4)*X*Z
               DDDYZ = (F1+P1_E)*THREE*(-FIVE*Y*Z)/R7 +(P1D_E-F3)*TYZ
     *                    + (P3_E-F4)*Y*Z
C
               CHPDDE = TWO*((F1+P1_E)*THREE/R5+F2+P2_E)
C
               DMX = CHPDDE*(DX1*DX2*X+PT5*(DX1*DY2+
     *                 DY1*DX2)*Y+PT5*(DX1*DZ2+DZ1*DX2)*Z)
               DMY = CHPDDE*(DY1*DY2*Y+PT5*(DX1*DY2+
     *                 DY1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Z)
               DMZ = CHPDDE*(DZ1*DZ2*Z+PT5*(DX1*DZ2+
     *                 DZ1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Y)
C
               DDD = DX1*DX2*DDDXX + DY1*DY2*DDDYY+
     *                DZ1*DZ2*DDDZZ +
     *               (DX1*DY2+DY1*DX2)*DDDXY +
     *               (DX1*DZ2+DZ1*DX2)*DDDXZ +
     *               (DY1*DZ2+DZ1*DY2)*DDDYZ
C
               CONX = (DMX + DDD*X)
               CONY = (DMY + DDD*Y)
               CONZ = (DMZ + DDD*Z)
C
C  --- THIS IS LIKE DIPOLE-DIPOLE ENERGY TERMS
               DUM1 = DOT1*THREE/R5
               DUM2 = DOT2*THREE/R5
               DFX1 = (-DX1/R3+X*DUM1)*(F1+P1_E) + X*DOT1*(F2+P2_E)
               DFY1 = (-DY1/R3+Y*DUM1)*(F1+P1_E) + Y*DOT1*(F2+P2_E)
               DFZ1 = (-DZ1/R3+Z*DUM1)*(F1+P1_E) + Z*DOT1*(F2+P2_E)
               DFX2 = (-DX2/R3+X*DUM2)*(F1+P1_E) + X*DOT2*(F2+P2_E)
               DFY2 = (-DY2/R3+Y*DUM2)*(F1+P1_E) + Y*DOT2*(F2+P2_E)
               DFZ2 = (-DZ2/R3+Z*DUM2)*(F1+P1_E) + Z*DOT2*(F2+P2_E)
                 END IF
C
          IF (IFMO .NE. 1) THEN
             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)       )
          ELSE
             DFRG(1,JM) = DFRG(1,JM) + SWF*CONX
             DFRG(2,JM) = DFRG(2,JM) + SWF*CONY
             DFRG(3,JM) = DFRG(3,JM) + SWF*CONZ
             DFRG(4,JM) = DFRG(4,JM) + SWF*
     *                      (CONZ*(EFP(2,IC2)-EFCENT(2,JM))
     *                      -CONY*(EFP(3,IC2)-EFCENT(3,JM))
     *                      -(DY2*DFZ1-DZ2*DFY1)       )
             DFRG(5,JM) = DFRG(5,JM) + SWF*
     *                    (CONX*(EFP(3,IC2)-EFCENT(3,JM))
     *                    -CONZ*(EFP(1,IC2)-EFCENT(1,JM))
     *                    -(DZ2*DFX1-DX2*DFZ1)       )
             DFRG(6,JM) = DFRG(6,JM) + SWF*
     *                    (CONY*(EFP(1,IC2)-EFCENT(1,JM))
     *                    -CONX*(EFP(2,IC2)-EFCENT(2,JM))
     *                    -(DX2*DFY1-DY2*DFX1)       )
             DFRG(1,IM) = DFRG(1,IM) - SWF*CONX
             DFRG(2,IM) = DFRG(2,IM) - SWF*CONY
             DFRG(3,IM) = DFRG(3,IM) - SWF*CONZ
             DFRG(4,IM) = DFRG(4,IM) - SWF*
     *                    (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                    -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                    +(DY1*DFZ2-DZ1*DFY2)       )
             DFRG(5,IM) = DFRG(5,IM) - SWF*
     *                    (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                    -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                    +(DZ1*DFX2-DX1*DFZ2)       )
             DFRG(6,IM) = DFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +(DX1*DFY2-DY1*DFX2)       )
         END IF
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) .AND.
     *   IFMO .NE. 1 ) THEN
         CALL INDQUA     
         IF(.NOT.(IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL)) THEN
            CALL INDCHG
            CALL INDDPL
            CALL INDIND
         END IF
      END IF
C
      RETURN
      END
C*MODULE EFELEC  *DECK DDPIND
      SUBROUTINE DDPIND(DIP1,DIP2,DFRG,IFMO)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL IFEWLD,TNFOIL,EWLDPL
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
C
      PARAMETER (MXFRG=1050, MXFGPT=12000, MXIFRQ=12,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
      DIMENSION DIP1(3,*), DIP2(3,*),DFRG(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 /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ,MXFGPT),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      COMMON /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,LSTMPTS(MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      COMMON /SCRPAR/ SCROFF
      COMMON /EWALD / IFEWLD,TNFOIL,BETA,ELCNST,EPSLN,CUTOFF,CUTLST,
     *                KMAX,NKVEC,LEVEL,EWLDPL
C
      DATA THREE/3.0D+00/, ZERO/0.0D+00/
      DATA ONE/1.0D+00/, TWO/2.0D+00/, FIVE/5.0D+00/
      DATA PT5/0.5D+00/
      PI=4*ATAN(1.0D+00)
C
      IC1=0
      ISCR = INT(ICHGP/2.0D+00)
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
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 1,NPPTS(IM)
            IC1=IC1+1
            X1 = EFP(1,IC1)
            Y1 = EFP(2,IC1)
            Z1 = EFP(3,IC1)
            IF (IFMO .NE. 1) THEN
               DX1 = PT5*(DIND(1,IC1)+DINDD(1,IC1))
               DY1 = PT5*(DIND(2,IC1)+DINDD(2,IC1))
               DZ1 = PT5*(DIND(3,IC1)+DINDD(3,IC1))
            ELSE
               DX1 = PT5*(DIP1(1,IC1)+DIP2(1,IC1))
               DY1 = PT5*(DIP1(2,IC1)+DIP2(2,IC1))
               DZ1 = PT5*(DIP1(3,IC1)+DIP2(3,IC1))
            END IF
            IC2=0
            DO 380 JM = 1,NFRG
               IF (IM.EQ.JM) THEN
                 IC2=IC2+NMPTS(JM)
                 GO TO 380
               END IF
C
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF = 1.0D+00
               IF(R12.GT.SWR2*SWR2) THEN
                 IC2=IC2+NMPTS(JM)
                 GOTO 380
               ELSE IF(R12.GT.SWR1*SWR1) THEN
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) GOTO 111
                 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
  111          CONTINUE
               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)
                  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
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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
C  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                     P1_E = ZERO
                     P1D_E = ZERO
                     P2_E = ZERO
                     P3_E = ZERO
C
                  IF(ISCR.EQ.3 .AND.IPLSCR .EQ. 1
     *                 .AND. INDSCR.EQ.0) THEN
C                  IF(1.EQ.0) THEN
                     ALPHAB = EFATRM2(IC2)
                     ALPHAA = POLSCR(IC1)
C
C  ----  IF DO FRAGMENT-FGARMENT SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3_E,P3_N1,P3_N2)
                    END IF
                 END IF
C
C--------   SCREENING FUNCTIONS FOR EWALD DIRECT TERMS
                 F0 = ONE
                 F1 = ONE
                 F2 = ZERO
                 F3 = ZERO
                 F4 = ZERO
                 IF (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL) THEN
                    F0 = ERFC(BETA*R)
                    EXPBR = EXP(-BETA*BETA*R2)
                    F1 = TWO*BETA*R/SQRT(PI)*EXPBR + F0
                    F2 =4.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR/R2
                    F3 = R3*F2
                    F4 = 8.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR*
     *                       (BETA*BETA*R2+ONE)/(R2*R2)
                 END IF
C
C   ---- CODE WITHOUT SCREENING
                  DOT1 = DX1*X + DY1*Y + DZ1*Z
                  DOT2 = DX2*X + DY2*Y + DZ2*Z
C
                  IF(IPLSCR .NE. 1 .AND. .NOT.
     *               (IFEWLD .AND. LEVEL .GE. 2 .AND. EWLDPL)) THEN
                  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
C  ----   NEW CODE WITH SCREENING FOR DIPOLE-DIPOLE GRADIENTS
                  ELSE
C   ----  T_AB TENSOR
               TXX = (THREE*X*X-R2)/R5
               TYY = (THREE*Y*Y-R2)/R5
               TZZ = (THREE*Z*Z-R2)/R5
               TXY = THREE*X*Y/R5
               TXZ = THREE*X*Z/R5
               TYZ = THREE*Y*Z/R5
C
               DDDXX = (F1+P1_E)*THREE*(-FIVE*X*X+R2)/R7+(P1D_E-F3)*TXX       
     *                    + (P3_E-F4)*X*X
               DDDYY = (F1+P1_E)*THREE*(-FIVE*Y*Y+R2)/R7+(P1D_E-F3)*TYY
     *                    + (P3_E-F4)*Y*Y
               DDDZZ = (F1+P1_E)*THREE*(-FIVE*Z*Z+R2)/R7+(P1D_E-F3)*TZZ
     *                    + (P3_E-F4)*Z*Z
               DDDXY = (F1+P1_E)*THREE*(-FIVE*X*Y)/R7+(P1D_E-F3)*TXY
     *                    + (P3_E-F4)*X*Y
               DDDXZ = (F1+P1_E)*THREE*(-FIVE*X*Z)/R7+(P1D_E-F3)*TXZ
     *                    + (P3_E-F4)*X*Z
               DDDYZ = (F1+P1_E)*THREE*(-FIVE*Y*Z)/R7 +(P1D_E-F3)*TYZ
     *                    + (P3_E-F4)*Y*Z
C
               CHPDDE = TWO*((F1+P1_E)*THREE/R5+F2+P2_E)
C
               DMX = CHPDDE*(DX1*DX2*X+PT5*(DX1*DY2+
     *                 DY1*DX2)*Y+PT5*(DX1*DZ2+DZ1*DX2)*Z)
               DMY = CHPDDE*(DY1*DY2*Y+PT5*(DX1*DY2+
     *                 DY1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Z)
               DMZ = CHPDDE*(DZ1*DZ2*Z+PT5*(DX1*DZ2+
     *                 DZ1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Y)
C
               DDD = DX1*DX2*DDDXX + DY1*DY2*DDDYY+
     *                DZ1*DZ2*DDDZZ +
     *               (DX1*DY2+DY1*DX2)*DDDXY +
     *               (DX1*DZ2+DZ1*DX2)*DDDXZ +
     *               (DY1*DZ2+DZ1*DY2)*DDDYZ
C
               CONX = (DMX + DDD*X)
               CONY = (DMY + DDD*Y)
               CONZ = (DMZ + DDD*Z)
C
C  --- THIS IS LIKE DIPOLE-DIPOLE ENERGY TERMS
               DUM1 = DOT1*THREE/R5
               DUM2 = DOT2*THREE/R5
               DFX1 = (-DX1/R3+X*DUM1)*(F1+P1_E) + X*DOT1*(P2_E+F2)
               DFY1 = (-DY1/R3+Y*DUM1)*(F1+P1_E) + Y*DOT1*(P2_E+F2)
               DFZ1 = (-DZ1/R3+Z*DUM1)*(F1+P1_E) + Z*DOT1*(P2_E+F2)
               DFX2 = (-DX2/R3+X*DUM2)*(F1+P1_E) + X*DOT2*(P2_E+F2)
               DFY2 = (-DY2/R3+Y*DUM2)*(F1+P1_E) + Y*DOT2*(P2_E+F2)
               DFZ2 = (-DZ2/R3+Z*DUM2)*(F1+P1_E) + Z*DOT2*(P2_E+F2)
               END IF
C
            IF (IFMO .NE. 1) THEN
             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)       )
             ELSE
             DFRG(1,JM) = DFRG(1,JM) + SWF*CONX
             DFRG(2,JM) = DFRG(2,JM) + SWF*CONY
             DFRG(3,JM) = DFRG(3,JM) + SWF*CONZ
             DFRG(4,JM) = DFRG(4,JM) + SWF*
     *                    (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                    -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                    -(DY2*DFZ1-DZ2*DFY1)       )
             DFRG(5,JM) = DFRG(5,JM) + SWF*
     *                    (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                    -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                    -(DZ2*DFX1-DX2*DFZ1)       )
             DFRG(6,JM) = DFRG(6,JM) + SWF*
     *                    (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                    -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                    -(DX2*DFY1-DY2*DFX1)       )
             DFRG(1,IM) = DFRG(1,IM) - SWF*CONX
             DFRG(2,IM) = DFRG(2,IM) - SWF*CONY
             DFRG(3,IM) = DFRG(3,IM) - SWF*CONZ
             DFRG(4,IM) = DFRG(4,IM) - SWF*
     *                    (CONZ*(EFP(2,IC1)-EFCENT(2,IM))
     *                    -CONY*(EFP(3,IC1)-EFCENT(3,IM))
     *                    +(DY1*DFZ2-DZ1*DFY2)       )
             DFRG(5,IM) = DFRG(5,IM) - SWF*
     *                    (CONX*(EFP(3,IC1)-EFCENT(3,IM))
     *                    -CONZ*(EFP(1,IC1)-EFCENT(1,IM))
     *                    +(DZ1*DFX2-DX1*DFZ2)       )
             DFRG(6,IM) = DFRG(6,IM) - SWF*
     *                      (CONY*(EFP(1,IC1)-EFCENT(1,IM))
     *                      -CONX*(EFP(2,IC1)-EFCENT(2,IM))
     *                      +(DX1*DFY2-DY1*DFX2)       )
             END IF
C
  370          CONTINUE
  380       CONTINUE
  390    CONTINUE
  400 CONTINUE
C
      RETURN
      END
C*MODULE EFELEC  *DECK DQDIND
      SUBROUTINE DQDIND(QUA,DIP1,DIP2,DFRG,IFMO)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      CHARACTER*8 FRGNME,POLNAM,DPOLNAM
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,*)
      DIMENSION DIP1(3,*), DIP2(3,*),DFRG(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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SCRPAR/ SCROFF
C
      DATA PT5,ONEPT5,TWO/0.5D+00,1.5D+00,2.0D+00/
      DATA THREE,FIVE,SIX,SEVEN/3.0D+00,5.0D+00,6.0D+00,7.0D+00/
      DATA ZERO/0.0D+00/, ONE/1.0D+00/
      DATA FIFTEN/15.0D+00/,D105/105.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
      ISCR = INT(ICHGP/2.0D+00)
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
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 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
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF = 1.0D+00
               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
               DO 370 JP = 1,NPPTS(JM)
                  IC2=IC2+1
                  X2 = EFP(1,IC2)
                  Y2 = EFP(2,IC2)
                  Z2 = EFP(3,IC2)
                  IF (IFMO .NE. 1) THEN
                     DX2 = PT5*(DIND(1,IC2)+DINDD(1,IC2))
                     DY2 = PT5*(DIND(2,IC2)+DINDD(2,IC2))
                     DZ2 = PT5*(DIND(3,IC2)+DINDD(3,IC2))
                  ELSE
                     DX2 = PT5*(DIP1(1,IC2)+DIP2(1,IC2))
                     DY2 = PT5*(DIP1(2,IC2)+DIP2(2,IC2))
                     DZ2 = PT5*(DIP1(3,IC2)+DIP2(3,IC2))
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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
      IF (ISCR.NE.3 .OR. IPLSCR.NE.1 .OR. INDSCR.EQ.1) THEN
      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
      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
             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
C
      ELSE
C   ----  CODE FOR CHARGE-PENETRATION
C
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                     P1_E = ZERO
                     P1D_E = ZERO
                     P2_E = ZERO
                     P3_E = ZERO
                     P4 = ZERO
                     P5 = ZERO
                     P6 = ZERO
C
                     ALPHAB = POLSCR(IC2)
                     ALPHAA = EFATRM2(IC1)
C
C  ----  IF DO FRAGMENT-FGARMENT SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3_E,P3_N1,P3_N2)
                    CALL EPENP4(AP,BP,AA2,AB2,DIFF,R2,P4)
                    CALL EPENP5(AP,BP,AA2,AB2,DIFF,R7,P5)
                    CALL EPENP6(AP,BP,AA2,AB2,DIFF,R9,P6)
                    END IF
C
C   ----  T_AB TENSOR
C               TXX = (THREE*XX-R2)/R5
C               TYY = (THREE*YY-R2)/R5
C               TZZ = (THREE*ZZ-R2)/R5
               TXX = (THREE*XX)/R5
               TYY = (THREE*YY)/R5
               TZZ = (THREE*ZZ)/R5
               TXY = THREE*XY/R5
               TXZ = THREE*XZ/R5
               TYZ = THREE*YZ/R5
C
C   ----  S_AB TENSOR (DIMINISHED T_ABC TENSOR)
C               SXX = -(FIFTEN*XX-THREE*R2)/R7
C               SYY = -(FIFTEN*YY-THREE*R2)/R7
C               SZZ = -(FIFTEN*ZZ-THREE*R2)/R7
               SXX = -(FIFTEN*XX)/R7
               SYY = -(FIFTEN*YY)/R7
               SZZ = -(FIFTEN*ZZ)/R7
               SXY = -FIFTEN*XY/R7
               SXZ = -FIFTEN*XZ/R7
               SYZ = -FIFTEN*YZ/R7
C
C   ----  U_AB TENSOR (DIMINISHED T_ABCD TENSOR)
C               UXX = (D105*XX-FIFTEN*R2)/R9
C               UYY = (D105*YY-FIFTEN*R2)/R9
C               UZZ = (D105*ZZ-FIFTEN*R2)/R9
               UXX = (D105*XX)/R9
               UYY = (D105*YY)/R9
               UZZ = (D105*ZZ)/R9
               UXY = D105*XY/R9
               UXZ = D105*XZ/R9
               UYZ = D105*YZ/R9
C
C   ----  V_AB TENSOR (INTERMEDIATE)
               VXX = (ONE+P1_E)*UXX + TWO*P1D_E*SXX + P4*TXX + P6*XX
               VYY = (ONE+P1_E)*UYY + TWO*P1D_E*SYY + P4*TYY + P6*YY
               VZZ = (ONE+P1_E)*UZZ + TWO*P1D_E*SZZ + P4*TZZ + P6*ZZ
               VXY = (ONE+P1_E)*UXY + TWO*P1D_E*SXY + P4*TXY + P6*XY
               VXZ = (ONE+P1_E)*UXZ + TWO*P1D_E*SXZ + P4*TXZ + P6*XZ
               VYZ = (ONE+P1_E)*UYZ + TWO*P1D_E*SYZ + P4*TYZ + P6*YZ
C
C   ----  W_AB TENSOR (INTERMEDIATE)
               WXX = (ONE+P1_E)*SXX + P1D_E*TXX + P3_E*XX
               WYY = (ONE+P1_E)*SYY + P1D_E*TYY + P3_E*YY
               WZZ = (ONE+P1_E)*SZZ + P1D_E*TZZ + P3_E*ZZ
               WXY = (ONE+P1_E)*SXY + P1D_E*TXY + P3_E*XY
               WXZ = (ONE+P1_E)*SXZ + P1D_E*TXZ + P3_E*XZ
               WYZ = (ONE+P1_E)*SYZ + P1D_E*TYZ + P3_E*YZ
C
C   ---- CH-PEN INTERMEDIATES
               PY = TWO*((ONE+P1_E)*(-FIFTEN/R7)+P1D_E*THREE/R5+P3_E)
               PZ = TWO*((ONE+P1_E)*THREE/R5 + P2_E)
C
C   ---- R_A*QUAD_AX PRODUCT
               QUAX1 = X*XX1+Y*XY1+Z*XZ1
               QUAY1 = Y*YY1+X*XY1+Z*YZ1
               QUAZ1 = Z*ZZ1+X*XZ1+Y*YZ1
C
C   ---- MU_A*QUAD_AX PRODUCTS
               QUADX1 = DX2*XX1+DY2*XY1+DZ2*XZ1
               QUADY1 = DY2*YY1+DX2*XY1+DZ2*YZ1
               QUADZ1 = DZ2*ZZ1+DX2*XZ1+DY2*YZ1
C
C   ---- MU_A*R_B*QUAD_AB PRODUCTS
               DRQUAD2 = XX1*X*DX2 + YY1*Y*DY2 +
     *                 ZZ1*Z*DZ2 + XY1*(X*DY2+Y*DX2)+
     *               XZ1*(X*DZ2+Z*DX2)+YZ1*(Y*DZ2+Z*DY2)
C
C   ---- DONE WITH PREPARATIONAL STUFF,
C   ---- NOW DIFFERENT PARTS OF GRADIENT GO...
               GRAND = DOT*(XX1*VXX + YY1*VYY + ZZ1*VZZ +
     *                    TWO*(XY1*VXY + XZ1*VXZ + YZ1*VYZ))
C
               BIG = (XX1*WXX + YY1*WYY + ZZ1*WZZ +
     *                    TWO*(XY1*WXY + XZ1*WXZ + YZ1*WYZ))
C
               DQ2X = DOT*PY*QUAX1 + PZ*QUADX1 + BIG*DX2
               DQ2Y = DOT*PY*QUAY1 + PZ*QUADY1 + BIG*DY2
               DQ2Z = DOT*PY*QUAZ1 + PZ*QUADZ1 + BIG*DZ2
C
               TERM = PY*DRQUAD2 + GRAND
C
C  ---- FINAL EXPRESSION FOR FORCE
               CONX = ( DQ2X + X*TERM)/THREE
               CONY = ( DQ2Y + Y*TERM)/THREE
               CONZ = ( DQ2Z + Z*TERM)/THREE
C
C  ---- UFFF ... :)
C  ---- NEED A BIT MORE EFFORT FOR TORQUES
C   ----  F_AB TENSORS (FOR TORQUES DUE TO QUADRUPOLE)
               F2XX = DOT*WXX + PZ*X*DX2
               F2YY = DOT*WYY + PZ*Y*DY2
               F2ZZ = DOT*WZZ + PZ*Z*DZ2
               F2XY = DOT*WXY + PZ*PT5*(X*DY2+Y*DX2)
               F2XZ = DOT*WXZ + PZ*PT5*(X*DZ2+Z*DX2)
               F2YZ = DOT*WYZ + PZ*PT5*(Y*DZ2+Z*DY2)
C
C   ----  TORQUES ON FRAGMENTS DUE TO QUADRUPOLES
               TORQX = (XZ1*F2XY - XY1*F2XZ +
     *                     YZ1*F2YY - YY1*F2YZ +
     *                     ZZ1*F2YZ - YZ1*F2ZZ)*TWO/THREE
               TORQY = -(XZ1*F2XX - XX1*F2XZ +
     *                   YZ1*F2XY - XY1*F2YZ +
     *                   ZZ1*F2XZ - XZ1*F2ZZ)*TWO/THREE
               TORQZ = -(XX1*F2XY - XY1*F2XX +
     *                   XY1*F2YY - YY1*F2XY +
     *                   XZ1*F2YZ - YZ1*F2XZ)*TWO/THREE
C
C   ----  TORQUES DUE TO DIPOLES
               TDX = -((PZ*QUAZ1+BIG*Z)*DY2-(PZ*QUAY1+BIG*Y)*DZ2)/THREE
               TDY = -((PZ*QUAX1+BIG*X)*DZ2-(PZ*QUAZ1+BIG*Z)*DX2)/THREE
               TDZ = -((PZ*QUAY1+BIG*Y)*DX2-(PZ*QUAX1+BIG*X)*DY2)/THREE
C
      END IF
C
           IF (IFMO .NE. 1) THEN
             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       )
           ELSE
             DFRG(1,JM) = DFRG(1,JM) + SWF*CONX
             DFRG(2,JM) = DFRG(2,JM) + SWF*CONY
             DFRG(3,JM) = DFRG(3,JM) + SWF*CONZ
             DFRG(4,JM) = DFRG(4,JM) + SWF*
     *                    (CONZ*(EFP(2,IC2)-EFCENT(2,JM))
     *                    -CONY*(EFP(3,IC2)-EFCENT(3,JM))
     *                    +TDX       )
             DFRG(5,JM) = DFRG(5,JM) + SWF*
     *                    (CONX*(EFP(3,IC2)-EFCENT(3,JM))
     *                    -CONZ*(EFP(1,IC2)-EFCENT(1,JM))
     *                    +TDY       )
             DFRG(6,JM) = DFRG(6,JM) + SWF*
     *                    (CONY*(EFP(1,IC2)-EFCENT(1,JM))
     *                    -CONX*(EFP(2,IC2)-EFCENT(2,JM))
     *                    +TDZ       )
             DFRG(1,IM) = DFRG(1,IM) - SWF*CONX
             DFRG(2,IM) = DFRG(2,IM) - SWF*CONY
             DFRG(3,IM) = DFRG(3,IM) - SWF*CONZ
             DFRG(4,IM) = DFRG(4,IM) - SWF*
     *                    (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                    -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                    -TORQX       )
             DFRG(5,IM) = DFRG(5,IM) - SWF*
     *                    (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                    -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                    -TORQY       )
             DFRG(6,IM) = DFRG(6,IM) - SWF*
     *                    (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                    -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                    -TORQZ       )
           END IF
370            CONTINUE
380         CONTINUE
390      CONTINUE
400   CONTINUE
C      IF (MASWRK) WRITE(6,*)'DESFRG-POLAR ',(DESFRG(I,1), I=1,6)      
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
      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,LSTMPTS(MXFRG)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
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
         COMX1 = EFCENT(1,IFRG)
         COMY1 = EFCENT(2,IFRG)
         COMZ1 = EFCENT(3,IFRG)
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
               COMX2 = EFCENT(1,JFRG)
               COMY2 = EFCENT(2,JFRG)
               COMZ2 = EFCENT(3,JFRG)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - PBCX)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - PBCY)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-PBCZ)
                 END IF
               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 + PBCX
          YJ = YJ + PBCY
          ZJ = ZJ + PBCZ
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
      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,LSTMPTS(MXFRG)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
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
         COMX1 = EFCENT(1,IFRG)
         COMY1 = EFCENT(2,IFRG)
         COMZ1 = EFCENT(3,IFRG)
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
               COMX2 = EFCENT(1,JFRG)
               COMY2 = EFCENT(2,JFRG)
               COMZ2 = EFCENT(3,JFRG)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - PBCX)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - PBCY)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF   = 1.0D+00
               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
      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 + PBCX
             YJ = BYJ + PBCY
             ZJ = BZJ + PBCZ
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-XXX-C
C-XXX-C*MODULE EFELEC  *DECK SPCEG_OLD
C-XXX-      SUBROUTINE SPCEG_OLD
C-XXX-C
C-XXX-      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C-XXX-C
C-XXX-      CHARACTER*8 FRGNME
C-XXX-C
C-XXX-      PARAMETER (MXATM=2000, MXPT=2000, MXFRG=1050, MXFGPT=12000,
C-XXX-     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C-XXX-      DIMENSION EF3(3,MXFGPT)
C-XXX-C
C-XXX-      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),
C-XXX-     *                EFATRM(MXFGPT),EFBTRM(MXFGPT),
C-XXX-     *                EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
C-XXX-     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
C-XXX-     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
C-XXX-      COMMON /EFPPBC/ XBOX,YBOX,ZBOX,XCUT,YCUT,ZCUT,RCUT
C-XXX-     *                ,SWR1,SWR2,ISWF
C-XXX-      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
C-XXX-     *                NPPTS(MXFRG),NPTTPT,IEFP,
C-XXX-     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
C-XXX-     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C-XXX-C
C-XXX-      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
C-XXX-     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),
C-XXX-     *                FRGMI(6,MXFRG),ATORQ(3,MXFRG)
C-XXX-      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
C-XXX-     *                FPNUC(MXPT),FGNUC(MXFGPT)
C-XXX-      COMMON /FUNCT / E,EG(3*MXATM)
C-XXX-C
C-XXX-      PARAMETER (ZERO=0.0D+00)
C-XXX-      PARAMETER (ONE=1.00D+00, UNITS=ONE/0.52917724924D+00)
C-XXX-      PARAMETER (FACTOR=ONE/627.510D+00)
C-XXX-C
C-XXX-C
C-XXX-C   HEATHER'S VERSION OF SPCEG, KEEP FOR A WHILE
C-XXX-C
C-XXX-C EPSILON UNITS = KCAL/MOL * FACTOR = AU
C-XXX-C SIGMA UNITS = ANG. * FACTOR = BOHR
C-XXX-C
C-XXX-C      FACTOR2 = UNITS/FACTOR
C-XXX-C      EPSILON = ZERO
C-XXX-      EPSILON = 0.155394444D+00*FACTOR
C-XXX-      EPSILON4 = 4.0D+00*EPSILON
C-XXX-      SIGMA = 3.16555725812893D+00*UNITS
C-XXX-      SIGMASQ = SIGMA*SIGMA
C-XXX-      IF (SWR2 .LT. 1.0D+06 .AND. SWR2 .LT. 1.0D+06) THEN
C-XXX-         RUPPER = SWR2
C-XXX-         RLOWER = SWR1       
C-XXX-      ELSE 
C-XXX-         RUPPER = 5.5D+00*UNITS
C-XXX-         RLOWER = 5.0D+00*UNITS
C-XXX-      END IF
C-XXX-      RUPPER2 = RUPPER*RUPPER
C-XXX-C      RLOWER2 = RLOWER*RLOWER
C-XXX-C
C-XXX-CC FOLLOWING ARE COEFF. OF POLYN. IN Z (=R**2-RLOWER**2)
C-XXX-C THAT DESCRIBES THE POTENTIAL SWITCHING FUNCTION IN THE RANNGE
C-XXX-C FROM Z=0 (R=RLOWER) TO Z=RUPPER**2-RLOWER**2. FOR R LESS THAN
C-XXX-C RLOWER, THE SWITCH FUNCTION IS ONE; FOR R GREATER THAN RUPPER
C-XXX-C THE SWITCH FUNCTION IS ZERO.
C-XXX-C T.A. ANDREA, W.C. SWOPE, H.C. ANDERSON,
C-XXX-C J.CHEM.PHYS. 79,4576(1983).
C-XXX-C
C-XXX-C S(Z) = 1+A*(Z**3)+B*(Z**4)+C*(Z**5)
C-XXX-C WITH A=-10/D**3,  B=15/D**4,   C=-6/D**5
C-XXX-C AND D=RUPPER**2-RLOWER**2
C-XXX-C
C-XXX-C THIS FUNCTION IS MEANT TO BE USED FOR Z IN THE RANGE FROM 0 TO D
C-XXX-C AND IS CONTINUOUS AND HAS TWO CONTINUOUS DERIVATIVES AT THE
C-XXX-C ENDPOINTS OF THIS INTERVAL.
C-XXX-C
C-XXX-      IF(RUPPER.GT.RLOWER) THEN
C-XXX-       DS = RUPPER**2 - RLOWER**2
C-XXX-       AS = -10.0D+00/DS**3
C-XXX-       BS = 15.0D+00/DS**4
C-XXX-       CS = -6.0D+00/DS**5
C-XXX-      ELSE
C-XXX-C
C-XXX-C TAKE THIS SITUATION TO MEAN A SHARP CUTOFF AT RUPPER
C-XXX-C
C-XXX-       AS=0.0D+00
C-XXX-       BS=0.0D+00
C-XXX-       CS=0.0D+00
C-XXX-      ENDIF
C-XXX-C
C-XXX-      ULJ = ZERO
C-XXX-      UCOUL = ZERO
C-XXX-      CALL VCLR(EF3,1,3*MXFGPT)
C-XXX-      CALL VCLR(DEF,1,3*MXFGPT)
C-XXX-C
C-XXX-      ICI=0
C-XXX-      KMASS=0
C-XXX-      DO 280 IM = 1,NFRG-1
C-XXX-          COMX1 = EFCENT(1,IM)
C-XXX-          COMY1 = EFCENT(2,IM)
C-XXX-          COMZ1 = EFCENT(3,IM)
C-XXX-C
C-XXX-         ICJ=ICI + NMPTS(IM)
C-XXX-C
C-XXX-         KMASS2=0
C-XXX-         DO 270 JM = IM+1,NFRG
C-XXX-C
C-XXX-               UCOULIJ=ZERO
C-XXX-               ULJIJ=ZERO
C-XXX-               COMX2 = EFCENT(1,JM)
C-XXX-               COMY2 = EFCENT(2,JM)
C-XXX-               COMZ2 = EFCENT(3,JM)
C-XXX-C
C-XXX-               COMX = COMX1 - COMX2
C-XXX-               COMY = COMY1 - COMY2
C-XXX-               COMZ = COMZ1 - COMZ2
C-XXX-C
C-XXX-               PBCX = ZERO
C-XXX-               PBCY = ZERO
C-XXX-               PBCZ = ZERO
C-XXX-               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
C-XXX-               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
C-XXX-               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C-XXX-C
C-XXX-               RIMJM2=(COMX-PBCX)**2+(COMY-PBCY)**2+(COMZ-PBCZ)**2
C-XXX-C
C-XXX-               IF(RIMJM2.LE.RUPPER2) THEN
C-XXX-                 ZCHK=RIMJM2-RLOWER**2
C-XXX-                 IF(ZCHK.LE.0.0D+00) THEN
C-XXX-                  S=1.0D+00
C-XXX-                  SP=0.0D+00
C-XXX-                 ELSE
C-XXX-                  S=1.0D+00+ZCHK*(AS*(ZCHK**2)
C-XXX-     *                     +ZCHK*(BS*(ZCHK**2)
C-XXX-     *                     +CS*(ZCHK**3)))
C-XXX-                  SP=ZCHK*((6.0D+00*AS)*ZCHK+
C-XXX-     *               ZCHK*((8.0D+00*BS)*ZCHK+
C-XXX-     *               (10.0D+00*CS)*(ZCHK**2)))
C-XXX-                 ENDIF
C-XXX-C
C-XXX-          IC1=ICI
C-XXX-C
C-XXX-          DO 260 IPX = 1,NMPTS(IM)
C-XXX-            IC1=IC1+1
C-XXX-            X1 = EFC(1,IC1)
C-XXX-            Y1 = EFC(2,IC1)
C-XXX-            Z1 = EFC(3,IC1)
C-XXX-C            Q1 = ZERO
C-XXX-            Q1 = EFCHG(1,IC1)
C-XXX-            IC2=ICJ
C-XXX-C
C-XXX-C
C-XXX-               DO 250 JP = 1,NMPTS(JM)
C-XXX-                  IC2=IC2+1
C-XXX-                  X2 = EFC(1,IC2)
C-XXX-                  Y2 = EFC(2,IC2)
C-XXX-                  Z2 = EFC(3,IC2)
C-XXX-C                  Q2 = ZERO
C-XXX-                  Q2 = EFCHG(1,IC2)
C-XXX-                  X = X1 - X2
C-XXX-                  Y = Y1 - Y2
C-XXX-                  Z = Z1 - Z2
C-XXX-                  X = X - PBCX
C-XXX-                  Y = Y - PBCY
C-XXX-                  Z = Z - PBCZ
C-XXX-C
C-XXX-                  R2 = X*X + Y*Y + Z*Z
C-XXX-                  R2I = ONE/R2
C-XXX-                  R = SQRT(R2)
C-XXX-                  ULJT = ZERO
C-XXX-                  PRELJ = ZERO
C-XXX-                  PRECO = ZERO
C-XXX-                  IF(IPX.EQ.1.AND.JP.EQ.1) THEN
C-XXX-                    SIGR = SIGMASQ*R2I
C-XXX-                    SIGR6 = SIGR*SIGR*SIGR
C-XXX-C
C-XXX-                    ULJT = EPSILON4*SIGR6*(SIGR6-ONE)
C-XXX-C
C-XXX-                    PRELJ = -6.0D+00*S*
C-XXX-      *              (ULJT+ EPSILON4*SIGR6*SIGR6)*R2I
C-XXX-                  ENDIF
C-XXX-C
C-XXX-                      UCOULT = Q1*Q2/R
C-XXX-C
C-XXX-C
C-XXX-                  PRECO = -S*UCOULT/R2
C-XXX-C
C-XXX-                  EF3(1,IC1) = EF3(1,IC1) + (PRELJ + PRECO)*X
C-XXX-                  EF3(2,IC1) = EF3(2,IC1) + (PRELJ + PRECO)*Y
C-XXX-                  EF3(3,IC1) = EF3(3,IC1) + (PRELJ + PRECO)*Z
C-XXX-                  EF3(1,IC2) = EF3(1,IC2) - (PRELJ + PRECO)*X
C-XXX-                  EF3(2,IC2) = EF3(2,IC2) - (PRELJ + PRECO)*Y
C-XXX-                  EF3(3,IC2) = EF3(3,IC2) - (PRELJ + PRECO)*Z
C-XXX-C
C-XXX-                  UCOULIJ = UCOULIJ + UCOULT
C-XXX-                  ULJIJ = ULJIJ + ULJT
C-XXX-C
C-XXX-250         CONTINUE
C-XXX-260         CONTINUE
C-XXX-C
C-XXX-            UCOUL = UCOUL+S*UCOULIJ
C-XXX-            ULJ = ULJ + S*ULJIJ
C-XXX-C
C-XXX-            FIMJMX=(ULJIJ+UCOULIJ)*SP*(COMX-PBCX)
C-XXX-            FIMJMY=(ULJIJ+UCOULIJ)*SP*(COMY-PBCY)
C-XXX-            FIMJMZ=(ULJIJ+UCOULIJ)*SP*(COMZ-PBCZ)
C-XXX-C
C-XXX-            IC1=ICI
C-XXX-            IC2=ICJ
C-XXX-            DO IPX = 1,NMPTS(IM)
C-XXX-               IC1=IC1+1
C-XXX-               SCR1=FMASS(IPX+KMASS)/FRGMAS(IM)
C-XXX-               EF3(1,IC1)= EF3(1,IC1) + FIMJMX*SCR1
C-XXX-               EF3(2,IC1)= EF3(2,IC1) + FIMJMY*SCR1
C-XXX-               EF3(3,IC1)= EF3(3,IC1) + FIMJMZ*SCR1
C-XXX-            ENDDO
C-XXX-C
C-XXX-            DO JP=1,NMPTS(JM)
C-XXX-             IC2=IC2+1
C-XXX-                  SCR2=FMASS(JP+KMASS2)/FRGMAS(JM)
C-XXX-                  EF3(1,IC2)= EF3(1,IC2) - FIMJMX*SCR2
C-XXX-                  EF3(2,IC2)= EF3(2,IC2) - FIMJMY*SCR2
C-XXX-                  EF3(3,IC2)= EF3(3,IC2) - FIMJMZ*SCR2
C-XXX-            ENDDO
C-XXX-C
C-XXX-             ENDIF
C-XXX-            ICJ=ICJ+NMPTS(JM)
C-XXX-            KMASS2=KMASS2 + NMPTS(JM)
C-XXX-270      CONTINUE
C-XXX-         ICI=ICI+NMPTS(IM)
C-XXX-         KMASS=KMASS + NMPTS(IM)
C-XXX-C
C-XXX-280   CONTINUE
C-XXX-C
C-XXX-      E = ULJ + UCOUL
C-XXX-C      COMMON /CONVMD/ AU2KCAL, EK2KCAL, AU2ANG, AU2SEC, AU2AMU
C-XXX-C      WRITE(6,*) 'ELJ,ECOUL, AND ETOT = ',
C-XXX-C     *            ULJ*AU2KCAL,UCOUL*AU2KCAL,E*AU2KCAL
C-XXX-C
C-XXX-      DO I = 1,NMTTPT
C-XXX-         DO J = 1,3
C-XXX-            DEF(J,I) = DEF(J,I) + EF3(J,I)
C-XXX-         ENDDO
C-XXX-      ENDDO
C-XXX-C
C-XXX-      RETURN
C-XXX-      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
      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 /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
C
      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
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
          COMX1 = EFCENT(1,IM)
          COMY1 = EFCENT(2,IM)
          COMZ1 = EFCENT(3,IM)
C
         ICJ=ICI + NMPTS(IM)
C
         KMASS2=0
         DO 270 JM = IM+1,NFRG
C
               UCOULIJ=ZERO
               ULJIJ=ZERO
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
            PBCX = ZERO
            PBCY = ZERO
            PBCZ = ZERO
            IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX / XBOX)
            IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY / YBOX)
            IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ / ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
            X12  = ABS(COMX - PBCX)
            Y12  = ABS(COMY - PBCY)
            Z12  = ABS(COMZ - PBCZ)
            R12  = X12*X12+Y12*Y12+Z12*Z12
C
C   ---- CHECKS IF FRAGMENTS ARE WITHIN CUTOFF RADIUS
            IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT) GO TO 265
            IF(R12.GT.RCUT) GOTO 265
C
            SWF   = 1.0D+00
            SWFDX = 0.0D+00
            SWFDY = 0.0D+00
            SWFDZ = 0.0D+00
C
               IF(R12.GT.SWR2*SWR2) THEN
                  GOTO 265
               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)-PBCX)
                 SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                 SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                 SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                 SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               END IF
C
          IC1=ICI
C
          DO 260 IPX = 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
               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
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
C
                  R2 = X*X + Y*Y + Z*Z
                  R2I = ONE/R2
                  R = SQRT(R2)
                  ULJT = ZERO
                  PRELJ = ZERO
                  PRECO = ZERO
                  IF(IPX.EQ.1.AND.JP.EQ.1) THEN
                    SIGR = SIGMASQ*R2I
                    SIGR6 = SIGR*SIGR*SIGR
                    ULJT = EPSILON4*SIGR6*(SIGR6-ONE)
                    PRELJ = -6.0D+00*(ULJT+ EPSILON4*SIGR6*SIGR6)*R2I
                  ENDIF
C
                  UCOULT = Q1*Q2/R
                  PRECO = -UCOULT/R2
C
                  EF3(1,IC1) = EF3(1,IC1) + SWF*(PRELJ + PRECO)*X
                  EF3(2,IC1) = EF3(2,IC1) + SWF*(PRELJ + PRECO)*Y
                  EF3(3,IC1) = EF3(3,IC1) + SWF*(PRELJ + PRECO)*Z
                  EF3(1,IC2) = EF3(1,IC2) - SWF*(PRELJ + PRECO)*X
                  EF3(2,IC2) = EF3(2,IC2) - SWF*(PRELJ + PRECO)*Y
                  EF3(3,IC2) = EF3(3,IC2) - SWF*(PRELJ + PRECO)*Z
C
                  UCOULIJ = UCOULIJ + UCOULT
                  ULJIJ = ULJIJ + ULJT
C
250         CONTINUE
260         CONTINUE
C
            UCOUL = UCOUL+SWF*UCOULIJ
            ULJ = ULJ + SWF*ULJIJ
C
            FIMJMX=(ULJIJ+UCOULIJ)*SWFDX
            FIMJMY=(ULJIJ+UCOULIJ)*SWFDY
            FIMJMZ=(ULJIJ+UCOULIJ)*SWFDZ
C
            IC1=ICI
            IC2=ICJ
            DO IPX = 1,NMPTS(IM)
               IC1=IC1+1
               SCR1=FMASS(IPX+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
 265        CONTINUE
            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
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,LSTMPTS(MXFRG)
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
      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,LSTMPTS(MXFRG)
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
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
        COMX1 = EFCENT(1,IFRG)
        COMY1 = EFCENT(2,IFRG)
        COMZ1 = EFCENT(3,IFRG)
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
               COMX2 = EFCENT(1,JFRG)
               COMY2 = EFCENT(2,JFRG)
               COMZ2 = EFCENT(3,JFRG)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - PBCX)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - PBCY)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF   = 1.0D+00
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IFRG)-EFCENT(2,JFRG)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IFRG)-EFCENT(3,JFRG)-PBCZ)
                 END IF
               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 + PBCX
                YJ = YJ + PBCY
                ZJ = ZJ + PBCZ
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
      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,LSTMPTS(MXFRG)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
C
      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
         COMX1 = EFCENT(1,IFRG)
         COMY1 = EFCENT(2,IFRG)
         COMZ1 = EFCENT(3,IFRG)
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
               COMX2 = EFCENT(1,JFRG)
               COMY2 = EFCENT(2,JFRG)
               COMZ2 = EFCENT(3,JFRG)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IFRG) - EFCENT(1,JFRG) - PBCX)
               Y12  = ABS(EFCENT(2,IFRG) - EFCENT(2,JFRG) - PBCY)
               Z12  = ABS(EFCENT(3,IFRG) - EFCENT(3,JFRG) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWF   = 1.0D+00
               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
       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 + PBCX
             YJ = BYJ + PBCY
             ZJ = BZJ + PBCZ
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
      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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
C
      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
      COMMON /SCRPAR/ SCROFF
C
      PARAMETER (ZERO=0.0D+00, ONE=1.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
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 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
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               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)
C
C                 MUST BE DINDD
                  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
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                  P1_E = ZERO
                  P1D_E = ZERO
                  P2_E = ZERO
C
                  IF(IPLSCR.EQ.1) THEN
                     ALPHAB = POLSCR(IC2)
                     ALPHAA = POLSCR(IC1)
C
C  ----  IF TURN ON SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    END IF
                 END IF
C
      DOT = DX2*X + DY2*Y + DZ2*Z
      DUM = DOT*THREE/R5
C      DFX = DFX - DX2/R3 + X*DUM
C      DFY = DFY - DY2/R3 + Y*DUM
C      DFZ = DFZ - DZ2/R3 + Z*DUM
      DFX = DFX + (-DX2/R3+X*DUM)*(ONE+P1_E) + X*DOT*P2_E
      DFY = DFY + (-DY2/R3+Y*DUM)*(ONE+P1_E) + Y*DOT*P2_E
      DFZ = DFZ + (-DZ2/R3+Z*DUM)*(ONE+P1_E) + Z*DOT*P2_E
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
      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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /EFPAR / LOCNFG,NLOW,NUP
C
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /SCRPAR/ SCROFF
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00,ONE=1.0D+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
      ISCR = INT(ICHGP/2.0D+00)
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 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
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               END IF
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)
                  Q2 = EFCHG(1,IC2)+EFCHG(2,IC2)
                  IF(ISCR.NE.1) THEN
                     EX = ZERO
                     CF = ZERO
                  ELSE
                     EX = EFATRM2(IC2)
                     CF = EFBTRM2(IC2)
                  END IF
C REMEMBER FIELDS AT 1 DUE TO MULTIPOLES AT 2
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
C
                  XX = X*X
                  YY = Y*Y
                  ZZ = Z*Z
                  R2 = XX+YY+ZZ
                  R = SQRT(R2)
                  R3 = R2*R
C
C  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                  P1_E = ZERO
C
                  IF(ISCR.EQ.3.AND.IPLSCR.EQ.1.AND.INDSCR.EQ.0)THEN
                     ALPHAB = EFATRM2(IC2)
                     ALPHAA = POLSCR(IC1)
C
C  ----  IF TURN ON SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    END IF
                 END IF
C
C.... POTENTIAL, FIELD, FIELD GRADIENT, AND FIELD SECOND DERIVATIVE
C.... AT POINT 'IPX' IN MOLECULE 'IM' DUE TO POINTS IN JM (ACCUMULATED)
C
                  DUM = Q2/R3
                  IF(ISCR.NE.1) THEN
                     CFX = CFX + X*DUM*(ONE+P1_E)
                     CFY = CFY + Y*DUM*(ONE+P1_E)
                     CFZ = CFZ + Z*DUM*(ONE+P1_E)
                  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 'IPX' IN
C     IN MOLECULE 'IM' DUE TO ALL POINTS 'JP' IN MOLECULE 'JM'
C     HAVE NOW BEEN CALCULATED.  ADD INTERACTION OF MOMENTS AT 'IPX'
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
      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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
C
      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
      COMMON /SCRPAR/ SCROFF
C
      PARAMETER (PT5=0.5D+00,ZERO=0.0D+00,ONE=1.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
      ISCR = INT(ICHGP/2.0D+00)
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NPPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
           COMX1 = EFCENT(1,IM)
           COMY1 = EFCENT(2,IM)
           COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 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
                COMX2 = EFCENT(1,JM)
                COMY2 = EFCENT(2,JM)
                COMZ2 = EFCENT(3,JM)
C
                COMX = COMX1 - COMX2
                COMY = COMY1 - COMY2
                COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               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)
                  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
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                  P1_E = ZERO
                  P1D_E = ZERO
                  P2_E = ZERO
C
                  IF(ISCR.EQ.3.AND.IPLSCR.EQ.1.AND.INDSCR.EQ.0) THEN
                     ALPHAB = EFATRM2(IC2)
                     ALPHAA = POLSCR(IC1)
C
C  ----  IF TURN ON SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    END IF
                 END IF
C
      DOT = DX2*X + DY2*Y + DZ2*Z
      DUM = DOT*THREE/R5
C      DFX = DFX - DX2/R3 + X*DUM
C      DFY = DFY - DY2/R3 + Y*DUM
C      DFZ = DFZ - DZ2/R3 + Z*DUM
      DFX = DFX + (-DX2/R3+X*DUM)*(ONE+P1_E) + X*DOT*P2_E
      DFY = DFY + (-DY2/R3+Y*DUM)*(ONE+P1_E) + Y*DOT*P2_E
      DFZ = DFZ + (-DZ2/R3+Z*DUM)*(ONE+P1_E) + Z*DOT*P2_E
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
      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),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      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,LSTMPTS(MXFRG)
C
      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
      COMMON /SCRPAR/ SCROFF
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)
      PARAMETER (ONE=1.0D+00)
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
      ISCR = INT(ICHGP/2.0D+00)
C
      IF (GOPARR) THEN
        DO I=1,NLOW-1
          IC1 = IC1 + NMPTS(I)
        ENDDO
      ENDIF
C
      DO 400 IM = NLOW,NUP
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
         DO 390 IPX = 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
               COMX2 = EFCENT(1,JM)
               COMY2 = EFCENT(2,JM)
               COMZ2 = EFCENT(3,JM)
C
               COMX = COMX1 - COMX2
               COMY = COMY1 - COMY2
               COMZ = COMZ1 - COMZ2
C
               PBCX = ZERO
               PBCY = ZERO
               PBCZ = ZERO
               IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX/XBOX)
               IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY/YBOX)
               IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ/ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
               X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
               Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
               Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
               R12  = X12*X12+Y12*Y12+Z12*Z12
C
               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
               SWFDX = 0.0D+00
               SWFDY = 0.0D+00
               SWFDZ = 0.0D+00
               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)-PBCX)
                    SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                    SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                    SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               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)
                  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
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
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  ----  FRAGMENT-FRAGMENT SCREENING
C  ----  ZERO OUT ALL FRAG-FRAG PENETRATION TERMS
                     P1 = ZERO
                     P1D = ZERO
                     P2 = ZERO
                     P3 = ZERO
C
                  IF(ISCR.EQ.3.AND.IPLSCR.EQ.1.AND.INDSCR.EQ.0) THEN
                     ALPHAB = POLSCR(IC2)
                     ALPHAA = EFATRM2(IC1)
C
C  ----  IF TURN ON FRAGMENT-FGARMENT SCREENING
                    IF(R.LE.SCROFF) THEN
                       AP=ALPHAA*R
                       BP=ALPHAB*R
                       AA2=ALPHAA*ALPHAA
                       AB2=ALPHAB*ALPHAB
                       DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL FRAG-FRAG CHARGE-PENETRATION TERMS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1,P1_N1,P1_N2)
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D,P1D_N1,P1D_N2)
                    P2 =  -P1D/R3
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3,P3_N1,P3_N2)
                    END IF
                 END IF
C
C.... POTENTIAL, FIELD, AND FIELD GRADIENT DUE TO DIPOLE MOMENTS ON JM
C
C   ---- OLD CODE WITHOUT ELECTROSTATIC SCREENING
C      DOT = DX2*X + DY2*Y + DZ2*Z
C      DUM = THREE/R5
C      DFXX = DFXX + (TWO*DX2*X)*DUM - FIFTEN*XX*DOT/R7
C      DFYY = DFYY + (TWO*DY2*Y)*DUM - FIFTEN*YY*DOT/R7
C      DFZZ = DFZZ + (TWO*DZ2*Z)*DUM - FIFTEN*ZZ*DOT/R7
C      DFXY = DFXY + (DX2*Y+DY2*X)*DUM - FIFTEN*XY*DOT/R7
C      DFXZ = DFXZ + (DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*DOT/R7
C      DFYZ = DFYZ + (DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*DOT/R7
C
C   ---- NEW CODE WITH ELECTROSTATIC SCREENING
               RMU2 = X*DX2 + Y*DY2 + Z*DZ2
               DUM = THREE/R5
          DFXX =DFXX + (ONE+P1)*((TWO*DX2*X)*DUM - FIFTEN*XX*RMU2/R7) +
     *            TWO*P2*DX2*X + P1D*RMU2*(THREE*XX-R2)/R5 +
     *            P3*RMU2*XX
          DFYY =DFYY + (ONE+P1)*((TWO*DY2*Y)*DUM - FIFTEN*YY*RMU2/R7) +
     *            TWO*P2*DY2*Y + P1D*RMU2*(THREE*YY-R2)/R5 +
     *            P3*RMU2*YY
          DFZZ =DFZZ + (ONE+P1)*((TWO*DZ2*Z)*DUM - FIFTEN*ZZ*RMU2/R7)+
     *            TWO*P2*DZ2*Z + P1D*RMU2*(THREE*ZZ-R2)/R5 +
     *            P3*RMU2*ZZ
          DFXY =DFXY +(ONE+P1)*((DX2*Y+DY2*X)*DUM - FIFTEN*XY*RMU2/R7)+
     *            P2*(DX2*Y+DY2*X)+ P1D*RMU2*(THREE*XY)/R5 +
     *            P3*RMU2*XY
          DFXZ =DFXZ +(ONE+P1)*((DX2*Z+DZ2*X)*DUM - FIFTEN*XZ*RMU2/R7)+
     *            P2*(DX2*Z+DZ2*X)+ P1D*RMU2*(THREE*XZ)/R5 +
     *            P3*RMU2*XZ
          DFYZ =DFYZ +(ONE+P1)*((DY2*Z+DZ2*Y)*DUM - FIFTEN*YZ*RMU2/R7)+
     *            P2*(DY2*Z+DZ2*Y)+ P1D*RMU2*(THREE*YZ)/R5 +
     *            P3*RMU2*YZ
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
C
C*MODULE EFELEC  *DECK EPENCHCH
      SUBROUTINE EPENCHCH(AP,BP,AA2,AB2,DIFF,SCRE,SCRN1,SCRN2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, ZERO=0.0D+00)
      PARAMETER (SMALL=1.0D-5)
C
C     -------  CALCULATE CHARGE-CHARGE PENETRATION --------
C     THIS FORMULA INVOLVES FRAGMENT/FRAGMENT SCREENING
C
      SCRE=ZERO
      SCRN1=ZERO
      SCRN2=ZERO
C
C          ALPHAA = ALPHAB
           IF(DIFF.LT.SMALL) THEN
              SCRE=-EXP(-AP)*(ONE+(AP/TWO))
              SCRN1=-EXP(-AP)
              SCRN2=-EXP(-AP)
           ELSE
              SCRE=-EXP(-AP)*(AB2/(AB2-AA2))
     *              -EXP(-BP)*(AA2/(AA2-AB2))
              SCRN2=-EXP(-AP)
              SCRN1=-EXP(-BP)
           ENDIF
C
       RETURN
       END
C
C*MODULE EFELEC  *DECK EPENCHDIP
      SUBROUTINE EPENCHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00, HALF=0.5D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- CALCULATE CHARGE-DIPOLE & DIPOLE-CHARGE PENETRATION ----
C  ----  AND CHARGE-CHARGE GRADIENT PENETRATION ----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
      P1_E=ZERO
      P1_N1=ZERO
      P1_N2=ZERO
C
      EXPAP = EXP(-AP)
      EXPBP = EXP(-BP)
C
C   ---- IF   ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P1_E=-EXPAP*(ONE+AP+HALF*AP*AP)
               P1_N1=-EXPAP*(ONE+AP)
               P1_N2=-EXPAP*(ONE+AP)
            ELSE
               P1_E=-EXPAP*(ONE+AP)*(AB2/(AB2-AA2))
     *              -EXPBP*(ONE+BP)*(AA2/(AA2-AB2))
               P1_N2=-EXPAP*(ONE+AP)
               P1_N1=-EXPBP*(ONE+BP)
            END IF
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK EPENCHQU
      SUBROUTINE EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,P1D_E,P1D_N1,P1D_N2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00,PT5=0.5D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- CALCULATE CHARGE-QUADRUPOLE, QUADRUPOLE-CHARGE AND
C  ----          DIPOLE-DIPOLE PENETRATION ----
C  ----    AND CHARGE-DIPOLE GRADIENT SCREENING ----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
C  ----    THIS TERM IS P1D = D/DR(P1)
C
      P1D_E=ZERO
      P1D_N1=ZERO
      P1D_N2=ZERO
C
C      P1D_E.. ELECTRON-ELECTRON PART
C      P1D_N*.. ELELCTRON-NUCLEAR PART
C
      EXPAP = EXP(-AP)
      EXPBP = EXP(-BP)
C
C  ----  CODE DUE OLD POTENTIAL
C  ----  ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P1D_E=ONE/R2*EXPAP*(PT5*AP*AP*AP)
               P1D_N2=ONE/R2*EXPAP*(AP*AP)
               P1D_N1=ONE/R2*EXPBP*(BP*BP)
            ELSE
               P1D_E=ONE/R2*(EXPAP*(AP*AP)*(AB2/(AB2-AA2))
     *                +EXPBP*(BP*BP)*(AA2/(AA2-AB2)))
               P1D_N2=ONE/R2*EXPAP*(AP*AP)
               P1D_N1=ONE/R2*EXPBP*(BP*BP)
            END IF
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK EPENCHOCT
      SUBROUTINE EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,P3_E,P3_N1,P3_N2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00, PT5=0.5D+00,THREE=3.0D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- CALCULATE CHARGE-QUADRUPOLE, QUADRUPOLE-CHARGE AND
C  ----          DIPOLE-DIPOLE -GRADIENT- PENETRATION ----
C  ----          P3 = D/DR(P2)        -----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
C  ----  P3_E.. ELECTRON-ELECTRON TERMS
C  ----  P3_N_ (NUCLEAR) TERMS, THEY DON'T APPEAR IN DIP-DIPOLE ENERGY
      P3_E=ZERO
      P3_N1=ZERO
      P3_N2=ZERO
C
         EXPAP = EXP(-AP)
         EXPBP = EXP(-BP)
         AP2=AP*AP
         AP3=AP*AP*AP
         BP2=BP*BP
C
C  ----  CODE DUE OLD POTENTIAL
C  ----     ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P3_E=ONE/R7*EXPAP*AP3*(ONE+PT5*AP)
               P3_N1=ONE/R7*EXPAP*AP2*(AP+THREE)
               P3_N2=ONE/R7*EXPAP*AP2*(AP+THREE)
            ELSE
               P3_E=ONE/R7*(EXPAP*AP2*(AP+THREE)*AB2/(AB2-AA2)
     *               +EXPBP*BP2*(BP+THREE)*AA2/(AA2-AB2))
               P3_N2=ONE/R7*EXPAP*AP2*(AP+THREE)
               P3_N1=ONE/R7*EXPBP*BP2*(BP+THREE)
            END IF
C
      RETURN
      END
C
C
C*MODULE EFELEC  *DECK EPENP4
      SUBROUTINE EPENP4(AP,BP,AA2,AB2,DIFF,R2,P4_E)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00, PT5=0.5D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- APPEARS IN DIPOLE-QUADRUPOLE GRADIENT AND QUAD-QUAD ENERGY
C  ----     SCREENING TERMS
C  ----          P4 = D/DR(P1D)        -----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
C  ----  P4_E.. ELECTRON-ELECTRON TERMS
C  ----  WE DO NOT NEED NUCLEAR TERMS CURRENTLY
      P4_E=ZERO
C
         EXPAP = EXP(-AP)
         EXPBP = EXP(-BP)
         AP3=AP*AP*AP
         BP3=BP*BP*BP
C
C  ----  CODE DUE OLD POTENTIAL
C  ----     ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P4_E=PT5/R2/R2*EXPAP*AP3*(ONE-AP)
            ELSE
               P4_E=-ONE/R2/R2*(EXPAP*AP3*AB2/(AB2-AA2)
     *               +EXPBP*BP3*AA2/(AA2-AB2))
            END IF
C
      RETURN
      END
C
C
C*MODULE EFELEC  *DECK EPENP5
      SUBROUTINE EPENP5(AP,BP,AA2,AB2,DIFF,R7,P5_E)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, THREE=3.0D+00)
      PARAMETER (FIVE=5.0D+00, TEN=10.0D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- APPEARS IN DIPOLE-QUADRUPOLE GRADIENT AND QUAD-QUAD ENERGY
C  ----     SCREENING TERMS
C  ----          P5 = D/DR(3*P1/R**5)        -----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
C  ----  P5_E.. ELECTRON-ELECTRON TERMS
C  ----  WE DO NOT NEED NUCLEAR TERMS CURRENTLY
C
         P5_E=ZERO
         EXPAP = EXP(-AP)
         EXPBP = EXP(-BP)
         AP2=AP*AP
         AP3=AP*AP*AP
         BP2=BP*BP
C
C  ----  CODE DUE OLD POTENTIAL
C  ----     ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P5_E=-THREE/R7*EXPAP*PT5*(TEN + TEN*AP + FIVE*AP2 + AP3)
            ELSE
               P5_E=-THREE/R7*(EXPAP*(FIVE+FIVE*AP+AP2)*AB2/(AB2-AA2)
     *               +EXPBP*(FIVE+FIVE*BP+BP2)*AA2/(AA2-AB2))
            END IF
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK EPENP6
      SUBROUTINE EPENP6(AP,BP,AA2,AB2,DIFF,R9,P6_E)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00)
      PARAMETER (SMALL=1.0D-5)
C
C  ---- APPEARS IN DIPOLE-QUADRUPOLE GRADIENT AND QUAD-QUAD ENERGY
C  ----     SCREENING TERMS
C  ----          P6 = D/DR(P3)        -----
C  ----         FRAGMENT/FRAGMENT SCREENING
C
C  ----  P6_E.. ELECTRON-ELECTRON TERMS
C  ----  WE DO NOT NEED NUCLEAR TERMS CURRENTLY
C
         P6_E=ZERO
         EXPAP = EXP(-AP)
         EXPBP = EXP(-BP)
         AP2=AP*AP
         AP3=AP*AP*AP
         BP2=BP*BP
C
C  ----  CODE DUE OLD POTENTIAL
C  ----     ALPHAA = ALPHAB
            IF(DIFF.LT.SMALL) THEN
               P6_E=-ONE/R9*EXPAP*AP3*(4.0D+00+2.5D+00*AP+0.5D+00*AP2)
            ELSE
               P6_E=-ONE/R9*(EXPAP*AP2*(15.0D+00+7.0D+00*AP+AP2)*
     *              AB2/(AB2-AA2)
     *             + EXPBP*BP2*(15.0D+00+7.0D+00*BP+BP2)*AA2/(AA2-AB2))
            END IF
C
      RETURN
      END
C
C---C*MODULE EFELEC  *DECK SCR5CHCH
C---      SUBROUTINE SCR5CHCH(AP,BP,AA2,AB2,DIFF,SCRE,SCRN1,SCRN2)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, ZERO=0.0D+00)
C---      PARAMETER (SMALL=1.0D-5)
C---C
C---C     -------  CALCULATE CHARGE-CHARGE PENETRATION --------
C---C     THIS FORMULA INVOLVES SCR5 FRAGMENT/FRAGMENT SCREENING
C---C
C---      SCRE=ZERO
C---      SCRN1=ZERO
C---      SCRN2=ZERO
C---C
C---C          ALPHAA = ALPHAB
C---           IF(DIFF.LT.SMALL) THEN
C---              SCRE=-EXP(-AP)*(ONE+11.0D+00/16.0D+00*AP+
C---     *               3.0D+00/16.0D+00*AP*AP+ONE/48.0D+00*AP*AP*AP)
C---              SCRN1=-EXP(-AP)*(ONE+(AP/TWO))
C---              SCRN2=-EXP(-AP)*(ONE+(AP/TWO))
C---           ELSE
C---              SCRE=-EXP(-AP)*AB2*AB2/((-AA2+AB2)*(-AA2+AB2))*
C---     *                   (ONE+AP/TWO-TWO*AA2/(-AA2+AB2))
C---     *             -EXP(-BP)*AA2*AA2/((AA2-AB2)*(AA2-AB2))*
C---     *                   (ONE+BP/TWO-TWO*AB2/(AA2-AB2))
C---              SCRN2=-EXP(-AP)*(ONE+AP/TWO)
C---              SCRN1=-EXP(-BP)*(ONE+BP/TWO)
C---           ENDIF
C---C
C---       RETURN
C---       END
C---C
C---C*MODULE EFELEC  *DECK SCR5CHDIP
C---      SUBROUTINE SCR5CHDIP(AP,BP,AA2,AB2,DIFF,P1_E,P1_N1,P1_N2)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      PARAMETER (ONE=1.0D+00, ZERO=0.0D+00, TWO=2.0D+00)
C---      PARAMETER (SMALL=1.0D-5)
C---C
C---C  ---- CALCULATE CHARGE-DIPOLE & DIPOLE-CHARGE PENETRATION ----
C---C  ----  AND CHARGE-CHARGE GRADIENT PENETRATION ----
C---C  ----         FRAGMENT/FRAGMENT SCR5 SCREENING
C---C
C---      P1_E=ZERO
C---      P1_N1=ZERO
C---      P1_N2=ZERO
C---C
C---      EXPAP = EXP(-AP)
C---      EXPBP = EXP(-BP)
C---      TMPA = AB2*AB2/((-AA2+AB2)*(-AA2+AB2))
C---      TMPB = AA2*AA2/((AA2-AB2)*(AA2-AB2))
C---C
C---C   ---- IF   ALPHAA = ALPHAB
C---            IF(DIFF.LT.SMALL) THEN
C---               P1_E=-EXPAP*(ONE+AP+AP*AP/TWO+
C---     *          7.0D+00/48.0D+00*AP*AP*AP+ONE/48.0D+00*AP*AP*AP*AP)
C---               P1_N1=-EXPAP*(ONE+AP+AP*AP/TWO)
C---               P1_N2=-EXPAP*(ONE+AP+AP*AP/TWO)
C---            ELSE
C---               P1_E=-EXPAP*TMPA*
C---     *               ((ONE+AP)*(ONE-TWO*AA2/(-AA2+AB2))+AP*AP/TWO)
C---     *              -EXPBP*TMPB*
C---     *               ((ONE+BP)*(ONE-TWO*AB2/(AA2-AB2))+BP*BP/TWO)
C---               P1_N2=-EXPAP*(ONE+AP+AP*AP/TWO)
C---               P1_N1=-EXPBP*(ONE+BP+BP*BP/TWO)
C---            END IF
C---C
C---      RETURN
C---      END
C---C
C---C*MODULE EFELEC  *DECK SCR5CHQU
C---      SUBROUTINE SCR5CHQU(AP,BP,AA2,AB2,DIFF,R2,P1D_E,P1D_N1,P1D_N2)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      PARAMETER (ONE=1.0D+00,ZERO=0.0D+00,TWO=2.0D+00,THREE=3.0D+00)
C---      PARAMETER (SMALL=1.0D-5)
C---C
C---C  ---- CALCULATE CHARGE-QUADRUPOLE, QUADRUPOLE-CHARGE AND
C---C  ----          DIPOLE-DIPOLE PENETRATION ----
C---C  ----    AND CHARGE-DIPOLE GRADIENT SCREENING ----
C---C  ----         FRAGMENT/FRAGMENT SCREENING
C---C
C---C  ----    THIS TERM IS P1D = D/DR(P1)
C---C
C---      P1D_E=ZERO
C---      P1D_N1=ZERO
C---      P1D_N2=ZERO
C---C
C---C      P1D_E.. ELECTRON-ELECTRON PART
C---C      P1D_N*.. ELELCTRON-NUCLEAR PART
C---C
C---      EXPAP = EXP(-AP)
C---      EXPBP = EXP(-BP)
C---      TMPA=AB2*AB2/((-AA2+AB2)*(-AA2+AB2))
C---      TMPB=AA2*AA2/((AA2-AB2)*(AA2-AB2))
C---C
C---C  ----  ALPHAA = ALPHAB
C---            IF(DIFF.LT.SMALL) THEN
C---               P1D_E=ONE/R2*EXPAP*AP*AP*AP*ONE/48.0D+00*
C---     *               (THREE+THREE*AP+AP*AP)
C---               P1D_N2=ONE/R2*EXPAP*AP*AP*AP/TWO
C---               P1D_N1=ONE/R2*EXPAP*AP*AP*AP/TWO
C---            ELSE
C---               P1D_E=ONE/R2*(EXPAP*AP*AP*TMPA*
C---     *               (TWO*AA2/(AA2-AB2)+AP/TWO)
C---     *               +EXPBP*BP*BP*TMPB*
C---     *               (TWO*AB2/(AB2-AA2)+BP/TWO))
C---               P1D_N2=ONE/R2*EXPAP*AP*AP*AP/TWO
C---               P1D_N1=ONE/R2*EXPBP*BP*BP*BP/TWO
C---            END IF
C---C
C---      RETURN
C---      END
C---C
C---C
C---C*MODULE EFELEC  *DECK SCR5CHOCT
C---      SUBROUTINE SCR5CHOCT(AP,BP,AA2,AB2,DIFF,R7,P3_E,P3_N1,P3_N2)
C---C
C---      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C---C
C---      PARAMETER (ONE=1.0D+00,ZERO=0.0D+00,TWO=2.0D+00,THREE=3.0D+00)
C---      PARAMETER (SMALL=1.0D-5)
C---C
C---C  ---- CALCULATE CHARGE-QUADRUPOLE, QUADRUPOLE-CHARGE AND
C---C  ----          DIPOLE-DIPOLE -GRADIENT- PENETRATION ----
C---C  ----          P3 = D/DR(P2)        -----
C---C  ----         FRAGMENT/FRAGMENT SCREEN5 SCREENING
C---C
C---C  ----  P3_E.. ELECTRON-ELECTRON TERMS
C---C  ----  P3_N_ (NUCLEAR) TERMS, THEY DO NOT APPEAR IN
C---C  ----  DIPOLE-DIPOLE ENERGY
C---      P3_E=ZERO
C---      P3_N1=ZERO
C---      P3_N2=ZERO
C---C
C---         EXPAP = EXP(-AP)
C---         EXPBP = EXP(-BP)
C---         AP2=AP*AP
C---         AP3=AP*AP*AP
C---         BP2=BP*BP
C---         BP3=BP*BP*BP
C---      TMPA=AB2*AB2/((-AA2+AB2)*(-AA2+AB2))
C---      TMPB=AA2*AA2/((AA2-AB2)*(AA2-AB2))
C---C
C---C  ----     ALPHAA = ALPHAB
C---            IF(DIFF.LT.SMALL) THEN
C---               P3_E=ONE/R7*EXPAP*AP3*ONE/48.0D+00*
C---     *              (6.0D+00+6.0D+00*AP+3.0D+00*AP2+AP3)
C---               P3_N1=ONE/R7*EXPAP*AP3*(ONE+AP/TWO)
C---               P3_N2=ONE/R7*EXPAP*AP3*(ONE+AP/TWO)
C---            ELSE
C---               P3_E=ONE/R7*(EXPAP*TMPA*AP2*((TWO*AA2/(AA2-AB2))*
C---     *              (THREE+AP)+TWO*AP+AP2)+
C---     *               EXPBP*TMPB*BP2*((TWO*AB2/(AB2-AA2))*
C---     *              (THREE+BP)+TWO*BP+BP2))
C---               P3_N2=ONE/R7*EXPAP*AP3*(ONE+AP/TWO)
C---               P3_N1=ONE/R7*EXPBP*BP3*(ONE+BP/TWO)
C---            END IF
C---C
C---      RETURN
C---      END
C---C
C
C*MODULE EFELEC  *DECK FFELEC
      SUBROUTINE FFELEC(EFINAL,ECHCH,ECHDIP,ECHQUAD,ECO,EDD,
     *                  EDQ,EQQ,QGRAD,IPRINT)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL DOMONO,DODIPO,DOQUAD,DOOCTU
      LOGICAL DOCHPEN,HOCHPEN,DOGAUSS,IFSWF,QGRAD,IPRINT
      LOGICAL IFEWLD,TNFOIL,EWLDPL
C
      CHARACTER*8 FRGNME
C
      DIMENSION GRADCO(3),TORQICO(3),TORQJCO(3),
     *          GRADDQ(3),TORQIDQ(3),TORQJDQ(3),
     *          GRADQQ(3),TORQIQQ(3),TORQJQQ(3),
     *          GCC(3),GCD(3),GCQ(3),GCO(3),GDD(3),GDQ(3),GQQ(3),
     *          TICD(3),TICQ(3),TICO(3),TIDD(3),TIDQ(3),TIQQ(3),
     *          TJCD(3),TJCQ(3),TJCO(3),TJDD(3),TJDQ(3),TJQQ(3),
     *          ESBUFF(10)
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 /EFPELE/ P0(3),P1(3),P1D(3),P2(3),P3(3),P4,P5,P6,FF(0:6),
     *                DIP1(3),DIP2(3),QUAD1(6),QUAD2(6),
     *                QQ1(2),QQ2(2),OCT1(10),OCT2(10),
     *                AXX(6),AXXX(10),TT(6),RMU(2),
     *                R,R2,R3,R4,R5,R7,R9,
     *                DOGAUSS,DOCHPEN,HOCHPEN
      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,LSTMPTS(MXFRG)
      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
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /SCRPAR/ SCROFF
      COMMON /EWALD / IFEWLD,TNFOIL,BETA,ELCNST,EPSLN,CUTOFF,CUTLST,
     *                KMAX,NKVEC,LEVEL,EWLDPL
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, THREE=3.0D+00, ZERO=0.0D+00)
      PARAMETER (FIVE=5.0D+00, FIFTEN=15.0D+00, SIX=6.0D+00)
      PARAMETER (PT5=0.5D+00,ONEPT5=1.5D+00)
C
      ISCR = INT(ICHGP/2.0D+00)
C   ---- INIZALIZATION
      CALL VCLR(DESFRG,1,6*MXFRG)
      EFINAL = ZERO
      ECHCH = ZERO
      ECHDIP = ZERO
      ECHQUAD = ZERO
      ECC = ZERO
      ECHPCC = ZERO
      ECD = ZERO
      ECHPCD = ZERO
      ECQ  = ZERO
      ECHPCQ = ZERO
      ECO = ZERO
      EDD = ZERO
      EDQ = ZERO
      EQQ = ZERO
      EDELTA = ZERO
C
      CALL VCLR(GCC,1,3)
      CALL VCLR(GCD,1,3)
      CALL VCLR(GCQ,1,3)
      CALL VCLR(GDD,1,3)
      CALL VCLR(GDQ,1,3)
      CALL VCLR(GQQ,1,3)
      CALL VCLR(GCO,1,3)
C
C  ---- THIS IS FOR DEBUGGING ----
C  PLEASE DO NOT REMOVE IT, EVEN THOUGH IT IS IMPOSSIBLE TO EXECUTE IT
C
      IF (IW.EQ.-328) THEN
C
      CALL VCLR(TICD,1,3)
      CALL VCLR(TICQ,1,3)
      CALL VCLR(TIDD,1,3)
      CALL VCLR(TIDQ,1,3)
      CALL VCLR(TIQQ,1,3)
      CALL VCLR(TICO,1,3)
      CALL VCLR(TJCD,1,3)
      CALL VCLR(TJCQ,1,3)
      CALL VCLR(TJDD,1,3)
      CALL VCLR(TJDQ,1,3)
      CALL VCLR(TJQQ,1,3)
      CALL VCLR(TJCO,1,3)
      END IF
C------
C
      IFSWF = (SWR1 .LE. 1.0D+12 .AND. SWR2 .LE. 1.0D+12)
      PI=4*ATAN(1.0D+00)
C
      CALL EFCM
C
      IC1=0
C
C.... THE SECOND AND THIRD MOMENTS OF THE CHARGE DISTRIBUTION ....
C.... ARE REPLACED LATER ON
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
C
C      DO 280 IM = 1,NFRG
      DO 280 IM = NLOW,NUP
         COMX1 = EFCENT(1,IM)
         COMY1 = EFCENT(2,IM)
         COMZ1 = EFCENT(3,IM)
C
C         DO 270 JM = LIST(IM),LIST(IM+1)-1
         DO 270 JM = 1,IM
            IF (IM.EQ.JM) GO TO 270
C
            COMX2 = EFCENT(1,JM)
            COMY2 = EFCENT(2,JM)
            COMZ2 = EFCENT(3,JM)
C
            COMX = COMX1 - COMX2
            COMY = COMY1 - COMY2
            COMZ = COMZ1 - COMZ2
C
            PBCX = ZERO
            PBCY = ZERO
            PBCZ = ZERO
            IF (XBOX .NE. ZERO) PBCX = XBOX * ANINT(COMX / XBOX)
            IF (YBOX .NE. ZERO) PBCY = YBOX * ANINT(COMY / YBOX)
            IF (ZBOX .NE. ZERO) PBCZ = ZBOX * ANINT(COMZ / ZBOX)
C
C   ----  DISTANCE BETWEEN FRAGMENTS
            X12  = ABS(EFCENT(1,IM) - EFCENT(1,JM) - PBCX)
            Y12  = ABS(EFCENT(2,IM) - EFCENT(2,JM) - PBCY)
            Z12  = ABS(EFCENT(3,IM) - EFCENT(3,JM) - PBCZ)
            R12  = X12*X12+Y12*Y12+Z12*Z12
C
C   ---- CHECKS IF FRAGMENTS ARE WITHIN CUTOFF RADIUS
            IF(X12.GT.XCUT.OR.Y12.GT.YCUT.OR.Z12.GT.ZCUT) GO TO 270
            IF(R12.GT.RCUT) GOTO 270
C
C   ---- SWITCHING FUNCTIONS
C   ---- IF ON, SWITCHING FUNCTIONS ARE MULTIPLIED BY THE TOTAL ENERGIES
C   ---- (GRADIENTS)
            SWF   = 1.0D+00
            SWFDX = 0.0D+00
            SWFDY = 0.0D+00
            SWFDZ = 0.0D+00
C
            IF(IFSWF) THEN
               IF(R12.GT.SWR2*SWR2) THEN
                  GOTO 270
               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)-PBCX)
                 SWFDY = DSWF*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                 SWFDZ = DSWF*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 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)-PBCX)
                 SWFDY = DUMY2*(EFCENT(2,IM)-EFCENT(2,JM)-PBCY)
                 SWFDZ = DUMY2*(EFCENT(3,IM)-EFCENT(3,JM)-PBCZ)
                 END IF
               END IF
            END IF
C
C  ---- THINGS FOR CHARGE-PENETRATION SCXREENING
            AI=ZERO
            AJ=ZERO
            CF1 = ZERO
            CF2 = ZERO
            ALPHAA = ZERO
            ALPHAB = ZERO
            BETAA = ZERO
            BETAB = ZERO
C
C   ----  INITIALIZATION
            EPAIRCC = ZERO
            EPCHPCC = ZERO
            EPAIRCD = ZERO
            EPCHPCD = ZERO
            EPAIRDD = ZERO
            EPAIRCQ = ZERO
            EPCHPCQ = ZERO
            EPAIRCO = ZERO
            EPAIRDQ = ZERO
            EPAIRQQ = ZERO
            CALL VCLR(QUAD1,1,6)
            CALL VCLR(QUAD2,1,6)
            CALL VCLR(OCT1,1,10)
            CALL VCLR(OCT2,1,10)
C
C   ---- START THE LOOP OVER MULTIPOLE POINTS OF IM FRAGMENT
            IC1 = LSTMPTS(IM)-1
            DO 260 IPX = 1,NMPTS(IM)
               IC1=IC1+1
               X1 = EFC(1,IC1)
               Y1 = EFC(2,IC1)
               Z1 = EFC(3,IC1)
               DX1 = EFDIP(1,IC1)
               DY1 = EFDIP(2,IC1)
               DZ1 = EFDIP(3,IC1)
               Q1 = EFCHG(1,IC1)
               Q1N = EFCHG(2,IC1)
               Q11 = Q1+Q1N
C   ---- PUT THIS INFORMATION TO COMMON /EFPELE/
               QQ1(1) = Q1
               QQ1(2) = Q1N
               DIP1(1) = DX1
               DIP1(2) = DY1
               DIP1(3) = DZ1
C   ---- QUADRUPOLE
               CALL VCLR(QUAD1,1,6)
               IF(DOQUAD(IC1)) THEN
                  XX1 = EFQAD(1,IC1)
                  YY1 = EFQAD(2,IC1)
                  ZZ1 = EFQAD(3,IC1)
                  XY1 = EFQAD(4,IC1)
                  XZ1 = EFQAD(5,IC1)
                  YZ1 = EFQAD(6,IC1)
                  DUM = XX1 + YY1 + ZZ1
                  QUAD1(1) = PT5 * (THREE * XX1 - DUM)
                  QUAD1(2) = PT5 * (THREE * YY1 - DUM)
                  QUAD1(3) = PT5 * (THREE * ZZ1 - DUM)
                  QUAD1(4) = ONEPT5 * XY1
                  QUAD1(5) = ONEPT5 * XZ1
                  QUAD1(6) = ONEPT5 * YZ1
               END IF
C   ---- OCTOPOLES
               CALL VCLR(OCT1,1,10)
               IF(DOOCTU(IC1)) THEN
                  XXX1 = EFOCT(1,IC1) * PT5
                  YYY1 = EFOCT(2,IC1) * PT5
                  ZZZ1 = EFOCT(3,IC1) * PT5
                  XXY1 = EFOCT(4,IC1) * PT5
                  XXZ1 = EFOCT(5,IC1) * PT5
                  XYY1 = EFOCT(6,IC1) * PT5
                  YYZ1 = EFOCT(7,IC1) * PT5
                  XZZ1 = EFOCT(8,IC1) * PT5
                  YZZ1 = EFOCT(9,IC1) * PT5
                  XYZ1 = EFOCT(10,IC1) * PT5
                  DUMX = XXX1 + XYY1 + XZZ1
                  DUMY = XXY1 + YYY1 + YZZ1
                  DUMZ = XXZ1 + YYZ1 + ZZZ1
                  OCT1(1) = FIVE * XXX1 - THREE * DUMX
                  OCT1(2) = FIVE * YYY1 - THREE * DUMY
                  OCT1(3) = FIVE * ZZZ1 - THREE * DUMZ
                  OCT1(4) = FIVE * XXY1 - DUMY
                  OCT1(5) = FIVE * XXZ1 - DUMZ
                  OCT1(6) = FIVE * XYY1 - DUMX
                  OCT1(7) = FIVE * YYZ1 - DUMZ
                  OCT1(8) = FIVE * XZZ1 - DUMX
                  OCT1(9) = FIVE * YZZ1 - DUMY
                  OCT1(10) = FIVE * XYZ1
               END IF
C
C   ---- FOR CHARGE-PENETRATION
               IF(ISCR.EQ.2.OR.ISCR.EQ.3.OR.ISCR.EQ.4
     *                .OR.ISCR.EQ.5) THEN
                  ALPHAA = EFATRM2(IC1)
                  BETAA = EFBTRM2(IC1)
               ELSE
                  IF (ISCR.EQ.1) THEN
                      AI=EFATRM2(IC1)
                      CF1 = EFBTRM2(IC1)
                   END IF
               END IF
C
C   ---- START THE LOOP OVER MULTIPOLE POINTS OF JM FRAGMENT
               IC2 = LSTMPTS(JM)-1
               DO 250 JP = 1,NMPTS(JM)
                  IC2 = IC2+1
                  X2 = EFC(1,IC2)
                  Y2 = EFC(2,IC2)
                  Z2 = EFC(3,IC2)
                  DX2 = EFDIP(1,IC2)
                  DY2 = EFDIP(2,IC2)
                  DZ2 = EFDIP(3,IC2)
                  Q2 = EFCHG(1,IC2)
                  Q2N = EFCHG(2,IC2)
                  Q22 = Q2+Q2N
C   ---- PUT THIS INFORMATION TO COMMON /EFPELE/
                  QQ2(1) = Q2
                  QQ2(2) = Q2N
                  DIP2(1) = DX2
                  DIP2(2) = DY2
                  DIP2(3) = DZ2
                  CALL VCLR(QUAD2,1,6)
                  IF(DOQUAD(IC2)) THEN
                     XX1 = EFQAD(1,IC2)
                     YY1 = EFQAD(2,IC2)
                     ZZ1 = EFQAD(3,IC2)
                     XY1 = EFQAD(4,IC2)
                     XZ1 = EFQAD(5,IC2)
                     YZ1 = EFQAD(6,IC2)
                     DUM = XX1 + YY1 + ZZ1
                     QUAD2(1) = PT5 * (THREE * XX1 - DUM)
                     QUAD2(2) = PT5 * (THREE * YY1 - DUM)
                     QUAD2(3) = PT5 * (THREE * ZZ1 - DUM)
                     QUAD2(4) = ONEPT5 * XY1
                     QUAD2(5) = ONEPT5 * XZ1
                     QUAD2(6) = ONEPT5 * YZ1
                  END IF
C   ---- OCTOPOLES
                  CALL VCLR(OCT2,1,10)
                  IF(DOOCTU(IC2)) THEN
                     XXX1 = EFOCT(1,IC2) * PT5
                     YYY1 = EFOCT(2,IC2) * PT5
                     ZZZ1 = EFOCT(3,IC2) * PT5
                     XXY1 = EFOCT(4,IC2) * PT5
                     XXZ1 = EFOCT(5,IC2) * PT5
                     XYY1 = EFOCT(6,IC2) * PT5
                     YYZ1 = EFOCT(7,IC2) * PT5
                     XZZ1 = EFOCT(8,IC2) * PT5
                     YZZ1 = EFOCT(9,IC2) * PT5
                     XYZ1 = EFOCT(10,IC2) * PT5
                     DUMX = XXX1 + XYY1 + XZZ1
                     DUMY = XXY1 + YYY1 + YZZ1
                     DUMZ = XXZ1 + YYZ1 + ZZZ1
                     OCT2(1) = FIVE * XXX1 - THREE * DUMX
                     OCT2(2) = FIVE * YYY1 - THREE * DUMY
                     OCT2(3) = FIVE * ZZZ1 - THREE * DUMZ
                     OCT2(4) = FIVE * XXY1 - DUMY
                     OCT2(5) = FIVE * XXZ1 - DUMZ
                     OCT2(6) = FIVE * XYY1 - DUMX
                     OCT2(7) = FIVE * YYZ1 - DUMZ
                     OCT2(8) = FIVE * XZZ1 - DUMX
                     OCT2(9) = FIVE * YZZ1 - DUMY
                     OCT2(10) = FIVE * XYZ1
                  END IF
C
C   ----  DISTANCE BETWEEN TWO CENTERS
                  X = X1 - X2
                  Y = Y1 - Y2
                  Z = Z1 - Z2
                  X = X - PBCX
                  Y = Y - PBCY
                  Z = Z - PBCZ
C
                  R2 = X*X + Y*Y + Z*Z
                  R = SQRT(R2)
                  R3 = R2*R
                  R4 = R2*R2
                  R5 = R2*R3
                  R7 = R2*R5
                  R9 = R2*R7
C
C--------   SCREENING FUNCTIONS FOR EWALD DIRECT TERMS
                 F0 = ONE
                 F0_GRAD = ONE
                 F1 = ONE
                 F1_CD = ONE
                 F1_DD = ONE
                 F1_CQ = ONE
                 F1_GRAD = ZERO
                 F2 = ZERO
                 F2_DD = ZERO
                 F2_CQ = ZERO
                 F3 = ZERO
                 F3_DD = ZERO
                 F4_DD = ZERO
                 F3_CQ = ZERO
                 F4_CQ = ZERO
                 F4 = ZERO
                 F5 = ZERO
                 F6 = ZERO
                 IF (IFEWLD) THEN
                    F0 = ERFC(BETA*R)
                    EXPBR = EXP(-BETA*BETA*R2)
                    F0_GRAD = TWO*BETA*R/SQRT(PI)*EXPBR + F0
C                   CHARGE-DIPOLE                    
                    IF (LEVEL .GE. 2) THEN 
                       F1_CD = TWO*BETA*R/SQRT(PI)*EXPBR + F0
                       F1_GRAD =4.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR/R2
                       F1_DD = F1_CD
                       F2_DD = F1_GRAD
                       F3_DD = R3*F2_DD
                       F4_DD = 8.0D+00*BETA*BETA*BETA/SQRT(PI)*EXPBR*
     *                       (BETA*BETA*R2+ONE)/R4
                    END IF
                    IF (LEVEL .GE. 3) THEN 
                       F1_CQ = F1_DD
                       F2_CQ = F2_DD
                       F3_CQ = F3_DD
                       F4_CQ = F4_DD
                    END IF
C                 F5 = R3*F4 - THREE*R*F2
C                 F6 = TWO*(BETA*BETA+ONE/R2)*F4+FOUR*F2/R4 
                 END IF    
C                 WRITE(IW,*)'F1,F1_GRAD', F1,F1_GRAD 
C
                 FF(0)=ONE
                 FF(1)=ONE
                 FF(2)=ZERO
                 FF(3)=ZERO
                 FF(4)=ZERO
                 FF(5)=ZERO
                 FF(6)=ZERO
C
C   ---- FOR CHARGE-PENETRATIION
                IF(ISCR.EQ.2.OR.ISCR.EQ.3.OR.ISCR.EQ.4
     *                .OR.ISCR.EQ.5) THEN
                     ALPHAB = EFATRM2(IC2)
                     BETAB = EFBTRM2(IC2)
                ELSE
                   IF (ISCR.EQ.1) THEN
                     AJ=EFATRM2(IC2)
                     CF2 = EFBTRM2(IC2)
                     AIJ=AI+AJ
                   END IF
                END IF
C
C  ----  ZERO OUT ALL PENETRATION TERMS
                EX1 = ZERO
                EX2 = ZERO
                SCR1 = ZERO
                SCR2 = ZERO
                P0_E = ZERO
                P0_N1 = ZERO
                P0_N2 = ZERO
                P1_E = ZERO
                P1_N1 = ZERO
                P1_N2 = ZERO
                P1_ECC = ZERO
                P1_N1CC = ZERO
                P1_N2CC = ZERO
                P1D_E = ZERO
                P1D_N1 = ZERO
                P1D_N2 = ZERO
                P2_E = ZERO
                P2_N1 = ZERO
                P2_N2 = ZERO
                P3_E = ZERO
                P3_N1 = ZERO
                P3_N2 = ZERO
                P4 = ZERO
                P5 = ZERO
                P6 = ZERO
                CALL VCLR(P0,1,3)
                CALL VCLR(P1,1,3)
                CALL VCLR(P2,1,3)
                CALL VCLR(P3,1,3)
C
C  ----  IF DO CHARGE-CHARGE (DOCHPEN) AND HIGH-ORDER (HOCHPEN)
C  ----   FRAGMENT-FGARMENT SCREENING
                 DOCHPEN = .FALSE.
                 HOCHPEN = .FALSE.
                 DOGAUSS = .FALSE.
                 IF(ISCR.GT.1.AND.R.LE.SCROFF.AND.
     *              (BETAA.NE.ZERO .OR. BETAB .NE.ZERO)) THEN
                    DOCHPEN = .TRUE.
                    IF(ISCR.EQ.3.OR.ISCR.EQ.5) HOCHPEN=.TRUE.
C  ---- THERE IS NO EFFECTIVE SCREENING IF COEFICCIENT BETA IS 0
                    IF (BETAA .EQ. ZERO) ALPHAA = 1.0D+20
                    IF (BETAB .EQ. ZERO) ALPHAB = 1.0D+20
                    AP=ALPHAA*R
                    BP=ALPHAB*R
                    AA2=ALPHAA*ALPHAA
                    AB2=ALPHAB*ALPHAB
                    DIFF=ABS(ALPHAA-ALPHAB)
C
C  ----  NOW CALCULATE ALL CHARGE-PENETRATION TERMS
                    CALL EPENCHCH(AP,BP,AA2,AB2,DIFF,P0_E,P0_N1,P0_N2)
                    P0(1)=P0_E
                    P0(2)=P0_N1
                    P0(3)=P0_N2
C  ---- WE NEED CHARGE-DIPOLE SCREENING PARAMS FOR CHARGE-CHARGE GRADS
                    CALL EPENCHDIP(AP,BP,AA2,AB2,DIFF,
     *                            P1_ECC,P1_N1CC,P1_N2CC)
                    IF(HOCHPEN)THEN
                    P1_E = P1_ECC
                    P1_N1 = P1_N1CC
                    P1_N2 = P1_N2CC
                    P1(1)=P1_E
                    P1(2)=P1_N1
                    P1(3)=P1_N2
                    CALL EPENCHQU(AP,BP,AA2,AB2,DIFF,R2,
     *                            P1D_E,P1D_N1,P1D_N2)
                    P2_E =  -P1D_E/R3
                    P2_N1 = -P1D_N1/R3
                    P2_N2 = -P1D_N2/R3
                    P1D(1)=P1D_E
                    P1D(2)=P1D_N1
                    P1D(3)=P1D_N2
                    P2(1)=P2_E
                    P2(2)=P2_N1
                    P2(3)=P2_N2
                    CALL EPENCHOCT(AP,BP,AA2,AB2,DIFF,R7,
     *                             P3_E,P3_N1,P3_N2)
                    P3(1)=P3_E
                    P3(2)=P3_N1
                    P3(3)=P3_N2
                    CALL EPENP4(AP,BP,AA2,AB2,DIFF,R2,P4)
                    CALL EPENP5(AP,BP,AA2,AB2,DIFF,R7,P5)
                    CALL EPENP6(AP,BP,AA2,AB2,DIFF,R9,P6)
                    END IF
                 END IF
C
C   ---- THIS PART IS FOR EFP1 FRAGMENT-FRAGMENT GAUSSIAN-LIKE SCREENING
C                 IF (ICHGP.EQ.1.AND.R.LE.ELEVEN) THEN
                 IF (ISCR.EQ.1 .AND. R.LE.SCROFF) THEN
                     DOGAUSS = .TRUE.
                     IF ((AI .EQ. ZERO) .OR. (CF1 .EQ. ZERO)) THEN
                         EX1 = ZERO
                         SCR1 = ZERO
                     ELSE
                         EX1 = EXP(-AI*R2)
                         SCR1 = - CF1*EX1
                     END IF
                     IF ((AJ .EQ. ZERO) .OR. (CF2 .EQ. ZERO)) THEN
                         EX2 = ZERO
                         SCR2 = ZERO
                     ELSE
                         EX2 = EXP(-AJ*R2)
                         SCR2 = - CF2*EX2
                     END IF
                 END IF
C
C  ---- PREPARATIONAL THINGS: ARRAYS ARE FOR COMMON /EFPELE/,
C  ---- VARIABLES FOR  CONVENIENT USE IN THIS FUNCTION
C  ---- ARRAY OF X*Y THINGS
               AXX(1) = X*X
               AXX(2) = Y*Y
               AXX(3) = Z*Z
               AXX(4) = X*Y
               AXX(5) = X*Z
               AXX(6) = Y*Z
               XX = AXX(1)
               YY = AXX(2)
               ZZ = AXX(3)
               XY = AXX(4)
               XZ = AXX(5)
               YZ = AXX(6)
C
               RMU1 = X*DX1 + Y*DY1 + Z*DZ1
               RMU2 = X*DX2 + Y*DY2 + Z*DZ2
               RMU(1) = RMU1
               RMU(2) = RMU2
C
C   ---- ARRAY OF X*Y*Z THINGS
               AXXX(1) = XX*X
               AXXX(2) = YY*Y
               AXXX(3) = ZZ*Z
               AXXX(4) = XX*Y
               AXXX(5) = XX*Z
               AXXX(6) = XY*Y
               AXXX(7) = YY*Z
               AXXX(8) = XZ*Z
               AXXX(9) = YZ*Z
               AXXX(10) = XY*Z
C
               XXX = AXXX(1)
               YYY = AXXX(2)
               ZZZ = AXXX(3)
               XXY = AXXX(4)
               XXZ = AXXX(5)
               XYY = AXXX(6)
               YYZ = AXXX(7)
               XZZ = AXXX(8)
               YZZ = AXXX(9)
               XYZ = AXXX(10)
C
               RRX = R2*X
               RRY = R2*Y
               RRZ = R2*Z
C
C   ----  T_AB TENSOR
               TT(1) = (THREE*XX-R2)/R5
               TT(2) = (THREE*YY-R2)/R5
               TT(3) = (THREE*ZZ-R2)/R5
               TT(4) = THREE*XY/R5
               TT(5) = THREE*XZ/R5
               TT(6) = THREE*YZ/R5
               TXX = TT(1)
               TYY = TT(2)
               TZZ = TT(3)
               TXY = TT(4)
               TXZ = TT(5)
               TYZ = TT(6)
C
C   ---- CHARGE-CHARGE & CHARGE-PENETRATION ENERGIES
                  EPAIRCC = EPAIRCC + Q11*Q22/R*F0
C
C   ---- CHARGE-PENETRATION
               IF(DOCHPEN) THEN
                  EPCHPCC = EPCHPCC + (ONE/R)*(Q1*Q2*P0_E +
     *                         Q1*Q2N*P0_N2 + Q2*Q1N*P0_N1)
               END IF
               IF (DOGAUSS) THEN
                  EPCHPCC=EPCHPCC+(Q1N*Q2*SCR2
     *                    +Q2N*Q1*SCR1+Q1*Q2*(SCR1+SCR2))/R
                  IF(CF1*CF2.NE.ZERO) THEN
                     EPCHPCC=EPCHPCC+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))
                  END IF
               END IF
C
C   ---- CHARGE-DIPOLE ENERGIES
C   ---- ATTENTION: BOTH CHARGE-DIPOLE AND DIPOLE CHARGE TERMS
C   ---- ARE NEEDED  BECAUSE WE SUM OVER I,J>I
C
               CD1 = ZERO
               CD2 = ZERO
               IF(DODIPO(IC1)) CD1 = Q22*RMU1
               IF(DODIPO(IC2)) CD2 = Q11*RMU2
               EPAIRCD = EPAIRCD + (CD2 - CD1)*F1_CD/R3
C               EPAIRCD = EPAIRCD + (Q11*RMU2-Q22*RMU1)*F1/R3
               IF(HOCHPEN) THEN
                  EPCHPCD = EPCHPCD + ((Q1*P1_E+Q1N*P1_N1)*RMU2-
     *                     (Q2*P1_E+Q2N*P1_N2)*RMU1)/R3
               END IF
               IF (DOGAUSS) THEN
                  PENCD1 = ZERO
                  PENCD2 = ZERO
                  IF(DODIPO(IC1)) PENCD1=Q22*SCR2*(ONE+TWO*AJ*R2)*RMU1
                  IF(DODIPO(IC2)) PENCD2=Q11*SCR1*(ONE+TWO*AI*R2)*RMU2
C                  EPCHPCD = EPCHPCD + (Q11*SCR1*(ONE+TWO*AI*R2)*RMU2-
C     *                      Q22*SCR2*(ONE+TWO*AJ*R2)*RMU1)/R3
                  EPCHPCD = EPCHPCD + (PENCD2-PENCD1)/R3
               END IF
C
C   ---- DIPOLE-DIPOLE ENERGIES
C   ---- CHARGE-PENETRATION IS INCORPORATED IN THE GENERAL FORMULA
               DUMJ = RMU2*THREE/R5
C
               DJFX = (-DX2/R3+X*DUMJ)*(F1_DD+P1_E)+X*RMU2*(F2_DD+P2_E)
               DJFY = (-DY2/R3+Y*DUMJ)*(F1_DD+P1_E)+Y*RMU2*(F2_DD+P2_E)
               DJFZ = (-DZ2/R3+Z*DUMJ)*(F1_DD+P1_E)+Z*RMU2*(F2_DD+P2_E)
C
               EPAIRDD = EPAIRDD -(DX1*DJFX+DY1*DJFY+DZ1*DJFZ)
C
C   ---- CHARGE-QUADRUPOLE ENERGIES
               CFXX = F1_CQ*TXX + F2_CQ*XX
               CFYY = F1_CQ*TYY + F2_CQ*YY
               CFZZ = F1_CQ*TZZ + F2_CQ*ZZ
               CFXY = F1_CQ*TXY + F2_CQ*XY
               CFXZ = F1_CQ*TXZ + F2_CQ*XZ
               CFYZ = F1_CQ*TYZ + F2_CQ*YZ
C
               CQ1 = ZERO
               CQ2 = ZERO
               IF(DOQUAD(IC1)) THEN
                  CQ1 = (QUAD1(1)*CFXX + QUAD1(2)*CFYY +
     *                QUAD1(3)*CFZZ + TWO*(QUAD1(4)*CFXY +
     *                QUAD1(5)*CFXZ + QUAD1(6)*CFYZ))*Q22
               END IF
               IF(DOQUAD(IC2)) THEN
                  CQ2 = (QUAD2(1)*CFXX + QUAD2(2)*CFYY +
     *                QUAD2(3)*CFZZ + TWO*(QUAD2(4)*CFXY +
     *                QUAD2(5)*CFXZ + QUAD2(6)*CFYZ))*Q11
               END IF
               EPAIRCQ = EPAIRCQ + (CQ1 + CQ2)/3.0D+00
C
               IF(HOCHPEN) THEN
                  CHPCQE = (TXX*P1_E+XX*P2_E)*(Q2*QUAD1(1)+
     *                     Q1*QUAD2(1)) +
     *                    (TYY*P1_E+YY*P2_E)*(Q2*QUAD1(2)+
     *                     Q1*QUAD2(2)) +
     *                    (TZZ*P1_E+ZZ*P2_E)*(Q2*QUAD1(3)+
     *                     Q1*QUAD2(3)) +
     *                    TWO*((TXY*P1_E+XY*P2_E)*(Q2*QUAD1(4)+
     *                     Q1*QUAD2(4)) +
     *                    (TXZ*P1_E+XZ*P2_E)*(Q2*QUAD1(5)+
     *                     Q1*QUAD2(5)) +
     *                    (TYZ*P1_E+YZ*P2_E)*(Q2*QUAD1(6)+
     *                     Q1*QUAD2(6)))
                  CHPCQ1N = Q1N*((TXX*P1_N1+XX*P2_N1)*QUAD2(1) +
     *                      (TYY*P1_N1+YY*P2_N1)*QUAD2(2) +
     *                      (TZZ*P1_N1+ZZ*P2_N1)*QUAD2(3) +
     *                      TWO*((TXY*P1_N1+XY*P2_N1)*QUAD2(4) +
     *                      (TXZ*P1_N1+XZ*P2_N1)*QUAD2(5) +
     *                      (TYZ*P1_N1+YZ*P2_N1)*QUAD2(6)))
                  CHPCQ2N = Q2N*((TXX*P1_N2+XX*P2_N2)*QUAD1(1) +
     *                      (TYY*P1_N2+YY*P2_N2)*QUAD1(2) +
     *                      (TZZ*P1_N2+ZZ*P2_N2)*QUAD1(3) +
     *                      TWO*((TXY*P1_N2+XY*P2_N2)*QUAD1(4) +
     *                      (TXZ*P1_N2+XZ*P2_N2)*QUAD1(5) +
     *                      (TYZ*P1_N2+YZ*P2_N2)*QUAD1(6)))
                  EPCHPCQ = EPCHPCQ + (CHPCQE+CHPCQ1N+CHPCQ2N)/THREE
               END IF
C
C   ---- CHARGE-OCTUPOLE ENERGIES
C   ---- ELECTROSTATIC SCREENING NOT DONE
               CFXXX = F1*THREE*(-FIVE*XXX+THREE*RRX)/R7 + TWO*F2*X -
     *                 F3*X*TXX - F4*XXX
               CFYYY = F1*THREE*(-FIVE*YYY+THREE*RRY)/R7 + TWO*F2*Y -
     *                 F3*Y*TYY - F4*YYY
               CFZZZ = F1*THREE*(-FIVE*ZZZ+THREE*RRZ)/R7 + TWO*F2*Z -
     *                 F3*Z*TZZ - F4*ZZZ
               CFXXY = F1*THREE*(-FIVE*XXY+RRY)/R7 + TWO*F2*Y -
     *                 F3*Y*TXX - F4*XXY
               CFXXZ = F1*THREE*(-FIVE*XXZ+RRZ)/R7 + TWO*F2*Z -
     *                 F3*Z*TXX - F4*XXZ
               CFXYY = F1*THREE*(-FIVE*XYY+RRX)/R7 + TWO*F2*X -
     *                 F3*X*TYY - F4*XYY
               CFYYZ = F1*THREE*(-FIVE*YYZ+RRZ)/R7 + TWO*F2*Z -
     *                 F3*Z*TYY - F4*YYZ
               CFXZZ = F1*THREE*(-FIVE*XZZ+RRX)/R7 + TWO*F2*X -
     *                 F3*X*TZZ - F4*XZZ
               CFYZZ = F1*THREE*(-FIVE*YZZ+RRY)/R7 + TWO*F2*Y -
     *                 F3*Y*TZZ - F4*YZZ
               CFXYZ = F1*THREE*(-FIVE*XYZ)/R7 - F4*XYZ
C
               CO1 = ZERO
               CO2 = ZERO
               IF(DOOCTU(IC1)) THEN
                   CO1 = (OCT1(1)*Q22)*CFXXX +
     *                   (OCT1(2)*Q22)*CFYYY +
     *                   (OCT1(3)*Q22)*CFZZZ +
     *             THREE*((OCT1(4)*Q22)*CFXXY +
     *                   (OCT1(5)*Q22)*CFXXZ +
     *                   (OCT1(6)*Q22)*CFXYY +
     *                   (OCT1(7)*Q22)*CFYYZ +
     *                   (OCT1(8)*Q22)*CFXZZ +
     *                   (OCT1(9)*Q22)*CFYZZ) +
     *               SIX*(OCT1(10)*Q22)*CFXYZ
               END IF
               IF(DOOCTU(IC2)) THEN
                   CO2 = (OCT2(1)*Q11)*CFXXX +
     *                   (OCT2(2)*Q11)*CFYYY +
     *                   (OCT2(3)*Q11)*CFZZZ +
     *            THREE*((OCT2(4)*Q11)*CFXXY +
     *                   (OCT2(5)*Q11)*CFXXZ +
     *                   (OCT2(6)*Q11)*CFXYY +
     *                   (OCT2(7)*Q11)*CFYYZ +
     *                   (OCT2(8)*Q11)*CFXZZ +
     *                   (OCT2(9)*Q11)*CFYZZ) +
     *               SIX*(OCT2(10)*Q11)*CFXYZ
               END IF
               EPAIRCO = EPAIRCO+(CO1-CO2)/15.0D+00
C
C   ---- THIS CODE IS FORMALLY CORRECT, BUT PRODUCES WRONG ANSWER
C   ---- DUE TO NUMERICAL NOISE. BE CAREFUL.  LVS
C               ECHOCT = (OCT1(1)*Q22-OCT2(1)*Q11)*CFXXX +
C     *                   (OCT1(2)*Q22-OCT2(2)*Q11)*CFYYY +
C     *                   (OCT1(3)*Q22-OCT2(3)*Q11)*CFZZZ +
C     *            THREE*((OCT1(4)*Q22-OCT2(4)*Q11)*CFXXY +
C     *                   (OCT1(5)*Q22-OCT2(5)*Q11)*CFXXZ +
C     *                   (OCT1(6)*Q22-OCT2(6)*Q11)*CFXYY +
C     *                   (OCT1(7)*Q22-OCT2(7)*Q11)*CFYYZ +
C     *                   (OCT1(8)*Q22-OCT2(8)*Q11)*CFXZZ +
C     *                   (OCT1(9)*Q22-OCT2(9)*Q11)*CFYZZ) +
C     *               SIX*(OCT1(10)*Q22-OCT2(10)*Q11)*CFXYZ
C               EPAIRCO = EPAIRCO+ECHOCT/15.0D+00
C
C   ---- DIPOLE-QUADRUPOLE ENERGIES
               EDPQUD = ZERO
               IF ((DODIPO(IC1) .AND. DOQUAD(IC2)) .OR.
     *            (DODIPO(IC2) .AND. DOQUAD(IC1))) THEN
                  CALL EDPQUAD(X,Y,Z,EDPQUD)
               END IF
               EPAIRDQ = EPAIRDQ + EDPQUD
C
C   ---- QUADRUPOLE-QUADRUPOLE ENERGIES: NO SCREENING SO FAR
C
               QUAD = ZERO
               IF (DOQUAD(IC1) .AND. DOQUAD(IC2)) THEN
               QUQU = QUAD1(1)*QUAD2(1)+QUAD1(2)*QUAD2(2)+
     *              QUAD1(3)*QUAD2(3)+TWO*(QUAD1(4)*QUAD2(4)+
     *              QUAD1(5)*QUAD2(5)+QUAD1(6)*QUAD2(6))
C
               QUARR1 = XX*QUAD1(1)+YY*QUAD1(2)+ZZ*QUAD1(3)+
     *             TWO*(XY*QUAD1(4)+XZ*QUAD1(5)+YZ*QUAD1(6))
               QUARR2 = XX*QUAD2(1)+YY*QUAD2(2)+ZZ*QUAD2(3)+
     *             TWO*(XY*QUAD2(4)+XZ*QUAD2(5)+YZ*QUAD2(6))
C
               QUAX1 = X*QUAD1(1)+Y*QUAD1(4)+Z*QUAD1(5)
               QUAY1 = Y*QUAD1(2)+X*QUAD1(4)+Z*QUAD1(6)
               QUAZ1 = Z*QUAD1(3)+X*QUAD1(5)+Y*QUAD1(6)
               QUAX2 = X*QUAD2(1)+Y*QUAD2(4)+Z*QUAD2(5)
               QUAY2 = Y*QUAD2(2)+X*QUAD2(4)+Z*QUAD2(6)
               QUAZ2 = Z*QUAD2(3)+X*QUAD2(5)+Y*QUAD2(6)
               QQRR = QUAX1*QUAX2 + QUAY1*QUAY2 + QUAZ1*QUAZ2
C
C   ----  ORIGINAL QUADRUPOLE-QUADRUPOLE TERM
               QUAD = SIX*QUQU/R5 - 60.0D+00*QQRR/R7 +
     *                105.0D+00*QUARR1*QUARR2/R9
C
C   ---- THESE WILL BE USED FOR EWALD SUMS
               IF (IFEWLD .AND. LEVEL.GT.6) THEN
               QUAT1 = TXX*QUAD1(1)+TYY*QUAD1(2)+TZZ*QUAD1(3)+
     *             TWO*(TXY*QUAD1(4)+TXZ*QUAD1(5)+TYZ*QUAD1(6))
               QUAT2 = TXX*QUAD2(1)+TYY*QUAD2(2)+TZZ*QUAD2(3)+
     *             TWO*(TXY*QUAD2(4)+TXZ*QUAD2(5)+TYZ*QUAD2(6))
C
C   ----   QUA_AB R_A T_BCD QUA_CD
C   ----   THIS IS SIMILAR TO DIPOLE-QUADRUPOLE TERMS
               TMPXX1 = (TWO*QUAX2*X)*DUM - FIFTEN*XX*QUARR2/R7
               TMPYY1 = (TWO*QUAY2*Y)*DUM - FIFTEN*YY*QUARR2/R7
               TMPZZ1 = (TWO*QUAZ2*Z)*DUM - FIFTEN*ZZ*QUARR2/R7
               TMPXY1 = (QUAX2*Y+QUAY2*X)*DUM - FIFTEN*XY*QUARR2/R7
               TMPXZ1 = (QUAX2*Z+QUAZ2*X)*DUM - FIFTEN*XZ*QUARR2/R7
               TMPYZ1 = (QUAY2*Z+QUAZ2*Y)*DUM - FIFTEN*YZ*QUARR2/R7
               QRTQ1 = QUAD1(1)*TMPXX1 + QUAD1(2)*TMPYY1 +
     *                 QUAD1(3)*TMPZZ1 + TWO*(QUAD1(4)*TMPXY1 +
     *                 QUAD1(5)*TMPXZ1 + QUAD1(6)*TMPYZ1)
C
               TMPXX2 = (TWO*QUAX1*X)*DUM - FIFTEN*XX*QUARR1/R7
               TMPYY2 = (TWO*QUAY1*Y)*DUM - FIFTEN*YY*QUARR1/R7
               TMPZZ2 = (TWO*QUAZ1*Z)*DUM - FIFTEN*ZZ*QUARR1/R7
               TMPXY2 = (QUAX1*Y+QUAY1*X)*DUM - FIFTEN*XY*QUARR1/R7
               TMPXZ2 = (QUAX1*Z+QUAZ1*X)*DUM - FIFTEN*XZ*QUARR1/R7
               TMPYZ2 = (QUAY1*Z+QUAZ1*Y)*DUM - FIFTEN*YZ*QUARR1/R7
               QRTQ2 = QUAD2(1)*TMPXX2 + QUAD2(2)*TMPYY2 +
     *                 QUAD2(3)*TMPZZ2 + TWO*(QUAD2(4)*TMPXY2 +
     *                 QUAD2(5)*TMPXZ2 + QUAD2(6)*TMPYZ2)
C
C   ----  EWALD QUAD-QUAD. DIRECT TERM
               EPAIRQQ = EPAIRQQ+(F1*QUAD+TWO*F2*QUQU-F3*(QRTQ1+QRTQ2)-
     *                   TWO*F4*QQRR-TWO*F4*QQRR+
     *                   F5*PT5*(QUARR1*QUAT2+QUARR2*QUAT1)+
     *                   F6*QUARR1*QUARR2) / 9.00D+00
C
               END IF
               END IF
               EPAIRQQ = EPAIRQQ+QUAD/ 9.00D+00
C
C
C   ----   NOW GRADIENTS
               IF (QGRAD) THEN
C               IF (.TRUE.) THEN
C
C   ----  CHARGE-CHARGE
                  CONCC=F0_GRAD*Q11*Q22/R3
                  DCCSCR=ZERO
C
C   ---- ELECTR. SCREENING
                  IF(DOCHPEN) THEN
                     DCCSCR = (Q1*Q2*P1_ECC+Q1N*Q2*P1_N1CC+
     *                        Q2N*Q1*P1_N2CC)/R3
                  END IF
                  IF(DOGAUSS) THEN
                     DCCSCR=(Q1N*Q2*SCR2+Q2N*Q1*SCR1+
     *                      Q2*Q1*(SCR1+SCR2))/R3
                     IF(CF1*CF2.NE.ZERO) THEN
                        DCCSCR=DCCSCR+Q1*Q2*CF1*CF2*(AI*EX1+AJ*EX2)/
     *                         (AIJ*R3) +
     *                         TWO*(Q1*(Q2+Q2N)*AI*SCR1+
     *                             Q2*(Q1+Q1N)*AJ*SCR2)/R +
     *                         TWO*Q1*Q2*CF1*CF2*
     *                         (AI*AI*EX1+AJ*AJ*EX2)/(AIJ*R)
C
                     TMP =AI*AJ*SQRT(PI/AIJ**3)*EXP(-R2*AI*AJ/AIJ)
                     DCCSCR=DCCSCR+Q1*Q2*CF1*CF2*TMP
     *                 *((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
                  END IF
C
                  CONCCX=(CONCC+DCCSCR)*X
                  CONCCY=(CONCC+DCCSCR)*Y
                  CONCCZ=(CONCC+DCCSCR)*Z
C
C
C   ---- CHARGE-DIPOLE
                  CFR1 = ZERO
                  CFR2 = ZERO
                  CN1 = ZERO
                  CN2 = ZERO
                  IF (DODIPO(IC1)) THEN
                     CFR1 = (Q22*F1_CD)/R3
                     CN1 = RMU1*Q22*(F1_CD*THREE/R5+F1_GRAD)
                  END IF
                  IF (DODIPO(IC2)) THEN
                     CFR2 = (Q11*F1_CD)/R3
                     CN2 = RMU2*Q11*(F1_CD*THREE/R5+F1_GRAD)
                  END IF
C
C   ---- SCREENING
                  CFRSCR1 = ZERO
                  CFRSCR2 = ZERO
                  CNSCR1 = ZERO
                  CNSCR2 = ZERO
                  IF(HOCHPEN) THEN
                     CFRSCR1 = (+P1_E*Q2+P1_N2*Q2N)/R3
                     CFRSCR2 = (+P1_E*Q1+P1_N1*Q1N)/R3
                     CNSCR1 = RMU1*(THREE/R5*Q2*P1_E+Q2*P2_E+
     *                        THREE/R5*Q2N*P1_N2+Q2N*P2_N2)
                     CNSCR2 = RMU2*(THREE/R5*Q1*P1_E+Q1*P2_E+
     *                        THREE/R5*Q1N*P1_N1+Q1N*P2_N1)
                  END IF
                  IF (DOGAUSS) THEN
                     IF (DODIPO(IC1)) THEN
                     CFRSCR1 = Q22*SCR2*(1+TWO*AJ*R2)/R3
                     CNSCR1 =(THREE*SCR2/R5+
     *                      4.0D+00*AJ*SCR2*(ONE/R3 + AJ/R))*RMU1*Q22
                     END IF
                     IF (DODIPO(IC2)) THEN
                     CFRSCR2 = Q11*SCR1*(1+TWO*AI*R2)/R3
                     CNSCR2 =(THREE*SCR1/R5+
     *                      4.0D+00*AI*SCR1*(ONE/R3 + AI/R))*RMU2*Q11
                     END IF
                  END IF
                  IF (DOGAUSS .OR. HOCHPEN) THEN
                     CFR1 = CFR1 + CFRSCR1
                     CFR2 = CFR2 + CFRSCR2
                     CN1 = CN1 + CNSCR1
                     CN2 = CN2 + CNSCR2
                  END IF
C
                  CONCDX = DX1*CFR1 - DX2*CFR2 - X*(CN1-CN2)
                  CONCDY = DY1*CFR1 - DY2*CFR2 - Y*(CN1-CN2)
                  CONCDZ = DZ1*CFR1 - DZ2*CFR2 - Z*(CN1-CN2)
C
C   ---- THIS IS FOR TORQUE
                  TIMCDX= CFR1*(DY1*Z-DZ1*Y)
                  TIMCDY= CFR1*(DZ1*X-DX1*Z)
                  TIMCDZ= CFR1*(DX1*Y-DY1*X)
C
                  TJMCDX= CFR2*(DY2*Z-DZ2*Y)
                  TJMCDY= CFR2*(DZ2*X-DX2*Z)
                  TJMCDZ= CFR2*(DX2*Y-DY2*X)
C
C
C   ----  GRADIENTS FOR DIPOLE-DIPOLE AND CHARGE-QUAD TREMS BEGIN HERE
C
C   ---- THIS IS T_A(BC), SIMILAR FOR CHARGE-QUADR. AND DIPOLE-DIPOLE
C   ---- GRADIENT TERMS
C   -----    FOR DIPOLE-DIPOLE PART
                      DDCFXX = F1_DD*THREE*(-FIVE*XX+R2)/R7 - F3_DD*TXX
     *                        - F4_DD*XX
                      DDCFYY = F1_DD*THREE*(-FIVE*YY+R2)/R7 - F3_DD*TYY
     *                        - F4_DD*YY
                      DDCFZZ = F1_DD*THREE*(-FIVE*ZZ+R2)/R7 - F3_DD*TZZ
     *                        - F4_DD*ZZ
                      DDCFXY = F1_DD*THREE*(-FIVE*XY)/R7 - F3_DD*TXY
     *                        - F4_DD*XY
                      DDCFXZ = F1_DD*THREE*(-FIVE*XZ)/R7 - F3_DD*TXZ
     *                        - F4_DD*XZ
                      DDCFYZ = F1_DD*THREE*(-FIVE*YZ)/R7 - F3_DD*TYZ
     *                        - F4_DD*YZ
C
C   -----    FOR CHARGE-QUAD PART
                      DCFXX = F1_CQ*THREE*(-FIVE*XX+R2)/R7 - F3_CQ*TXX
     *                        - F4_CQ*XX
                      DCFYY = F1_CQ*THREE*(-FIVE*YY+R2)/R7 - F3_CQ*TYY
     *                        - F4_CQ*YY
                      DCFZZ = F1_CQ*THREE*(-FIVE*ZZ+R2)/R7 - F3_CQ*TZZ
     *                        - F4_CQ*ZZ
                      DCFXY = F1_CQ*THREE*(-FIVE*XY)/R7 - F3_CQ*TXY
     *                        - F4_CQ*XY
                      DCFXZ = F1_CQ*THREE*(-FIVE*XZ)/R7 - F3_CQ*TXZ
     *                        - F4_CQ*XZ
                      DCFYZ = F1_CQ*THREE*(-FIVE*YZ)/R7 - F3_CQ*TYZ
     *                        - F4_CQ*YZ
C
C   ----  DCQ DOES NOT INCLUDE THE SCREENING
            DCQ1 = ZERO
            DCQ2 = ZERO
            IF (DOQUAD(IC1)) THEN
            DCQ1 = (QUAD1(1)*DCFXX + QUAD1(2)*DCFYY +
     *             QUAD1(3)*DCFZZ + TWO*(QUAD1(4)*DCFXY +
     *             QUAD1(5)*DCFXZ + QUAD1(6)*DCFYZ))*Q22/3.0D+00
            END IF
            IF (DOQUAD(IC2)) THEN
            DCQ2 = (QUAD2(1)*DCFXX + QUAD2(2)*DCFYY +
     *             QUAD2(3)*DCFZZ + TWO*(QUAD2(4)*DCFXY +
     *             QUAD2(5)*DCFXZ + QUAD2(6)*DCFYZ))*Q11/3.0D+00
            END IF
            DCQ = DCQ1 + DCQ2
C
C  ----   SCREENING FOR DIPOLE-DIPOLE GRADIENTS
            PEN1CQ=ZERO
            PEN2CQ=ZERO
            DDDXX = ZERO
            DDDYY = ZERO
            DDDZZ = ZERO
            DDDXY = ZERO
            DDDXZ = ZERO
            DDDYZ = ZERO
C
            IF(HOCHPEN) THEN
                      DDDXX = P1_E*THREE*(-FIVE*XX+R2)/R7 + P1D_E*TXX
     *                     + P3_E*XX
                      DDDYY = P1_E*THREE*(-FIVE*YY+R2)/R7 + P1D_E*TYY
     *                     + P3_E*YY
                      DDDZZ = P1_E*THREE*(-FIVE*ZZ+R2)/R7 + P1D_E*TZZ
     *                     + P3_E*ZZ
                      DDDXY = P1_E*THREE*(-FIVE*XY)/R7 + P1D_E*TXY
     *                     + P3_E*XY
                      DDDXZ = P1_E*THREE*(-FIVE*XZ)/R7 + P1D_E*TXZ
     *                     + P3_E*XZ
                      DDDYZ = P1_E*THREE*(-FIVE*YZ)/R7 + P1D_E*TYZ
     *                     + P3_E*YZ
C
C  ----   SOME INTERMEDIATES FOR SCREENING PART IN CHARGE-QUAD TERMS
            P1_Q1 = P1_E*Q1+P1_N1*Q1N
            P1D_Q1 = P1D_E*Q1+P1D_N1*Q1N
            P3_Q1  = P3_E*Q1+P3_N1*Q1N
            P1_Q2 = P1_E*Q2+P1_N2*Q2N
            P1D_Q2 = P1D_E*Q2+P1D_N2*Q2N
            P3_Q2  = P3_E*Q2+P3_N2*Q2N
C
                  PEN1CFXX = P1_Q1*THREE*(-FIVE*XX+R2)/R7 + P1D_Q1*TXX
     *                     + P3_Q1*XX
                  PEN1CFYY = P1_Q1*THREE*(-FIVE*YY+R2)/R7 + P1D_Q1*TYY
     *                     + P3_Q1*YY
                  PEN1CFZZ = P1_Q1*THREE*(-FIVE*ZZ+R2)/R7 + P1D_Q1*TZZ
     *                     + P3_Q1*ZZ
                  PEN1CFXY = P1_Q1*THREE*(-FIVE*XY)/R7 + P1D_Q1*TXY
     *                     + P3_Q1*XY
                  PEN1CFXZ = P1_Q1*THREE*(-FIVE*XZ)/R7 + P1D_Q1*TXZ
     *                     + P3_Q1*XZ
                  PEN1CFYZ = P1_Q1*THREE*(-FIVE*YZ)/R7 + P1D_Q1*TYZ
     *                     + P3_Q1*YZ
C
                  PEN2CFXX = P1_Q2*THREE*(-FIVE*XX+R2)/R7 + P1D_Q2*TXX
     *                     + P3_Q2*XX
                  PEN2CFYY = P1_Q2*THREE*(-FIVE*YY+R2)/R7 + P1D_Q2*TYY
     *                     + P3_Q2*YY
                  PEN2CFZZ = P1_Q2*THREE*(-FIVE*ZZ+R2)/R7 + P1D_Q2*TZZ
     *                     + P3_Q2*ZZ
                  PEN2CFXY = P1_Q2*THREE*(-FIVE*XY)/R7 + P1D_Q2*TXY
     *                     + P3_Q2*XY
                  PEN2CFXZ = P1_Q2*THREE*(-FIVE*XZ)/R7 + P1D_Q2*TXZ
     *                     + P3_Q2*XZ
                  PEN2CFYZ = P1_Q2*THREE*(-FIVE*YZ)/R7 + P1D_Q2*TYZ
     *                     + P3_Q2*YZ
C
C   ----  CORRESPONDING TERMS WITH SCREENING ARE HERE
                  PEN1CQ = ONE/THREE*(QUAD2(1)*PEN1CFXX
     *                  + QUAD2(2)*PEN1CFYY
     *                  + QUAD2(3)*PEN1CFZZ
     *                  + TWO*(QUAD2(4)*PEN1CFXY
     *                  + QUAD2(5)*PEN1CFXZ +QUAD2(6)*PEN1CFYZ))
C
                  PEN2CQ = ONE/THREE*(QUAD1(1)*PEN2CFXX
     *                  + QUAD1(2)*PEN2CFYY
     *                  + QUAD1(3)*PEN2CFZZ
     *                  + TWO*(QUAD1(4)*PEN2CFXY
     *                  + QUAD1(5)*PEN2CFXZ +QUAD1(6)*PEN2CFYZ))
            END IF
C
C   ---- MORE INTERMEDIATE TERMS
                  QUA1X = QUAD1(1)*X+QUAD1(4)*Y+QUAD1(5)*Z
                  QUA1Y = QUAD1(4)*X+QUAD1(2)*Y+QUAD1(6)*Z
                  QUA1Z = QUAD1(5)*X+QUAD1(6)*Y+QUAD1(3)*Z
                  QUA2X = QUAD2(1)*X+QUAD2(4)*Y+QUAD2(5)*Z
                  QUA2Y = QUAD2(4)*X+QUAD2(2)*Y+QUAD2(6)*Z
                  QUA2Z = QUAD2(5)*X+QUAD2(6)*Y+QUAD2(3)*Z
C
C   ----  SOME MORE SCREENING FACTORS FOR CHARGE-QUAD
C         AND DIPOLE-DIPOLE GRADS
                  FACTDD = TWO*(F1_DD*THREE/R5+F2_DD)
                  FACTCQ = TWO*(F1_CQ*THREE/R5+F2_CQ)
                  CHPCQE = TWO*(P1_E*THREE/R5+P2_E)
                  CHPCQN1 = TWO*(P1_N1*THREE/R5+P2_N1)
                  CHPCQN2 = TWO*(P1_N2*THREE/R5+P2_N2)
                  COEF2 = FACTCQ*Q22+CHPCQE*Q2+CHPCQN2*Q2N
                  COEF1 = FACTCQ*Q11+CHPCQE*Q1+CHPCQN1*Q1N
C
                  TIMX = COEF2*QUA1X/THREE
                  TIMY = COEF2*QUA1Y/THREE
                  TIMZ = COEF2*QUA1Z/THREE
C
                  TJMX = COEF1*QUA2X/THREE
                  TJMY = COEF1*QUA2Y/THREE
                  TJMZ = COEF1*QUA2Z/THREE
C
C   ---- THESE ARE FINAL EXPRESSIONS FOR GRADIENTS AND TORQUES
                  CONCQX = -(TIMX + TJMX + (DCQ+PEN1CQ+PEN2CQ)*X)
                  CONCQY = -(TIMY + TJMY + (DCQ+PEN1CQ+PEN2CQ)*Y)
                  CONCQZ = -(TIMZ + TJMZ + (DCQ+PEN1CQ+PEN2CQ)*Z)
C
                  TIMCQX = Y*TIMZ - Z*TIMY
                  TIMCQY = Z*TIMX - X*TIMZ
                  TIMCQZ = X*TIMY - Y*TIMX
                  TJMCQX = Y*TJMZ - Z*TJMY
                  TJMCQY = Z*TJMX - X*TJMZ
                  TJMCQZ = X*TJMY - Y*TJMX
C
C   ---- DIPOLE-DIPOLE GRADIENTS
C
                  DMX = (FACTDD+CHPCQE)*(DX1*DX2*X+PT5*(DX1*DY2+
     *                    DY1*DX2)*Y+PT5*(DX1*DZ2+DZ1*DX2)*Z)
                  DMY = (FACTDD+CHPCQE)*(DY1*DY2*Y+PT5*(DX1*DY2+
     *                    DY1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Z)
                  DMZ = (FACTDD+CHPCQE)*(DZ1*DZ2*Z+PT5*(DX1*DZ2+
     *                    DZ1*DX2)*X+PT5*(DY1*DZ2+DZ1*DY2)*Y)
C
                  DDD = DX1*DX2*(DDCFXX+DDDXX) + DY1*DY2*(DDCFYY+DDDYY)+
     *                   DZ1*DZ2*(DDCFZZ+DDDZZ) +
     *                  (DX1*DY2+DY1*DX2)*(DDCFXY+DDDXY) +
     *                  (DX1*DZ2+DZ1*DX2)*(DDCFXZ+DDDXZ) +
     *                  (DY1*DZ2+DZ1*DY2)*(DDCFYZ+DDDYZ)
C
                  CONDDX = (DMX + DDD*X)
                  CONDDY = (DMY + DDD*Y)
                  CONDDZ = (DMZ + DDD*Z)
C                  IF(IM.EQ.1 .OR. JM.EQ.1) THEN
C                  WRITE (6,*)'DMX=',DMX,'DDD=',DDD
C                  END IF
C
C  --- THIS IS MU_1 PART, ANALOGUES TO DJFX DIPOLE-DIPOLE ENERGY TERMS
                DUMI = RMU1*THREE/R5
                DIFX = (-DX1/R3+X*DUMI)*(F1_DD+P1_E)+X*RMU1*(F2_DD+P2_E)     
                DIFY = (-DY1/R3+Y*DUMI)*(F1_DD+P1_E)+Y*RMU1*(F2_DD+P2_E)
                DIFZ = (-DZ1/R3+Z*DUMI)*(F1_DD+P1_E)+Z*RMU1*(F2_DD+P2_E)
C
C  ---- TORQUES
                  TJMDDX=DY2*DIFZ-DZ2*DIFY
                  TJMDDY=DZ2*DIFX-DX2*DIFZ
                  TJMDDZ=DX2*DIFY-DY2*DIFX
                  TIMDDX=DY1*DJFZ-DZ1*DJFY
                  TIMDDY=DZ1*DJFX-DX1*DJFZ
                  TIMDDZ=DX1*DJFY-DY1*DJFX
C
C  ---- END OF DIPOLE-DIPOLE GRADIENTS
C
C  ---- CHARGE-OCTOPOLE GRADIENTS
                  CALL GRCHOCT(X,Y,Z,DOOCTU(IC1),DOOCTU(IC2),
     *                        GRADCO,TORQICO,TORQJCO)
C  ---- DIPOLE-QUAD GRADS
                  CALL VCLR(GRADDQ,1,3)
                  CALL VCLR(TORQIDQ,1,3)
                  CALL VCLR(TORQJDQ,1,3)
                  IF ((DODIPO(IC1) .AND. DOQUAD(IC2)) .OR.
     *                (DODIPO(IC2) .AND. DOQUAD(IC1))) THEN
                      CALL GRDPQUAD(X,Y,Z,GRADDQ,TORQIDQ,TORQJDQ)
                  END IF
C
C  ---- QUAD-QUAD GRADS
                  CALL VCLR(GRADQQ,1,3)
                  CALL VCLR(TORQIQQ,1,3)
                  CALL VCLR(TORQJQQ,1,3)
                  IF (DOQUAD(IC1) .AND. DOQUAD(IC2)) THEN
                     CALL GRQUQU(X,Y,Z,GRADQQ,TORQIQQ,TORQJQQ)
                  END IF
C
C   ----  THESE ARE TOTAL FORCES AND TORQUES
                IF (IFEWLD) THEN
                  IF (LEVEL .EQ. 3) THEN
                  CONX = CONCCX + CONCDX + CONCQX + CONDDX
                  CONY = CONCCY + CONCDY + CONCQY + CONDDY 
                  CONZ = CONCCZ + CONCDZ + CONCQZ + CONDDZ 
                  TIMX = TIMCDX + TIMCQX + TIMDDX 
                  TIMY = TIMCDY + TIMCQY + TIMDDY 
                  TIMZ = TIMCDZ + TIMCQZ + TIMDDZ 
                  TJMX = TJMCDX - TJMCQX - TJMDDX 
                  TJMY = TJMCDY - TJMCQY - TJMDDY 
                  TJMZ = TJMCDZ - TJMCQZ - TJMDDZ 
                  ELSE IF (LEVEL .EQ. 2) THEN
                  CONX = CONCCX + CONCDX + CONDDX + SWF*CONCQX 
                  CONY = CONCCY + CONCDY + CONDDY + SWF*CONCQY  
                  CONZ = CONCCZ + CONCDZ + CONDDZ + SWF*CONCQZ 
                  TIMX = TIMCDX + TIMDDX + SWF*TIMCQX 
                  TIMY = TIMCDY + TIMDDY + SWF*TIMCQY 
                  TIMZ = TIMCDZ + TIMDDZ + SWF*TIMCQZ 
                  TJMX = TJMCDX - TJMDDX - SWF*TJMCQX 
                  TJMY = TJMCDY - TJMDDY - SWF*TJMCQY 
                  TJMZ = TJMCDZ - TJMDDZ - SWF*TJMCQZ
                  ELSE IF (LEVEL .EQ. 1) THEN
                  CONX = CONCCX + SWF*(CONCDX + CONCQX + CONDDX)
                  CONY = CONCCY + SWF*(CONCDY + CONCQY + CONDDY) 
                  CONZ = CONCCZ + SWF*(CONCDZ + CONCQZ + CONDDZ) 
                  END IF
                ELSE 
                  CONX = SWF*(CONCCX + CONCDX + CONCQX + CONDDX)
                  CONY = SWF*(CONCCY + CONCDY + CONCQY + CONDDY) 
                  CONZ = SWF*(CONCCZ + CONCDZ + CONCQZ + CONDDZ) 
                END IF
                CONX = CONX + SWF*(GRADCO(1) + GRADDQ(1) + GRADQQ(1))
                CONY = CONY + SWF*(GRADCO(2) + GRADDQ(2) + GRADQQ(2))
                CONZ = CONZ + SWF*(GRADCO(3) + GRADDQ(3) + GRADQQ(3))
C
                IF (.NOT. IFEWLD .OR. (IFEWLD .AND. LEVEL .EQ. 1)) THEN
                   TIMX = SWF*(TIMCDX + TIMCQX + TIMDDX )
                   TIMY = SWF*(TIMCDY + TIMCQY + TIMDDY )
                   TIMZ = SWF*(TIMCDZ + TIMCQZ + TIMDDZ )
                   TJMX = SWF*(TJMCDX - TJMCQX - TJMDDX )
                   TJMY = SWF*(TJMCDY - TJMCQY - TJMDDY )
                   TJMZ = SWF*(TJMCDZ - TJMCQZ - TJMDDZ )
                END IF
                TIMX=TIMX + SWF*(
     *              TORQICO(1) + TORQIDQ(1) - TORQIQQ(1))
                TIMY=TIMY + SWF*(
     *              TORQICO(2) +  TORQIDQ(2) - TORQIQQ(2))
                TIMZ=TIMZ + SWF*(
     *              TORQICO(3) +  TORQIDQ(3) - TORQIQQ(3))
                TJMX=TJMX + SWF*(
     *              TORQJCO(1) + TORQJDQ(1) + TORQJQQ(1))
                TJMY=TJMY + SWF*(
     *              TORQJCO(2) +  TORQJDQ(2) + TORQJQQ(2))
                TJMZ=TJMZ +SWF*(
     *              TORQJCO(3) + TORQJDQ(3) + TORQJQQ(3))
                
C
C   ----  TOTAL TORQUES DUE TO MOMENTS
C                TIMX=TIMCDX + TIMCQX + TIMDDX +
C     *              TORQICO(1) + TORQIDQ(1) - TORQIQQ(1)
C                TIMY=TIMCDY + TIMCQY + TIMDDY +
C     *              TORQICO(2) +  TORQIDQ(2) - TORQIQQ(2)
C                TIMZ=TIMCDZ + TIMCQZ + TIMDDZ +
C     *              TORQICO(3) +  TORQIDQ(3) - TORQIQQ(3)
C                TJMX=TJMCDX - TJMCQX - TJMDDX +
C     *              TORQJCO(1) + TORQJDQ(1) + TORQJQQ(1)
C                TJMY=TJMCDY - TJMCQY - TJMDDY +
C     *              TORQJCO(2) +  TORQJDQ(2) + TORQJQQ(2)
C                TJMZ=TJMCDZ - TJMCQZ - TJMDDZ +
C     *              TORQJCO(3) + TORQJDQ(3) + TORQJQQ(3)
C
C  ---- THIS IS FOR DEBUGGING TORQUES AND GRADIENTS.
C  PLEASE DO NOT REMOVE IT, EVEN THOUGH IT IS IMPOSSIBLE TO EXECUTE IT
            IF(IW.EQ.-328) THEN
C
               IF(IM.EQ.1 .OR. JM.EQ.1) THEN
                GCC(1) = GCC(1) + CONCCX
                GCC(2) = GCC(2) + CONCCY
                GCC(3) = GCC(3) + CONCCZ
                GCD(1) = GCD(1) + CONCDX
                GCD(2) = GCD(2) + CONCDY
                GCD(3) = GCD(3) + CONCDZ
                GCQ(1) = GCQ(1) + CONCQX
                GCQ(2) = GCQ(2) + CONCQY
                GCQ(3) = GCQ(3) + CONCQZ
                GDD(1) = GDD(1) + CONDDX
                GDD(2) = GDD(2) + CONDDY
                GDD(3) = GDD(3) + CONDDZ
                DO I=1,3
                   GCO(I) = GCO(I) + GRADCO(I)
                   GDQ(I) = GDQ(I) + GRADDQ(I)
                   GQQ(I) = GQQ(I) + GRADQQ(I)
                END DO
C
                CDXJ = GRADQQ(3)*(EFC(2,IC2)-EFCENT(2,JM))
     *             -GRADQQ(2)*(EFC(3,IC2)-EFCENT(3,JM))
                CDYJ = GRADQQ(1)*(EFC(3,IC2)-EFCENT(3,JM))
     *             -GRADQQ(3)*(EFC(1,IC2)-EFCENT(1,JM))
                CDZJ = GRADQQ(2)*(EFC(1,IC2)-EFCENT(1,JM))
     *             -GRADQQ(1)*(EFC(2,IC2)-EFCENT(2,JM))
                CDXI = GRADQQ(3)*(EFC(2,IC1)-EFCENT(2,IM))
     *             -GRADQQ(2)*(EFC(3,IC1)-EFCENT(3,IM))
                CDYI = GRADQQ(1)*(EFC(3,IC1)-EFCENT(3,IM))
     *             -GRADQQ(3)*(EFC(1,IC1)-EFCENT(1,IM))
                CDZI = GRADQQ(2)*(EFC(1,IC1)-EFCENT(1,IM))
     *             -GRADQQ(1)*(EFC(2,IC1)-EFCENT(2,IM))
C
                TICD(1) = TICD(1) - CDXI - TIMCDX
                TICD(2) = TICD(2) - CDYI - TIMCDY
                TICD(3) = TICD(3) - CDZI - TIMCDZ
                TJCD(1) = TJCD(1) + CDXJ  + TJMCDX
                TJCD(2) = TJCD(2) + CDYJ  + TJMCDY
                TJCD(3) = TJCD(3) + CDZJ  + TJMCDZ
C
                TIDD(1) = TIDD(1) - CDXI - TIMDDX
                TIDD(2) = TIDD(2) - CDYI - TIMDDY
                TIDD(3) = TIDD(3) - CDZI - TIMDDZ
                TJDD(1) = TJDD(1) + CDXJ - TJMDDX
                TJDD(2) = TJDD(2) + CDYJ - TJMDDY
                TJDD(3) = TJDD(3) + CDZJ - TJMDDZ
C
                TICQ(1) = TICQ(1) -CDXI - TIMCQX
                TICQ(2) = TICQ(2) -CDYI - TIMCQY
                TICQ(3) = TICQ(3) -CDZI - TIMCQZ
                TJCQ(1) = TJCQ(1) +CDXJ - TJMCQX
                TJCQ(2) = TJCQ(2) +CDYJ - TJMCQY
                TJCQ(3) = TJCQ(3) +CDZJ - TJMCQZ
C
                TICO(1) = TICO(1) -CDXI - TORQICO(1)
                TICO(2) = TICO(2) -CDYI - TORQICO(2)
                TICO(3) = TICO(3) -CDZI - TORQICO(3)
                TJCO(1) = TJCO(1) + CDXJ + TORQJCO(1)
                TJCO(2) = TJCO(2) + CDYJ + TORQJCO(2)
                TJCO(3) = TJCO(3) + CDZJ + TORQJCO(3)
C
                TIDQ(1) = TIDQ(1) -CDXI - TORQIDQ(1)
                TIDQ(2) = TIDQ(2) -CDYI - TORQIDQ(2)
                TIDQ(3) = TIDQ(3) -CDZI - TORQIDQ(3)
                TJDQ(1) = TJDQ(1) +CDXJ + TORQJDQ(1)
                TJDQ(2) = TJDQ(2) +CDYJ + TORQJDQ(2)
                TJDQ(3) = TJDQ(3) +CDZJ + TORQJDQ(3)
C
                TIQQ(1) = TIQQ(1) -CDXI + TORQIQQ(1)
                TIQQ(2) = TIQQ(2) -CDYI + TORQIQQ(2)
                TIQQ(3) = TIQQ(3) -CDZI + TORQIQQ(3)
                TJQQ(1) = TJQQ(1) +CDXJ + TORQJQQ(1)
                TJQQ(2) = TJQQ(2) +CDYJ + TORQJQQ(2)
                TJQQ(3) = TJQQ(3) +CDZJ + TORQJQQ(3)
              END IF
            END IF
C
C   ---- ADD UP FORCES AND TORQUES
C---            IF (.FALSE.) THEN 
C---                DESFRG(1,JM) = DESFRG(1,JM) + SWF*CONX
C---                DESFRG(2,JM) = DESFRG(2,JM) + SWF*CONY
C---                DESFRG(3,JM) = DESFRG(3,JM) + SWF*CONZ
C---                DESFRG(4,JM) = DESFRG(4,JM) + SWF*(
C---     *                         CONZ*(EFC(2,IC2)-EFCENT(2,JM))
C---     *                         -CONY*(EFC(3,IC2)-EFCENT(3,JM))
C---     *                         +TJMX )
C---                DESFRG(5,JM) = DESFRG(5,JM) + SWF*(
C---     *                         CONX*(EFC(3,IC2)-EFCENT(3,JM))
C---     *                         -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
C---     *                         +TJMY )
C---                DESFRG(6,JM) = DESFRG(6,JM) + SWF*(
C---     *                         CONY*(EFC(1,IC2)-EFCENT(1,JM))
C---     *                         -CONX*(EFC(2,IC2)-EFCENT(2,JM))
C---     *                         +TJMZ )
C---C
C---                DESFRG(1,IM) = DESFRG(1,IM) - SWF*CONX
C---                DESFRG(2,IM) = DESFRG(2,IM) - SWF*CONY
C---                DESFRG(3,IM) = DESFRG(3,IM) - SWF*CONZ
C---                DESFRG(4,IM) = DESFRG(4,IM) - SWF*(
C---     *                          CONZ*(EFC(2,IC1)-EFCENT(2,IM))
C---     *                         -CONY*(EFC(3,IC1)-EFCENT(3,IM))
C---     *                         +TIMX)
C---                DESFRG(5,IM) = DESFRG(5,IM) - SWF*(
C---     *                          CONX*(EFC(3,IC1)-EFCENT(3,IM))
C---     *                         -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
C---     *                         +TIMY)
C---                DESFRG(6,IM) = DESFRG(6,IM) - SWF*(
C---     *                          CONY*(EFC(1,IC1)-EFCENT(1,IM))
C---     *                         -CONX*(EFC(2,IC1)-EFCENT(2,IM))
C---     *                         +TIMZ)
C---           END IF
C
                DESFRG(1,JM) = DESFRG(1,JM) + CONX
                DESFRG(2,JM) = DESFRG(2,JM) + CONY
                DESFRG(3,JM) = DESFRG(3,JM) + CONZ
                DESFRG(4,JM) = DESFRG(4,JM) + 
     *                         (CONZ*(EFC(2,IC2)-EFCENT(2,JM))
     *                         -CONY*(EFC(3,IC2)-EFCENT(3,JM))
     *                         +TJMX )
                DESFRG(5,JM) = DESFRG(5,JM) + 
     *                         (CONX*(EFC(3,IC2)-EFCENT(3,JM))
     *                         -CONZ*(EFC(1,IC2)-EFCENT(1,JM))
     *                         +TJMY )
                DESFRG(6,JM) = DESFRG(6,JM) + 
     *                         (CONY*(EFC(1,IC2)-EFCENT(1,JM))
     *                         -CONX*(EFC(2,IC2)-EFCENT(2,JM))
     *                         +TJMZ )
C
                DESFRG(1,IM) = DESFRG(1,IM) - CONX
                DESFRG(2,IM) = DESFRG(2,IM) - CONY
                DESFRG(3,IM) = DESFRG(3,IM) - CONZ
                DESFRG(4,IM) = DESFRG(4,IM) - 
     *                          (CONZ*(EFC(2,IC1)-EFCENT(2,IM))
     *                         -CONY*(EFC(3,IC1)-EFCENT(3,IM))
     *                         +TIMX)
                DESFRG(5,IM) = DESFRG(5,IM) - 
     *                          (CONX*(EFC(3,IC1)-EFCENT(3,IM))
     *                         -CONZ*(EFC(1,IC1)-EFCENT(1,IM))
     *                         +TIMY)
                DESFRG(6,IM) = DESFRG(6,IM) - 
     *                          (CONY*(EFC(1,IC1)-EFCENT(1,IM))
     *                         -CONX*(EFC(2,IC1)-EFCENT(2,IM))
     *                         +TIMZ)
C
C  ----  END OF GRADIENTS
               END IF
C
250            CONTINUE
260         CONTINUE
C
C   ---- CONTRIBUTION TO THE GRADIENT FROM SWITCHING FUNCTION DERIVES
C            EDELTA = EPAIRCC + EPCHPCC + EPAIRCD + EPCHPCD + EPAIRDD +
C     *               EPAIRCQ + EPCHPCQ + EPAIRCO + EPAIRDQ + EPAIRQQ
            EDELTA = ZERO
            IF (IFEWLD) THEN
               IF (LEVEL .EQ. 3) EDELTA = ZERO
               IF (LEVEL .EQ. 2) EDELTA = EPAIRCQ + EPCHPCQ
               IF (LEVEL .EQ. 1) EDELTA = EPAIRDD + EPAIRCQ + EPCHPCQ +
     *                                    EPAIRCD + EPCHPCD
            ELSE 
               EDELTA = EPAIRDD + EPAIRCQ + EPCHPCQ +
     *                  EPAIRCD + EPCHPCD + EPAIRCC + EPCHPCC 
            END IF
            EDELTA = EDELTA + EPAIRCO + EPAIRDQ + EPAIRQQ
C            
            IF (IFSWF) THEN
               DESFRG(1,JM) = DESFRG(1,JM) - EDELTA*SWFDX
               DESFRG(2,JM) = DESFRG(2,JM) - EDELTA*SWFDY
               DESFRG(3,JM) = DESFRG(3,JM) - EDELTA*SWFDZ
               DESFRG(1,IM) = DESFRG(1,IM) + EDELTA*SWFDX
               DESFRG(2,IM) = DESFRG(2,IM) + EDELTA*SWFDY
               DESFRG(3,IM) = DESFRG(3,IM) + EDELTA*SWFDZ
            END IF
C
            IF (IFEWLD) THEN 
               IF (LEVEL .EQ. 3) THEN
                  ECC = ECC + EPAIRCC
                  ECHPCC = ECHPCC + EPCHPCC
                  ECD = ECD + EPAIRCD
                  ECHPCD = ECHPCD + EPCHPCD
                  EDD = EDD + EPAIRDD
                  ECQ = ECQ + EPAIRCQ
                  ECHPCQ = ECHPCQ + EPCHPCQ
               ELSE IF (LEVEL .EQ. 2) THEN 
                  ECC = ECC + EPAIRCC
                  ECHPCC = ECHPCC + EPCHPCC
                  ECD = ECD + EPAIRCD
                  ECHPCD = ECHPCD + EPCHPCD
                  EDD = EDD + EPAIRDD
                  ECQ = ECQ + EPAIRCQ*SWF
                  ECHPCQ = ECHPCQ + EPCHPCQ*SWF
               ELSE IF (LEVEL .EQ. 1) THEN 
                  ECC = ECC + EPAIRCC
                  ECHPCC = ECHPCC + EPCHPCC
                  ECD = ECD + EPAIRCD*SWF
                  ECHPCD = ECHPCD + EPCHPCD*SWF
                  EDD = EDD + EPAIRDD*SWF
                  ECQ = ECQ + EPAIRCQ*SWF
                  ECHPCQ = ECHPCQ + EPCHPCQ*SWF
               END IF
            ELSE
                  ECC = ECC + EPAIRCC*SWF
                  ECHPCC = ECHPCC + EPCHPCC*SWF
                  ECD = ECD + EPAIRCD*SWF
                  ECHPCD = ECHPCD + EPCHPCD*SWF
                  EDD = EDD + EPAIRDD*SWF
                  ECQ = ECQ + EPAIRCQ*SWF
                  ECHPCQ = ECHPCQ + EPCHPCQ*SWF
            END IF
            ECO = ECO + EPAIRCO*SWF
            EDQ = EDQ + EPAIRDQ*SWF
            EQQ = EQQ + EPAIRQQ*SWF
C
270      CONTINUE
280   CONTINUE
C
      IF(GOPARR) THEN
        ESBUFF(1) = ECC
        ESBUFF(2) = ECHPCC
        ESBUFF(3) = ECD
        ESBUFF(4) = ECHPCD
        ESBUFF(5) = EDD
        ESBUFF(6) = ECQ
        ESBUFF(7) = ECHPCQ
        ESBUFF(8) = ECO
        ESBUFF(9) = EDQ
        ESBUFF(10) = EQQ
        CALL DDI_GSUMF(666,ESBUFF,10)
        ECC = ESBUFF(1)
        ECHPCC = ESBUFF(2)
        ECD = ESBUFF(3)
        ECHPCD = ESBUFF(4)
        EDD = ESBUFF(5)
        ECQ = ESBUFF(6)
        ECHPCQ = ESBUFF(7)
        ECO = ESBUFF(8)
        EDQ = ESBUFF(9)
        EQQ = ESBUFF(10)
      ENDIF
C
C  ---- THIS IS TOTAL ELECTROSTTAIC ENERGY
      EFINAL = ECC + ECHPCC + ECD + ECHPCD + EDD + ECQ
     *             + ECHPCQ + ECO + EDQ + EQQ
      ECHCH = ECC + ECHPCC
      ECHDIP = ECD + ECHPCD
      ECHQUAD = ECQ + ECHPCQ
C
C  ---- THIS IS FOR DEBUGGING TORQUES AND GRADIENTS.
C  PLEASE DO NOT REMOVE IT, EVEN THOUGH IT IS IMPOSSIBLE TO EXECUTE IT
C
      IF (IW.EQ.-328) THEN
C
      WRITE(IW,*)'TICD',TICD
      WRITE(IW,*)'TJCD',TJCD
      WRITE(IW,*)'TIDD',TIDD
      WRITE(IW,*)'TJDD',TJDD
      WRITE(IW,*)'TICQ',TICQ
      WRITE(IW,*)'TJCQ',TJCQ
      WRITE(IW,*)'TIDQ',TIDQ
      WRITE(IW,*)'TJDQ',TJDQ
      WRITE(IW,*)'TIQQ',TIQQ
      WRITE(IW,*)'TJQQ',TJQQ
      WRITE(IW,*)'TICO',TICO
      WRITE(IW,*)'TJCO',TJCO
C
         WRITE(IW,1010) GCC
         WRITE(IW,1020) GCD
         WRITE(IW,1030) GDD
         WRITE(IW,1040) GCQ
         WRITE(IW,1050) GDQ
         WRITE(IW,1060) GQQ
         WRITE(IW,1070) GCO
 1020 FORMAT(17X,'CHARGE-DIPOLE GRADIENT = ',3F14.10)
 1010 FORMAT(17X,'CHARGE-CHARGE GRADIENT = ',3F14.10)
 1030 FORMAT(17X,'DIPOLE-DIPOLE GRADIENT = ',3F14.10)
 1040 FORMAT(17X,'CHARGE-QUADRU GRADIENT = ',3F14.10)
 1050 FORMAT(17X,'DIPOLE-QUADRU GRADIENT = ',3F14.10)
 1060 FORMAT(17X,'QUADRU-QUADRU GRADIENT = ',3F14.10)
 1070 FORMAT(17X,'CHARGE-OCTOPO GRADIENT = ',3F14.10)
      END IF
C
      IF (IPRINT) THEN
         WRITE(IW,9020) ECC+ECHPCC, ECHPCC
         WRITE(IW,9030) ECD+ECHPCD, ECHPCD
         WRITE(IW,9040) ECQ+ECHPCQ, ECHPCQ
         WRITE(IW,9050) ECO
         WRITE(IW,9060) EDD
         WRITE(IW,9070) EDQ
         WRITE(IW,9080) EQQ
         WRITE(IW,9090) EFINAL
C
 9020 FORMAT(17X,'CHARGE-CHARGE         = ',F18.14,' SCREEN = ',F14.10)
 9030 FORMAT(17X,'CHARGE-DIPOLE         = ',F18.14,' SCREEN = ',F14.10)
 9040 FORMAT(17X,'CHARGE-QUADRUPOLE     = ',F18.14,' SCREEN = ',F14.10)
 9050 FORMAT(17X,'CHARGE-OCTUPOLE       = ',F18.14)
 9060 FORMAT(17X,'DIPOLE-DIPOLE         = ',F18.14)
 9070 FORMAT(17X,'DIPOLE-QUADRUPOLE     = ',F18.14)
 9080 FORMAT(17X,'QUADRUPOLE-QUADRUPOLE = ',F18.14)
 9090 FORMAT(17X,'ELECTROSTATIC ENERGY  = ',F18.14)
       END IF
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK GRDPQUAD
      SUBROUTINE GRDPQUAD(X,Y,Z,FORCE,TORQ1,TORQ2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      LOGICAL DOGAUSS,DOCHPEN,HOCHPEN
C
      DIMENSION FORCE(3),TORQ1(3),TORQ2(3),SS(6),UU(6),VV(6),WW(6),
     *          FFF1(6),FFF2(6)
C
      COMMON /EFPELE/ P0(3),P1(3),P1D(3),P2(3),P3(3),P4,P5,P6,FF(0:6),
     *                DIP1(3),DIP2(3),QUAD1(6),QUAD2(6),
     *                QQ1(2),QQ2(2),OCT1(10),OCT2(10),
     *                XX(6),XXX(10),TT(6),RMU(2),
     *                R,R2,R3,R4,R5,R7,R9,
     *                DOGAUSS,DOCHPEN,HOCHPEN
C
      DATA PT5,TWO/0.5D+00,2.0D+00/
      DATA THREE/3.0D+00/
C
C   ---- EFP-EFP ELECTROSTATICS
C   ---- CALCULATES DIPOLE-QUADRUPOLE GRADIENT
C
        G1 = FF(1)+P1(1)
        G2 = FF(2)+P2(1)
        G1D = -FF(3)+P1D(1)
        G3 = -FF(4)+P3(1)
C  LVS!  ADD EWALD TERMS HERE!!
        G4 = FF(5)+P4
C        G5 = FF(6)+P5
        G6 = P6
C
        DO I=1,6
             SS(I) = -15.0D+00*XX(I)/R7
             UU(I) = 105.0D+00*XX(I)/R9
             VV(I) = G1*UU(I) + TWO*G1D*SS(I) + G4*TT(I) + G6*XX(I)
             WW(I) = G1*SS(I) + G1D*TT(I) + G3*XX(I)
        END DO
C
C   ---- CH-PEN INTERMEDIATES
        PY = TWO*(G1*(-15.0D+00/R7)+G1D*THREE/R5+G3)
        PZ = TWO*(G1*THREE/R5 + G2)
C
C   ---- R_A*QUAD_AX PRODUCT
        QUAX1 = X*QUAD1(1)+Y*QUAD1(4)+Z*QUAD1(5)
        QUAY1 = Y*QUAD1(2)+X*QUAD1(4)+Z*QUAD1(6)
        QUAZ1 = Z*QUAD1(3)+X*QUAD1(5)+Y*QUAD1(6)
        QUAX2 = X*QUAD2(1)+Y*QUAD2(4)+Z*QUAD2(5)
        QUAY2 = Y*QUAD2(2)+X*QUAD2(4)+Z*QUAD2(6)
        QUAZ2 = Z*QUAD2(3)+X*QUAD2(5)+Y*QUAD2(6)
C
C   ---- MU_A*QUAD_AX PRODUCTS
        QUADX1 = DIP2(1)*QUAD1(1)+DIP2(2)*QUAD1(4)+DIP2(3)*QUAD1(5)
        QUADY1 = DIP2(2)*QUAD1(2)+DIP2(1)*QUAD1(4)+DIP2(3)*QUAD1(6)
        QUADZ1 = DIP2(3)*QUAD1(3)+DIP2(1)*QUAD1(5)+DIP2(2)*QUAD1(6)
        QUADX2 = DIP1(1)*QUAD2(1)+DIP1(2)*QUAD2(4)+DIP1(3)*QUAD2(5)
        QUADY2 = DIP1(2)*QUAD2(2)+DIP1(1)*QUAD2(4)+DIP1(3)*QUAD2(6)
        QUADZ2 = DIP1(3)*QUAD2(3)+DIP1(1)*QUAD2(5)+DIP1(2)*QUAD2(6)
C
C   ---- MU_A*R_B*QUAD_AB PRODUCTS
        DRQUAD1 = QUAD1(1)*X*DIP2(1) + QUAD1(2)*Y*DIP2(2) +
     *            QUAD1(3)*Z*DIP2(3) + QUAD1(4)*(X*DIP2(2)+Y*DIP2(1))+
     *            QUAD1(5)*(X*DIP2(3)+Z*DIP2(1))+
     *            QUAD1(6)*(Y*DIP2(3)+Z*DIP2(2))
        DRQUAD2 = QUAD2(1)*X*DIP1(1) + QUAD2(2)*Y*DIP1(2) +
     *            QUAD2(3)*Z*DIP1(3) + QUAD2(4)*(X*DIP1(2)+Y*DIP1(1))+
     *            QUAD2(5)*(X*DIP1(3)+Z*DIP1(1))+
     *            QUAD2(6)*(Y*DIP1(3)+Z*DIP1(2))
C
C   ---- DONE WITH PREPARING STUFF,
C   ---- NOW DIFFERENT PARTS OF GRADIENT GO...
        GRAND1 = RMU(2)*(QUAD1(1)*VV(1) + QUAD1(2)*VV(2) +
     *           QUAD1(3)*VV(3) + TWO*(QUAD1(4)*VV(4) +
     *           QUAD1(5)*VV(5) + QUAD1(6)*VV(6)))
        GRAND2 = RMU(1)*(QUAD2(1)*VV(1) + QUAD2(2)*VV(2) +
     *           QUAD2(3)*VV(3) + TWO*(QUAD2(4)*VV(4) +
     *           QUAD2(5)*VV(5) + QUAD2(6)*VV(6)))
C
        BIG1 = QUAD1(1)*WW(1) + QUAD1(2)*WW(2) +
     *         QUAD1(3)*WW(3) + TWO*(QUAD1(4)*WW(4) +
     *         QUAD1(5)*WW(5) + QUAD1(6)*WW(6))
        BIG2 = QUAD2(1)*WW(1) + QUAD2(2)*WW(2) +
     *         QUAD2(3)*WW(3) + TWO*(QUAD2(4)*WW(4) +
     *         QUAD2(5)*WW(5) + QUAD2(6)*WW(6))
C
        DQ1X = RMU(2)*PY*QUAX1 + PZ*QUADX1 + BIG1*DIP2(1)
        DQ1Y = RMU(2)*PY*QUAY1 + PZ*QUADY1 + BIG1*DIP2(2)
        DQ1Z = RMU(2)*PY*QUAZ1 + PZ*QUADZ1 + BIG1*DIP2(3)
        DQ2X = RMU(1)*PY*QUAX2 + PZ*QUADX2 + BIG2*DIP1(1)
        DQ2Y = RMU(1)*PY*QUAY2 + PZ*QUADY2 + BIG2*DIP1(2)
        DQ2Z = RMU(1)*PY*QUAZ2 + PZ*QUADZ2 + BIG2*DIP1(3)
C
        TERM1 = PY*DRQUAD1 + GRAND1
        TERM2 = PY*DRQUAD2 + GRAND2
C
C  ---- FINAL EXPRESSION FOR FORCE
        CONDQX = ( DQ1X - DQ2X + X*(TERM1-TERM2))/THREE
        CONDQY = ( DQ1Y - DQ2Y + Y*(TERM1-TERM2))/THREE
        CONDQZ = ( DQ1Z - DQ2Z + Z*(TERM1-TERM2))/THREE
C
        FORCE(1) = CONDQX
        FORCE(2) = CONDQY
        FORCE(3) = CONDQZ
C
C  ---- UFFF ... :)
C  ---- NEED A BIT MORE EFFORT FOR TORQUES
C   ----  F_AB TENSORS (FOR TORQUES DUE TO QUADRUPOLE)
        FFF1(1) = RMU(1)*WW(1) + PZ*X*DIP1(1)
        FFF1(2) = RMU(1)*WW(2) + PZ*Y*DIP1(2)
        FFF1(3) = RMU(1)*WW(3) + PZ*Z*DIP1(3)
        FFF1(4) = RMU(1)*WW(4) + PZ*PT5*(X*DIP1(2)+Y*DIP1(1))
        FFF1(5) = RMU(1)*WW(5) + PZ*PT5*(X*DIP1(3)+Z*DIP1(1))
        FFF1(6) = RMU(1)*WW(6) + PZ*PT5*(Y*DIP1(3)+Z*DIP1(2))
        FFF2(1) = RMU(2)*WW(1) + PZ*X*DIP2(1)
        FFF2(2) = RMU(2)*WW(2) + PZ*Y*DIP2(2)
        FFF2(3) = RMU(2)*WW(3) + PZ*Z*DIP2(3)
        FFF2(4) = RMU(2)*WW(4) + PZ*PT5*(X*DIP2(2)+Y*DIP2(1))
        FFF2(5) = RMU(2)*WW(5) + PZ*PT5*(X*DIP2(3)+Z*DIP2(1))
        FFF2(6) = RMU(2)*WW(6) + PZ*PT5*(Y*DIP2(3)+Z*DIP2(2))
C
C   ----  TORQUES ON FRAGMENTS DUE TO QUADRUPOLES
        T2DQX = (QUAD2(5)*FFF1(4) - QUAD2(4)*FFF1(5) +
     *           QUAD2(6)*FFF1(2) - QUAD2(2)*FFF1(6) +
     *           QUAD2(3)*FFF1(6) - QUAD2(6)*FFF1(3))*TWO/THREE
        T2DQY = -(QUAD2(5)*FFF1(1) - QUAD2(1)*FFF1(5) +
     *           QUAD2(6)*FFF1(4) - QUAD2(4)*FFF1(6) +
     *           QUAD2(3)*FFF1(5) - QUAD2(5)*FFF1(3))*TWO/THREE
        T2DQZ = -(QUAD2(1)*FFF1(4) - QUAD2(4)*FFF1(1) +
     *           QUAD2(4)*FFF1(2) - QUAD2(2)*FFF1(4) +
     *           QUAD2(5)*FFF1(6) - QUAD2(6)*FFF1(5))*TWO/THREE
C
        T1DQX = (QUAD1(5)*FFF2(4) - QUAD1(4)*FFF2(5) +
     *          QUAD1(6)*FFF2(2) - QUAD1(2)*FFF2(6) +
     *          QUAD1(3)*FFF2(6) - QUAD1(6)*FFF2(3))*TWO/THREE
        T1DQY = -(QUAD1(5)*FFF2(1) - QUAD1(1)*FFF2(5) +
     *           QUAD1(6)*FFF2(4) - QUAD1(4)*FFF2(6) +
     *           QUAD1(3)*FFF2(5) - QUAD1(5)*FFF2(3))*TWO/THREE
        T1DQZ = -(QUAD1(1)*FFF2(4) - QUAD1(4)*FFF2(1) +
     *            QUAD1(4)*FFF2(2) - QUAD1(2)*FFF2(4) +
     *            QUAD1(5)*FFF2(6) - QUAD1(6)*FFF2(5))*TWO/THREE
C
C   ----  TORQUES DUE TO DIPOLES
        T2DX = -((PZ*QUAZ1+BIG1*Z)*DIP2(2)-
     *          (PZ*QUAY1+BIG1*Y)*DIP2(3))/THREE
        T2DY = -((PZ*QUAX1+BIG1*X)*DIP2(3)-
     *          (PZ*QUAZ1+BIG1*Z)*DIP2(1))/THREE
        T2DZ = -((PZ*QUAY1+BIG1*Y)*DIP2(1)-
     *          (PZ*QUAX1+BIG1*X)*DIP2(2))/THREE
C
        T1DX = -((PZ*QUAZ2+BIG2*Z)*DIP1(2)-
     *          (PZ*QUAY2+BIG2*Y)*DIP1(3))/THREE
        T1DY = -((PZ*QUAX2+BIG2*X)*DIP1(3)-
     *          (PZ*QUAZ2+BIG2*Z)*DIP1(1))/THREE
        T1DZ = -((PZ*QUAY2+BIG2*Y)*DIP1(1)-
     *          (PZ*QUAX2+BIG2*X)*DIP1(2))/THREE
C
        TORQ1(1) = - T1DQX + T1DX
        TORQ1(2) = - T1DQY + T1DY
        TORQ1(3) = - T1DQZ + T1DZ
        TORQ2(1) = - T2DQX + T2DX
        TORQ2(2) = - T2DQY + T2DY
        TORQ2(3) = - T2DQZ + T2DZ
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK GRQUQU
      SUBROUTINE GRQUQU(X,Y,Z,FORCE,TORQ1,TORQ2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      LOGICAL DOGAUSS,DOCHPEN,HOCHPEN
C
      DIMENSION FORCE(3),TORQ1(3),TORQ2(3)
C
      COMMON /EFPELE/ P0(3),P1(3),P1D(3),P2(3),P3(3),P4,P5,P6,FF(7),
     *                DIP1(3),DIP2(3),QUAD1(6),QUAD2(6),
     *                QQ1(2),QQ2(2),OCT1(10),OCT2(10),
     *                XX(6),XXX(10),TT(6),RMU(2),
     *                R,R2,R3,R4,R5,R7,R9,
     *                DOGAUSS,DOCHPEN,HOCHPEN
C
      DATA TWO/2.0D+00/
      DATA THREE/3.0D+00/
C
C   ---- EFP-EFP ELECTROSTATICS
C   ---- CALCULATES QUADRUPOLE-QUADRUPOLE GRADIENT
C   ---- NO ELECTR. SCREENING, NO EWALD SUMS SO FAR
C
        QUQU = QUAD1(1)*QUAD2(1)+QUAD1(2)*QUAD2(2)+
     *         QUAD1(3)*QUAD2(3)+
     *         TWO*(QUAD1(4)*QUAD2(4)+QUAD1(5)*QUAD2(5)+
     *         QUAD1(6)*QUAD2(6))
        DQU1 = QUQU * 30.0D+00 / R7
C   ---- R_A*QUAD_XA PRODUCT
        QUAX1 = X*QUAD1(1)+Y*QUAD1(4)+Z*QUAD1(5)
        QUAY1 = Y*QUAD1(2)+X*QUAD1(4)+Z*QUAD1(6)
        QUAZ1 = Z*QUAD1(3)+X*QUAD1(5)+Y*QUAD1(6)
        QUAX2 = X*QUAD2(1)+Y*QUAD2(4)+Z*QUAD2(5)
        QUAY2 = Y*QUAD2(2)+X*QUAD2(4)+Z*QUAD2(6)
        QUAZ2 = Z*QUAD2(3)+X*QUAD2(5)+Y*QUAD2(6)
C   ---- XY*QUAD_XY PRODUCT
        QUARR1 = XX(1)*QUAD1(1)+XX(2)*QUAD1(2)+XX(3)*QUAD1(3)+
     *          TWO*(XX(4)*QUAD1(4)+XX(5)*QUAD1(5)+XX(6)*QUAD1(6))
        QUARR2 = XX(1)*QUAD2(1)+XX(2)*QUAD2(2)+XX(3)*QUAD2(3)+
     *          TWO*(XX(4)*QUAD2(4)+XX(5)*QUAD2(5)+XX(6)*QUAD2(6))
        DQU2 =  QUARR1*QUARR2*945.0D+00 / (R2*R9)
C
        DQU2X =  (QUAX1*QUARR2+QUAX2*QUARR1) * 210.0D+00 / R9
        DQU2Y =  (QUAY1*QUARR2+QUAY2*QUARR1) * 210.0D+00 / R9
        DQU2Z =  (QUAZ1*QUARR2+QUAZ2*QUARR1) * 210.0D+00 / R9
C
        DQU3 = (QUAX1*QUAX2+QUAY1*QUAY2+QUAZ1*QUAZ2)*420.0D+00/R9
C
        DQU3X = (QUAD1(1)*QUAX2 + QUAD2(1)*QUAX1 +
     *         QUAD1(4)*QUAY2 + QUAD2(4)*QUAY1 +
     *         QUAD1(5)*QUAZ2 + QUAD2(5)*QUAZ1) * 60.0D+00 / R7
        DQU3Y = (QUAD1(4)*QUAX2 + QUAD2(4)*QUAX1 +
     *         QUAD1(2)*QUAY2 + QUAD2(2)*QUAY1 +
     *         QUAD1(6)*QUAZ2 + QUAD2(6)*QUAZ1) * 60.0D+00 / R7
        DQU3Z = (QUAD1(5)*QUAX2 + QUAD2(5)*QUAX1 +
     *         QUAD1(6)*QUAY2 + QUAD2(6)*QUAY1 +
     *         QUAD1(3)*QUAZ2 + QUAD2(3)*QUAZ1) * 60.0D+00 / R7
C
       F1XX = TWO*QUAD1(1)/R5 - 20.0D+00*X*QUAX1/R7 +
     *       35.0D+00*XX(1)*QUARR1/R9
       F1YY = TWO*QUAD1(2)/R5-20.0D+00*Y*QUAY1/R7+
     *       35.0D+00*XX(2)*QUARR1/R9
       F1ZZ = TWO*QUAD1(3)/R5-20.0D+00*Z*QUAZ1/R7+
     *       35.0D+00*XX(3)*QUARR1/R9
       F1XY = TWO*QUAD1(4)/R5-10.0D+00*(Y*QUAX1+X*QUAY1)/R7 +
     *        35.0D+00*XX(4)*QUARR1/R9
       F1XZ = TWO*QUAD1(5)/R5-10.0D+00*(Z*QUAX1+X*QUAZ1)/R7 +
     *        35.0D+00*XX(5)*QUARR1/R9
       F1YZ = TWO*QUAD1(6)/R5-10.0D+00*(Z*QUAY1+Y*QUAZ1)/R7 +
     *        35.0D+00*XX(6)*QUARR1/R9
C
       F2XX = TWO*QUAD2(1)/R5 - 20.0D+00*X*QUAX2/R7 +
     *       35.0D+00*XX(1)*QUARR2/R9
       F2YY = TWO*QUAD2(2)/R5-20.0D+00*Y*QUAY2/R7+
     *       35.0D+00*XX(2)*QUARR2/R9
       F2ZZ = TWO*QUAD2(3)/R5-20.0D+00*Z*QUAZ2/R7+
     *       35.0D+00*XX(3)*QUARR2/R9
       F2XY = TWO*QUAD2(4)/R5-10.0D+00*(Y*QUAX2+X*QUAY2)/R7 +
     *        35.0D+00*XX(4)*QUARR2/R9
       F2XZ = TWO*QUAD2(5)/R5-10.0D+00*(Z*QUAX2+X*QUAZ2)/R7 +
     *        35.0D+00*XX(5)*QUARR2/R9
       F2YZ = TWO*QUAD2(6)/R5-10.0D+00*(Z*QUAY2+Y*QUAZ2)/R7 +
     *        35.0D+00*XX(6)*QUARR2/R9
C
C  ---- GRADIENT
       CONX = (X*(DQU1+DQU2-DQU3)-DQU2X+DQU3X)/9.0D+00
       CONY = (Y*(DQU1+DQU2-DQU3)-DQU2Y+DQU3Y)/9.0D+00
       CONZ = (Z*(DQU1+DQU2-DQU3)-DQU2Z+DQU3Z)/9.0D+00
       FORCE(1) = CONX
       FORCE(2) = CONY
       FORCE(3) = CONZ
C
C        WRITE(6,*)'IC1,IC2,DQU1,DQU2,DQU3,DQU2X,DQU3X',
C     *            IC1,IC2,DQU1,DQU2,DQU3,DQU2X,DQU3X
C  ---- TORQUE
       TORQJX= (QUAD2(2)*F1YZ+QUAD2(6)*F1ZZ+QUAD2(4)*F1XZ
     *        -(QUAD2(6)*F1YY+QUAD2(3)*F1YZ+QUAD2(5)*F1XY))*TWO/THREE
       TORQJY= (QUAD2(3)*F1XZ+QUAD2(5)*F1XX+QUAD2(6)*F1XY
     *        -(QUAD2(5)*F1ZZ+QUAD2(1)*F1XZ+QUAD2(4)*F1YZ))*TWO/THREE
       TORQJZ= (QUAD2(1)*F1XY+QUAD2(4)*F1YY+QUAD2(5)*F1YZ
     *        -(QUAD2(4)*F1XX+QUAD2(2)*F1XY+QUAD2(6)*F1XZ))*TWO/THREE
C
       TORQIX= (QUAD1(2)*F2YZ+QUAD1(6)*F2ZZ+QUAD1(4)*F2XZ
     *        -(QUAD1(6)*F2YY+QUAD1(3)*F2YZ+QUAD1(5)*F2XY))*TWO/THREE
       TORQIY= (QUAD1(3)*F2XZ+QUAD1(5)*F2XX+QUAD1(6)*F2XY
     *        -(QUAD1(5)*F2ZZ+QUAD1(1)*F2XZ+QUAD1(4)*F2YZ))*TWO/THREE
       TORQIZ= (QUAD1(1)*F2XY+QUAD1(4)*F2YY+QUAD1(5)*F2YZ
     *        -(QUAD1(4)*F2XX+QUAD1(2)*F2XY+QUAD1(6)*F2XZ))*TWO/THREE
       TORQ1(1) = TORQIX
       TORQ1(2) = TORQIY
       TORQ1(3) = TORQIZ
       TORQ2(1) = TORQJX
       TORQ2(2) = TORQJY
       TORQ2(3) = TORQJZ
C
       RETURN
       END
C
C*MODULE EFELEC  *DECK GRCHOCT
      SUBROUTINE GRCHOCT(X,Y,Z,DOOCT1,DOOCT2,FORCE,TORQ1,TORQ2)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      LOGICAL DOGAUSS,DOCHPEN,HOCHPEN
      LOGICAL DOOCT1,DOOCT2
C
      DIMENSION FORCE(3),TORQ1(3),TORQ2(3)
C
      COMMON /EFPELE/ P0(3),P1(3),P1D(3),P2(3),P3(3),P4,P5,P6,FF(7),
     *                DIP1(3),DIP2(3),QUAD1(6),QUAD2(6),
     *                QQ1(2),QQ2(2),OCT1(10),OCT2(10),
     *                XX(6),XXX(10),TT(6),RMU(2),
     *                R,R2,R3,R4,R5,R7,R9,
     *                DOGAUSS,DOCHPEN,HOCHPEN
C
      DATA ONE/1.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   ---- EFP-EFP ELECTROSTATICS
C   ---- CALCULATES CHARGE-OCTOPOLE GRADIENT
C   ---- NO ELECTR. SCREENING, NO EWALD SUMS SO FAR
C
      DUM7 = ONE/R7/FIVE
      DUM9 = SEVEN/R9/FIVE
      RRX = R2*X
      RRY = R2*Y
      RRZ = R2*Z
      CFXXX = FIVE*XXX(1)-THREE*RRX
      CFYYY = FIVE*XXX(2)-THREE*RRY
      CFZZZ = FIVE*XXX(3)-THREE*RRZ
      CFXXY = FIVE*XXX(4)-RRY
      CFXXZ = FIVE*XXX(5)-RRZ
      CFXYY = FIVE*XXX(6)-RRX
      CFYYZ = FIVE*XXX(7)-RRZ
      CFXZZ = FIVE*XXX(8)-RRX
      CFYZZ = FIVE*XXX(9)-RRY
      CFXYZ = FIVE*XXX(10)
C
C.... CHARGE(JM) - OCTUPOLE(IM)
C
      CALL VCLR(TORQ1,1,3)
      CALL VCLR(TORQ2,1,3)
      CONX1 = ZERO
      CONY1 = ZERO
      CONZ1 = ZERO
      CONX2 = ZERO
      CONY2 = ZERO
      CONZ2 = ZERO
C
      IF(DOOCT1) THEN
      TERM1 = (QQ2(1)+QQ2(2))*DUM9*
     *        (OCT1(1)*CFXXX + OCT1(2)*CFYYY + OCT1(3)*CFZZZ
     *      + THREE*(OCT1(4)*CFXXY + OCT1(5)*CFXXZ + OCT1(6)*CFXYY)
     *      + THREE*(OCT1(7)*CFYYZ + OCT1(8)*CFXZZ + OCT1(9)*CFYZZ)
     *      + SIX*OCT1(10)*CFXYZ)
       TERM1X = TERM1*X
       TERM1Y = TERM1*Y
       TERM1Z = TERM1*Z
C
        TMX1A = (OCT1(1)*FIFTEN*XX(1)
     *      + THREE*(OCT1(4)*TEN*XX(4) + OCT1(5)*TEN*XX(5)
     *      +  OCT1(6)*FIVE*XX(2) + OCT1(8)*FIVE*XX(3))
     *      + THIRTY*OCT1(10)*XX(6))*DUM7*(QQ2(1)+QQ2(2))
C
        TMX1B = -SIX*DUM7*(QQ2(1)+QQ2(2))*
     *         (OCT1(1)*XX(1)+OCT1(2)*XX(4)+OCT1(3)*XX(5)
     *      +  OCT1(4)*XX(4) + OCT1(5)*XX(5)
     *      +  OCT1(6)*XX(1) + OCT1(8)*XX(1)
     *      +  OCT1(7)*XX(5) + OCT1(9)*XX(4))
C
        TMY1A = (OCT1(2)*FIFTEN*XX(2)
     *      + THREE*(OCT1(6)*TEN*XX(4) + OCT1(7)*TEN*XX(6)
     *      +  OCT1(4)*FIVE*XX(1) + OCT1(9)*FIVE*XX(3))
     *      + THIRTY*OCT1(10)*XX(5))*DUM7*(QQ2(1)+QQ2(2))
C
        TMY1B = -SIX*DUM7*(QQ2(1)+QQ2(2))*
     *         (OCT1(2)*XX(2)+OCT1(1)*XX(4)+OCT1(3)*XX(6)
     *      +  OCT1(6)*XX(4) + OCT1(7)*XX(6)
     *      +  OCT1(4)*XX(2) + OCT1(9)*XX(2)
     *      +  OCT1(5)*XX(6) + OCT1(8)*XX(4))
C
        TMZ1A = (OCT1(3)*FIFTEN*XX(3)
     *      + THREE*(OCT1(9)*TEN*XX(6) + OCT1(8)*TEN*XX(5)
     *      +  OCT1(7)*FIVE*XX(2) + OCT1(5)*FIVE*XX(1))
     *      + THIRTY*OCT1(10)*XX(4))*DUM7*(QQ2(1)+QQ2(2))
C
        TMZ1B = -SIX*DUM7*(QQ2(1)+QQ2(2))*
     *         (OCT1(3)*XX(3)+OCT1(2)*XX(6)+OCT1(1)*XX(5)
     *      +  OCT1(9)*XX(6) + OCT1(8)*XX(5)
     *      +  OCT1(7)*XX(3) + OCT1(5)*XX(3)
     *      +  OCT1(6)*XX(5) + OCT1(4)*XX(6))
C
        TMX1 = TMX1A + TMX1B
        TMY1 = TMY1A + TMY1B
        TMZ1 = TMZ1A + TMZ1B
C  ---- GRADIENTS
        CONX1 = TMX1 - TERM1X
        CONY1 = TMY1 - TERM1Y
        CONZ1 = TMZ1 - TERM1Z
C   ---- TORQUES
        TORQ1(1) = TMY1*Z - TMZ1*Y
        TORQ1(2) = TMZ1*X - TMX1*Z
        TORQ1(3) = TMX1*Y - TMY1*X
       END IF
C
       IF (DOOCT2) THEN
       TERM2 = (QQ1(1)+QQ1(2))*DUM9*
     *        (OCT2(1)*CFXXX + OCT2(2)*CFYYY + OCT2(3)*CFZZZ
     *      + THREE*(OCT2(4)*CFXXY + OCT2(5)*CFXXZ + OCT2(6)*CFXYY)
     *      + THREE*(OCT2(7)*CFYYZ + OCT2(8)*CFXZZ + OCT2(9)*CFYZZ)
     *      + SIX*OCT2(10)*CFXYZ)
C
       TERM2X = TERM2*X
       TERM2Y = TERM2*Y
       TERM2Z = TERM2*Z
C
        TMX2A = (OCT2(1)*FIFTEN*XX(1)
     *      + THREE*(OCT2(4)*TEN*XX(4) + OCT2(5)*TEN*XX(5)
     *      +  OCT2(6)*FIVE*XX(2) + OCT2(8)*FIVE*XX(3))
     *      + THIRTY*OCT2(10)*XX(6))*DUM7*(QQ1(1)+QQ1(2))
C
        TMX2B = -SIX*DUM7*(QQ1(1)+QQ1(2))*
     *        (OCT2(1)*XX(1) + OCT2(2)*XX(4) + OCT2(3)*XX(5)
     *      +  OCT2(4)*XX(4) + OCT2(5)*XX(5)
     *      +  OCT2(6)*XX(1) + OCT2(8)*XX(1)
     *      +  OCT2(7)*XX(5) + OCT2(9)*XX(4))
C
        TMY2A = (OCT2(2)*FIFTEN*XX(2)
     *      + THREE*(OCT2(6)*TEN*XX(4) + OCT2(7)*TEN*XX(6)
     *      +  OCT2(4)*FIVE*XX(1) + OCT2(9)*FIVE*XX(3))
     *      + THIRTY*OCT2(10)*XX(5))*DUM7*(QQ1(1)+QQ1(2))
C
        TMY2B = -SIX*DUM7*(QQ1(1)+QQ1(2))*
     *         (OCT2(2)*XX(2)+OCT2(1)*XX(4)+OCT2(3)*XX(6)
     *      +  OCT2(6)*XX(4) + OCT2(7)*XX(6)
     *      +  OCT2(4)*XX(2) + OCT2(9)*XX(2)
     *      +  OCT2(5)*XX(6) + OCT2(8)*XX(4))
C
        TMZ2A = (OCT2(3)*FIFTEN*XX(3)
     *      + THREE*(OCT2(9)*TEN*XX(6) + OCT2(8)*TEN*XX(5)
     *      +  OCT2(7)*FIVE*XX(2) + OCT2(5)*FIVE*XX(1))
     *      + THIRTY*OCT2(10)*XX(4))*DUM7*(QQ1(1)+QQ1(2))
C
        TMZ2B = -SIX*DUM7*(QQ1(1)+QQ1(2))*
     *         (OCT2(3)*XX(3)+OCT2(2)*XX(6)+OCT2(1)*XX(5)
     *      +  OCT2(9)*XX(6) + OCT2(8)*XX(5)
     *      +  OCT2(7)*XX(3) + OCT2(5)*XX(3)
     *      +  OCT2(6)*XX(5) + OCT2(4)*XX(6))
C
        TMX2 = TMX2A + TMX2B
        TMY2 = TMY2A + TMY2B
        TMZ2 = TMZ2A + TMZ2B
C   ---- GRADIENTS
        CONX2 = TMX2 - TERM2X
        CONY2 = TMY2 - TERM2Y
        CONZ2 = TMZ2 - TERM2Z
C   ---- TORQUES
        TORQ2(1) = TMY2*Z - TMZ2*Y
        TORQ2(2) = TMZ2*X - TMX2*Z
        TORQ2(3) = TMX2*Y - TMY2*X
        END IF
C
C        CONX = (TMX1 - TMX2) - (TERM1X - TERM2X)
C        CONY = (TMY1 - TMY2) - (TERM1Y - TERM2Y)
C        CONZ = (TMZ1 - TMZ2) - (TERM1Z - TERM2Z)
        FORCE(1) = CONX1-CONX2
        FORCE(2) = CONY1-CONY2
        FORCE(3) = CONZ1-CONZ2
C
      RETURN
      END
C
C*MODULE EFELEC  *DECK EDPQUAD
      SUBROUTINE EDPQUAD(X,Y,Z,EDQ)
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      LOGICAL DOGAUSS,DOCHPEN,HOCHPEN
C
      COMMON /EFPELE/ P0(3),P1(3),P1D(3),P2(3),P3(3),P4,P5,P6,FF(0:6),
     *                DIP1(3),DIP2(3),QUAD1(6),QUAD2(6),
     *                QQ1(2),QQ2(2),OCT1(10),OCT2(10),
     *                XX(6),XXX(10),TT(6),RMU(2),
     *                R,R2,R3,R4,R5,R7,R9,
     *                DOGAUSS,DOCHPEN,HOCHPEN
C
      DATA PT5,TWO/0.5D+00,2.0D+00/
      DATA THREE,FIFTEN/3.0D+00,15.0D+00/
      DATA ZERO/0.0D+00/
C
C   ---- EFP-EFP ELECTROSTATICS
C   ---- CALCULATES DIPOLE-QUADRUPOLE ENERGY
C
        G1 = FF(1)+P1(1)
        G2 = FF(2)+P2(1)
        G1D = -FF(3)+P1D(1)
        G3 = -FF(4)+P3(1)
C
        RMU1 = RMU(1)
        RMU2 = RMU(2)
C
C   ---- DIPOLE-QUADRUPOLE ENERGIES (ELECTR. SCREENING IS
C   -----INCORPORTAED IN A GENERAL FORMULA)
C
          DUM = THREE/R5
          TERM1 = ZERO
          TERM2 = ZERO
C
          DFXX1 = G1* (TWO*DIP2(1)*X*DUM -
     *            FIFTEN*XX(1)*RMU2/R7) +
     *            TWO*G2*DIP2(1)*X +
     *            G1D*RMU2*(THREE*XX(1)-R2)/R5 +
     *            G3*RMU2*XX(1)
          DFYY1 = G1*((TWO*DIP2(2)*Y)*DUM -
     *            FIFTEN*XX(2)*RMU2/R7) +
     *            TWO*G2*DIP2(2)*Y +
     *            G1D*RMU2*(THREE*XX(2)-R2)/R5 +
     *            G3*RMU2*XX(2)
          DFZZ1 = G1*((TWO*DIP2(3)*Z)*DUM -
     *            FIFTEN*XX(3)*RMU2/R7)+
     *            TWO*G2*DIP2(3)*Z +
     *            G1D*RMU2*(THREE*XX(3)-R2)/R5 +
     *            G3*RMU2*XX(3)
          DFXY1 = G1*((DIP2(1)*Y+DIP2(2)*X)*DUM -
     *            FIFTEN*XX(4)*RMU2/R7)+
     *            TWO*G2*PT5*(DIP2(1)*Y+DIP2(2)*X)+
     *            G1D*RMU2*THREE*XX(4)/R5 + G3*RMU2*XX(4)
          DFXZ1 = G1*((DIP2(1)*Z+DIP2(3)*X)*DUM -
     *            FIFTEN*XX(5)*RMU2/R7)+
     *            TWO*G2*PT5*(DIP2(1)*Z+DIP2(3)*X)+
     *            G1D*RMU2*THREE*XX(5)/R5 + G3*RMU2*XX(5)
          DFYZ1 = G1*((DIP2(2)*Z+DIP2(3)*Y)*DUM -
     *            FIFTEN*XX(6)*RMU2/R7)+
     *            TWO*G2*PT5*(DIP2(2)*Z+DIP2(3)*Y)+
     *            G1D*RMU2*THREE*XX(6)/R5 + G3*RMU2*XX(6)
          TERM1 = QUAD1(1)*DFXX1 + QUAD1(2)*DFYY1 +
     *       QUAD1(3)*DFZZ1 + TWO*(QUAD1(4)*DFXY1 +
     *       QUAD1(5)*DFXZ1 + QUAD1(6)*DFYZ1)
C
          DFXX2 = G1*((TWO*DIP1(1)*X)*DUM -
     *            FIFTEN*XX(1)*RMU1/R7)+
     *            TWO*G2*DIP1(1)*X + G1D*RMU1*(THREE*XX(1)-R2)/R5 +
     *            G3*RMU1*XX(1)
          DFYY2 = G1*((TWO*DIP1(2)*Y)*DUM -
     *            FIFTEN*XX(2)*RMU1/R7)+
     *            TWO*G2*DIP1(2)*Y+ G1D*RMU1*(THREE*XX(2)-R2)/R5+
     *            G3*RMU1*XX(2)
          DFZZ2 = G1*((TWO*DIP1(3)*Z)*DUM -
     *            FIFTEN*XX(3)*RMU1/R7)+
     *            TWO*G2*DIP1(3)*Z + G1D*RMU1*(THREE*XX(3)-R2)/R5 +
     *            G3*RMU1*XX(3)
          DFXY2 = G1*((DIP1(1)*Y+DIP1(2)*X)*DUM -
     *            FIFTEN*XX(4)*RMU1/R7)+
     *            TWO*G2*PT5*(DIP1(1)*Y+DIP1(2)*X)+
     *            G1D*RMU1*THREE*XX(4)/R5+G3*RMU1*XX(4)
          DFXZ2 = G1*((DIP1(1)*Z+DIP1(3)*X)*DUM -
     *            FIFTEN*XX(5)*RMU1/R7)+
     *            TWO*G2*PT5*(DIP1(1)*Z+DIP1(3)*X)+
     *            G1D*RMU1*THREE*XX(5)/R5+G3*RMU1*XX(5)
          DFYZ2 = G1*((DIP1(2)*Z+DIP1(3)*Y)*DUM -
     *            FIFTEN*XX(6)*RMU1/R7)+
     *            TWO*G2*PT5*(DIP1(2)*Z+DIP1(3)*Y)+
     *            G1D*RMU1*THREE*XX(6)/R5+G3*RMU1*XX(6)
          TERM2 = QUAD2(1)*DFXX2 + QUAD2(2)*DFYY2 +
     *          QUAD2(3)*DFZZ2 + TWO*(QUAD2(4)*DFXY2 +
     *          QUAD2(5)*DFXZ2 + QUAD2(6)*DFYZ2)
          EDQ = (-TERM1+TERM2)/THREE
C
      RETURN
      END
C
