      SUBROUTINE ESELF(CMETHD,CXZP,NX,NY,NZ,NPY,NPZ,AKD,DX,
     &                 CXZC,CXZW,CXZE)
      IMPLICIT NONE

C Arguments:

      CHARACTER*6 CMETHD
      INTEGER NPY,NPZ,NX,NY,NZ
      REAL AKD
      REAL DX(3)
      COMPLEX 
     &   CXZC(NX+1,NY+1,NZ+1,6),
     &   CXZE(NX,NY,NZ,3),
     &   CXZP(NX,NY,NZ,3),
     &   CXZW(2*NX,2*NY,2*NZ,*)

C Local scalars:

      COMPLEX 
     &   CXEX,CXEY,CXEZ,CXFAC,CXPHAS,CXUNIT,CXXX,CXXY,CXXZ,
     &   CXYY,CXYZ,CXZERO,CXZZ
      REAL BETA,FAC,R,R2,R3,WOLD,XX
      INTEGER 
     &   I,IER,II,IR,ISGN,ISUM,J,JJ,JPY,JPYM,JPZ,JPZM,JR,JSGN,
     &   K,KR,KSGN,M,NGRID

C Local arrays:

      REAL X(3)
      INTEGER 
     &   ISYM(3)
      COMPLEX CXSUM(6)

      EXTERNAL CXC3DFFT,CXFFTW,EXTND,PAD,TRIM
      INTRINSIC EXP,MIN,NINT,SIGN,SQRT
      SAVE BETA,CXUNIT,CXZERO,NGRID,WOLD
      DATA BETA/1.E-10/
c-----------------------------------------------------------------------
c subroutine ESELF
C
C       Given the dipole moments, CXZP, at all points on
C       a rectangular grid,oscillating at frequency AKD,
C       compute the electric field amplitude, CXZE,
C       at each point produced by all the other dipoles except the one
C       at that point.
C       The relationship between the dipoles and the field
C       values at the grid points can be expressed as a convolution,
C       and the convolution is efficiently evaluated using 3D FFTs.
C
C       3-dimensional FFT is performed using either
C
C       a) Native 3d FFT routine in Convex vector library.
C          This option is available only on Convex hardware, and
C          linking must be done with -lveclib option (see the Makefile).
C          This also requires that NX,NY,NZ be of form
C          (2**I)*(3**J)*(5**K); subroutine EXTEND takes care of choosing
C          suitable NX,NY,NZ.
C          Select CMETHD='CONVEX' (in the DDSCAT parameter file).
C       b) CXFFT3N interface to GPFA code of Temperton. 
C          Good points: 
C             -On CRAY the code is on average 30-40% faster in comparison
C              to TMPRTN (and 10-15 faster in comparison to BRENNR)
C             -On scalar machines the code is 2-8 faster in comparison
C              to BRENNR or TMPRTN
C             -Doesn't require additional storage
C          Limitations:
C              -Requires that NX,NY,NZ be of form (2**I)*(3**J)*(5**K); 
C               subroutine EXTEND takes care of choosing suitable NX,NY,NZ.
C              -The choice of "lvr" variable in gpfa2f, gpfa3f, gpfa5f
C               depends on machine. WARNING: on C90 use lvr=128, on
C               all other CRAY's use lvr=64; wrong lvr will produce WRONG
C               RESULTS. On scalar machines optimal lvr depends on cache
C               length; sub-optimal choice degrades performance but still 
C               produces correct results.
C       c) CXFFTW interface to FFTW (Fastest Fourier Transform in the
C               West) version 2.1.x from Frigo and Johnson.
C
C       INPUT:
C       CXZP(I,J,K,L)   Lth cartesian component of the dipole
C                       moment at the grid point (I,J,K);
C                       the DIMENSIONed length of CXZP in
C                       the calling routine is CXZP(NX,NY,NZ,3)
C                       [or CXZP(NX*NY*NZ,3) or CXZP(3*NX*NY*NZ)]
C
C       NX,NY,NZ        Size of grid in x,y,z directions (INTEGER).

c       NPY,NPZ         Period of lattice in y,z directions
c                       Note: must have NPY.GE.NX, NPZ.GE.NZ

C       DX(1-3)         Lattice spacing in x,y,z directions, in units of
C                       n**(-1./3.) .  Note that with this normalization
C                       we have DX(1)*DX(2)*DX(3)=1.

C       AKD             Frequency of oscillation of dipoles and electric
C                       field; also absolute value of wave vector of
C                       incident wave [c=1]  (REAL*4).

C       CXZC            (NX+1) by (NY+1) by (NZ+1) by 6 array of Green
C                       function coefficients used
C                       internally by ESELF and
C                       *************NOT TO BE OVERWRITTEN***********
C                       between calls, because these coefficients are
C                       recomputed only if W has changed since the last
C                       call to ESELF.

C       CXZW            Complex, scratch-space vector of length:
C                       2*NX*2*NY*2*NY*3
C                       See comment about FFT usage and CMETHD
C                       flag.
C                       Can be overwritten between calls to ESELF

C       OUTPUT:

C       CXZE(I,J,K,L)   Lth component of dipole-induced electric field
C                       at grid point (I,J,K);
C                       the DECLARED length of ZE in the calling
C                       program is CXZE(NX,NY,NZ,3)
C                       [or CXZE(NX*NY*NZ,3) or CXZE(3*NX*NY*NZ)]
C
C Originally written by Jeremy Goodman, Princeton Univ. Observatory, 90.09.22
C History:
C 90.11.29 (BTD): Modified to set untransformed ZC(1,1,1,1-6)=0.
C 90.11.29 (PJF): Modified to use FOURX and CXFFT99
C 90.12.05 (BTD): Modified for new ordering of elements of polarization
C                 and electric field vectors in calling program.  Modified
C                 ESELF and PAD to remove distinction between NX,NY,NZ
C                 and dimensions CXZE and CXZP, since our new ordering
C                 always assumes this.
C 90.12.13 (BTD): Modified to include CONVEX option.
C 92.04.20 (BTD): removed ISYM from argument list of TRIM (was not used)
C 94.06.20 (PJF): modified to call CXFFT3N when CMETHD='NEWTMP'
C 96.10.18 (BTD): changed NEWTMP to GPFAFT
C 97.10.16 (BTD): added DX(1-3) to argument list to support use for
C                 noncubic rectangular lattices.
C                 Added DX to 3 lines computing X(1-3)
C 99.04.26 (BTD): changed notation: CXY -> CXZE
C 00.06.22 (BTD): modified to support option FFTWFJ, with calls to CXFFTW
C 00.06.25 (BTD): modified to eliminate calls to FOURX (CMETHD=BRENNR)
C                 and CXFFT3 (CMETHD=TMPRTN), as these options are no
C                 longer supported
C 00.07.05 (BTD): further cleanup 
C 03.07.13 (BTD): changed FFTWFJ to FFTW21 to allow future distinction
C                 between FFTW 2.1.x and FFTW 3.0.x
C 04.03.05 (BTD): modified to handle a periodic lattice of scatterers
C                 with periodicity NPY*D(2) in y direction and
C                 NPZ*D(3) in z direction
c                 Added NPY and NPZ to argument list.
C                 Add parameter BETA to assist convergence
C end history
C Copyright (C) 1993,1994,1996,1997,1999,2000,2003,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
      DATA WOLD/-999.e-33/,CXUNIT/ (0.,1.)/,CXZERO/(0.,0.)/

      IF(AKD.EQ.WOLD)GOTO 70

C               AKD.NE.WOLD :

C               We have to recompute the
C               Green-function coefficients giving
C               components of field strength at a each grid point R
C               produced by unit-valued component of dipole moment at
C               point R', and then Fourier transform these components.

      WOLD=AKD
      NGRID=8*NX*NY*NZ

c        We assume screening function exp(-alpha*r^4) so
c        rmax^2 = sqrt(20/alpha) so that alpha*r^4 < 20
c     JPYM = maximum number of periods in Y direction
c            rmax = JPYM*NPY*DX(2)

c NPY=0 for nonperiodic case
c    >0 for periodic boundary conditions in y direction

      IF(NPY.EQ.0)THEN
         JPYM=0
      ELSE
         JPYM=INT((20./BETA)**0.25/(NPY*DX(2)))
      ENDIF

C
C               Compute the actual coefficients:
C
      DO K=1,NZ
         DO J=1,NY
            DO I=1,NX

c Compute 6 independent elements of 3x3 symmetric matrix A_jk, where
c A_jk*P_k = -electric field at location j due to dipole P_k at location k
c
c A_jk = (a_1  a_2  a_3)
c        (a_2  a_4  a_5)
c        (a_3  a_5  a_6)_jk

c NPY*d(2) = periodicity in Y direction
c NPZ*d(3) = periodicity in Z direction

c initialize CX(I,J,K,M) = a_M

               DO M=1,6
                  CXSUM(M)=CXZERO
               ENDDO
               DO JPY=-JPYM,JPYM

c NPZ=0 for nonperiodic case
c    >0 for periodic boundary conditions in z direction

                  IF(NPZ.EQ.0)THEN
                     JPZM=0
                  ELSE
                     JPZM=INT(SQRT(SQRT(20./BETA)-JPY*DX(2))/DX(3))
                  ENDIF

                  ISUM=I+J+K+JPY*JPY
                  DO JPZ=-JPZM,JPZM

C skip the self-interaction (R=0) case (I=J=K=1 and JPY=JPZ=0)

                     IF(ISUM+JPZ*JPZ.GT.3)THEN

C Note: here is where unequal lattice spacings are dealt with.
C For a cubic lattice we would have DX(1)=DX(2)=DX(3)=1.

                        X(1)=REAL(I-1)*DX(1)
                        X(2)=REAL(J-1+NPY*JPY)*DX(2)
                        X(3)=REAL(K-1+NPZ*JPZ)*DX(3)
                        R2=X(1)**2+X(2)**2+X(3)**2
                        R=SQRT(R2)
                        R3=R*R2

c include artificial factor exp(-beta*r^4) to assist convergence

                        CXPHAS=EXP(CXUNIT*AKD*R)*EXP(-BETA*R2*R2)
                        CXFAC=(1.-CXUNIT*AKD*R)/R2


                        M=0
                        DO II=1,3
                           M=M+1
                           CXSUM(M)=CXSUM(M)-
     &                              CXPHAS/R3*(AKD**2*(X(II)**2-R2)+
     &                              CXFAC*(R2-3*X(II)**2))
                           IF(II.LT.3)THEN
                              DO JJ=II+1,3
                                 M=M+1
                                 XX=X(II)*X(JJ)
                                 CXSUM(M)=CXSUM(M)-CXPHAS/R3*
     &                                    (AKD**2*XX-CXFAC*(3*XX))
                              ENDDO
                           ENDIF
                        ENDDO
                     ENDIF
                  ENDDO
               ENDDO
               DO M=1,6
                  CXZC(I,J,K,M)=CXSUM(M)
               ENDDO
            ENDDO
         ENDDO
      ENDDO

C          At this point, zc(i,j,k,*) contains the upper triangular
C          part of the symmetric 3 x 3 matrix giving the electric
C          field at grid point (i,j,k) caused by a dipole at (1,1,1)

C          Fill out zc to twice the size in each grid dimension
C          to accomodate negative lags [periodicity in each dimension is
C          assumed, so (e.g.)
C          nx < i <= 2*nx is equivalent to -nx < i <= 0],
C          exploiting symmetries, and Fourier transform.
C          Store only the first octant of the transform,
C          since the others can be obtained by symmetry.

      ISYM(1)=1
      ISYM(2)=1
      ISYM(3)=1
      CALL EXTND(CXZC(1,1,1,1),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,1))

      ISYM(1)=-1
      ISYM(2)=-1
      ISYM(3)=1
      CALL EXTND(CXZC(1,1,1,2),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,2))

      ISYM(1)=-1
      ISYM(2)=1
      ISYM(3)=-1
      CALL EXTND(CXZC(1,1,1,3),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,3))

      ISYM(1)=1
      ISYM(2)=1
      ISYM(3)=1
      CALL EXTND(CXZC(1,1,1,4),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,4))

      ISYM(1)=1
      ISYM(2)=-1
      ISYM(3)=-1
      CALL EXTND(CXZC(1,1,1,5),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,5))

      ISYM(1)=1
      ISYM(2)=1
      ISYM(3)=1
      CALL EXTND(CXZC(1,1,1,6),NX,NY,NZ,ISYM,CXZW(1,1,1,1))
      IF(CMETHD.EQ.'GPFAFT')THEN
         CALL CXFFT3N(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'FFTW21')THEN
         CALL CXFFTW(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,+1)
      ELSEIF(CMETHD.EQ.'CONVEX')THEN
         CALL CXC3DFFT(CXZW(1,1,1,1),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
      ENDIF

      CALL TRIM(CXZW(1,1,1,1),NX,NY,NZ,CXZC(1,1,1,6))

C          End of recomputation of Green-function coefficients

   70 CONTINUE

C       Fourier transform the polarizations:

      DO M=1,3
         CALL PAD(CXZP(1,1,1,M),NX,NY,NZ,CXZW(1,1,1,M))
         IF(CMETHD.EQ.'GPFAFT')THEN
            CALL CXFFT3N(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,+1)
         ELSEIF(CMETHD.EQ.'FFTW21')THEN
            CALL CXFFTW(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,+1)
         ELSEIF(CMETHD.EQ.'CONVEX')THEN
            CALL CXC3DFFT(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,2*NX,2*NY,+1,IER)
         ENDIF
      ENDDO

C***********************************************************************

C       Multiply by F.T. of Green function:

      DO K=1,2*NZ
         KSGN=NINT(SIGN(1.,NZ+1.5-K))
         KR=MIN(K,2*NZ+2-K)
         DO J=1,2*NY
            JSGN=NINT(SIGN(1.,NY+1.5-J))
            JR=MIN(J,2*NY+2-J)
            DO I=1,2*NX
               ISGN=NINT(SIGN(1.,NX+1.5-I))
               IR=MIN(I,2*NX+2-I)
               CXXX=CXZC(IR,JR,KR,1)
               CXXY=CXZC(IR,JR,KR,2)*(ISGN*JSGN)
               CXXZ=CXZC(IR,JR,KR,3)*(ISGN*KSGN)
               CXYY=CXZC(IR,JR,KR,4)
               CXYZ=CXZC(IR,JR,KR,5)*(JSGN*KSGN)
               CXZZ=CXZC(IR,JR,KR,6)
               CXEX=CXXX*CXZW(I,J,K,1)+CXXY*CXZW(I,J,K,2)+
     &              CXXZ*CXZW(I,J,K,3)
               CXEY=CXXY*CXZW(I,J,K,1)+CXYY*CXZW(I,J,K,2)+
     &              CXYZ*CXZW(I,J,K,3)
               CXEZ=CXXZ*CXZW(I,J,K,1)+CXYZ*CXZW(I,J,K,2)+
     &              CXZZ*CXZW(I,J,K,3)
               CXZW(I,J,K,1)=CXEX
               CXZW(I,J,K,2)=CXEY
               CXZW(I,J,K,3)=CXEZ
            ENDDO
         ENDDO
      ENDDO

C       Inverse Fourier transform to obtain electric field:

      DO M=1,3
         IF(CMETHD.EQ.'GPFAFT')THEN
            CALL CXFFT3N(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,-1)
         ELSEIF(CMETHD.EQ.'FFTW21')THEN
            CALL CXFFTW(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,-1)
         ELSEIF(CMETHD.EQ.'CONVEX')THEN
            CALL CXC3DFFT(CXZW(1,1,1,M),2*NX,2*NY,2*NZ,2*NX,2*NY,-1,IER)
         ENDIF
C
C***********************************************************************

C Note: the Convex FFT routine already normalizes result.
C       For other FFT routines need to divide result by NGRID

         IF(CMETHD.EQ.'CONVEX')THEN
            DO K=1,NZ
               DO J=1,NY
                  DO I=1,NX
                     CXZE(I,J,K,M)=CXZW(I,J,K,M)
                  ENDDO
               ENDDO
            ENDDO
         ELSE
            FAC=1./REAL(NGRID)
            DO K=1,NZ
               DO J=1,NY
                  DO I=1,NX
                     CXZE(I,J,K,M)=FAC*CXZW(I,J,K,M)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
      ENDDO

      RETURN
      END
C***********************************************************************

      SUBROUTINE EXTND(CXA,NX,NY,NZ,ISYM,CXB)
      IMPLICIT NONE

C       Using symmetries, extend first octant of coefficient matrix to
C       other octants.

C Originally written by Jeremy Goodman

C Copyright (C) 1993, B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C Arguments:
      INTEGER NX,NY,NZ
      COMPLEX CXA(NX+1,NY+1,NZ+1),CXB(2*NX,2*NY,2*NZ)
      INTEGER ISYM(3)
C Local variables:
      INTEGER I,J,K
      COMPLEX CXZERO
C SAVE statement:
      SAVE CXZERO
C DATA statement:
      DATA CXZERO/(0.,0.)/
C***********************************************************************
      DO K=1,NZ
         DO J=1,NY
            DO I=1,NX
               CXB(I,J,K)=CXA(I,J,K)
            ENDDO
         ENDDO
      ENDDO
C
      DO K=1,NZ
         DO J=1,NY
            CXB(NX+1,J,K)=CXZERO
            DO I=NX+2,2*NX
               CXB(I,J,K)=CXA(2*NX+2-I,J,K)*ISYM(1)
            ENDDO
         ENDDO
      ENDDO
C
      DO K=1,NZ
         DO I=1,2*NX
            CXB(I,NY+1,K)=CXZERO
            DO J=NY+2,2*NY
               CXB(I,J,K)=CXB(I,2*NY+2-J,K)*ISYM(2)
            ENDDO
         ENDDO
      ENDDO
C
      DO J=1,2*NY
         DO I=1,2*NX
            CXB(I,J,NZ+1)=CXZERO
            DO K=NZ+2,2*NZ
               CXB(I,J,K)=CXB(I,J,2*NZ+2-K)*ISYM(3)
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END
C***********************************************************************

      SUBROUTINE TRIM(CXB,NX,NY,NZ,CXA)
      IMPLICIT NONE
C
C Copy the first octant of CXB into CXA
C
C Originally written by Jeremy Goodman
C History:
C 92.04.20 (BTD) removed ISYM from argument list of TRIM:
C
C Copyright (C) 1993, B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C Arguments:
      INTEGER NX,NY,NZ
      COMPLEX CXA(NX+1,NY+1,NZ+1),CXB(2*NX,2*NY,2*NZ)
C Local variables:
      INTEGER I,J,K
C***********************************************************************
      DO 30 K=1,NZ+1
         DO 20 J=1,NY+1
            DO 10 I=1,NX+1
               CXA(I,J,K)=CXB(I,J,K)
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
C***********************************************************************

      SUBROUTINE PAD(CXA,NX,NY,NZ,CXB)
      IMPLICIT NONE
C
C Pad the array CXA with zeros out to twice its length in each
C dimension, and put the result in CXB.
C
C Originally written by Jeremy Goodman
C
C Copyright (C) 1993, B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C Arguments:
      INTEGER NX,NY,NZ
      COMPLEX CXA(NX,NY,NZ),CXB(2*NX,2*NY,2*NZ)
C Local variables:
      COMPLEX CXZERO
      INTEGER I,J,K
      SAVE CXZERO
      DATA CXZERO/(0.,0.)/
C***********************************************************************
      DO 30 K=1,2*NZ
         DO 20 J=1,2*NY
            DO 10 I=1,2*NX
               CXB(I,J,K)=CXZERO
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE

      DO 60 K=1,NZ
         DO 50 J=1,NY
            DO 40 I=1,NX
               CXB(I,J,K)=CXA(I,J,K)
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE

      RETURN
      END



