      SUBROUTINE ALPHA(AKR,CALPHA,CXALDS,CXALPH,CXALOF,CXALOS,
     &     CXE0R,CXEPS,CXSC,CXSCR1,CXZC,CXZW,DX,IBETH,IBETH1,
     &     ICOMP,IOCC,IPHI,IPHI1,IXYZ0,JORTH,MYID,MXCOMP,MXNAT,MXN3,
     &     NAT,NAT0,NAT3,NCOMP,NX,NY,NZ,CXRLOC,CSHAPE,SHPAR)
      IMPLICIT NONE

C*** Arguments:

      CHARACTER*6 CALPHA,CSHAPE
      INTEGER 
     &   IBETH,IBETH1,IPHI,IPHI1,JORTH,MXCOMP,MXNAT,MXN3,
     &   MYID,NAT,NAT0,NAT3,NCOMP,NX,NY,NZ
      COMPLEX 
     &   CXALOF(NAT,3),
     &   CXALPH(NAT,3),
     &   CXE0R(3),
     &   CXEPS(MXCOMP),
     &   CXALDS(NAT,3),
     &   CXALOS(NAT,3),
     &   CXSC(NAT,3,3),
     &   CXSCR1(NAT,3),
     &   CXZC(NX+1,NY+1,NZ+1,6),
     &   CXZW(2*NX,2*NY,2*NZ,3),
     &   CXRLOC(MXCOMP+1,3,3)
      INTEGER*2 
     &   ICOMP(NAT,3),
     &   IOCC(NAT),
     &   IXYZ0(MXNAT,3)
      REAL 
     &   AKR(3),
     &   DX(3),
     &   SHPAR(6)

C*** Local Variables:

      LOGICAL INIT
      CHARACTER CMSGNM*70
      INTEGER
     &   IA,IC,L
      REAL 
     &   AK1,AK2,B1,B2,B3,B3L,EMKD,PI,SUM
      COMPLEX 
     &   CXI,CXRR,CXTERM

C*** Common:

      CHARACTER*6 CMETHD
      INTEGER DUM1,DUM2,DUM3,DUM4,DUM5,DUM6,DUM7,DUM8,DUM9,
     &     DUM10,DUM11,DUM12,DUM13,DUM14
C-----------------------------------------------------------------------
      COMMON/M6/DUM1,DUM2,DUM3,DUM4,DUM5,DUM6,DUM7,DUM8,DUM9,DUM10,
     &          DUM11,DUM12,DUM13,DUM14,CMETHD
C-----------------------------------------------------------------------

      SAVE INIT,CXI,PI
      DATA CXI/(0.,1.)/
      DATA INIT/.TRUE./

C***********************************************************************
C Given:
C       AKR(1-3)=(kx,ky,kz)*d, where d=effective lattice spacing
C       CALPHA = 'LATTDR' or 'SCLDR' = polarizability prescription
C       CMETHD = determines 3-d FFT routine used by ESELF
C       CSHAPE = descriptor of target shape
C       CXE0R(1-3) = polarization vector in lattice coordinates
C                    (assumed to be normalized)
C       CXEPS(1-NCOMP)=distinct values of dielectric constant
C       CXSC(1-NAT,1-3,1-3) = complex scratch space for SCLDR calculation
C       CXSCR1(1-NAT,1-3)   = complex scratch space for SCLDR calculation
C       CXZC = complex scratch space needed by ESELF
C       CXZW = complex scratch space needed by ESELF
C       DX(1-3)=(dx/d,dy/d,dz/d), where dx,dy,dz=lattice spacings in
C               x,y,z directions, and d=(dx*dy*dz)**(1/3)
C       IBETH= MYID+IBETH1 if first time through combined BETA/THETA 
C              orientation loop
C       IBETH1=starting value of IBETH (see above)
C       ICOMP(1-NAT3)=composition identifier for each lattice site and
C                     direction (ICOMP=0 if lattice site is unoccupied)
C                storage scheme: 
C                1x,2x,...,NATx,1y,2y,...,NATy,1z,2z,...,NATz
C       IOCC(1-NAT) == 0 if site unoccupied
C                   == 1 if site occupied
C       IPHI = IPHI1 if first time through PHI orientation loop
C       IPHI1= starting value of IPHI (see above)
C       JORTH= 1 if first incident polarization state
C       MXCOMP = dimensioning information
C       MXN3 = dimensioning information
C       MYID = parallel process identifier (=0 if only 1 process)
C       NAT  = number of sites in extended target (incl. vacuum sites)
C       NAT3 = 3*number of sites in extended target (incl. vacuum sites)
C       NCOMP= number of different dielectric tensor elements in target
C       NX   = x-dimension of extended target
C       NY   = y-dimension of extended target
C       NZ   = z-dimension of extended target
C       SHPAR(1-6)=target shape parameters
C
C Returns:
C       CXALPH(J,1-3)=(alpha_11,alpha_22,alpha_33)/d^3 for dipole J=1-NAT
C                     where alpha_ij=complex polarizability tensor.
C       CXALOF(J,1-3)=(alpha_23,alpha_31,alpha_12)/d^3 for dipole J=1-NAT
C
C***
C If CALPHA = LATTDR:
C    Compute dipole polarizability using "Lattice Dispersion Relation"
C    of Draine & Goodman (1993,ApJ,March 10).  It is required that
C    polarizability be such that an infinite lattice of such dipoles
C    reproduce the continuum dispersion relation for radiation
C    propagating with direction and polarization of radiation incident
C    on the DDA target.  This is the recommended option.
C
C***
C    Note: CXALPH = polarizability/d^3
C    In the event that ICOMP=0, then we set CXALPH=1.
C***********************************************************************
C B.T.Draine, Princeton Univ. Obs.
C History:
C 90.09.13 (BTD): Corrected error in DO loop limit.
C 90.11.01 (BTD): Special treatment for "vacuum" sites in order
C                 to allow FFT treatment.
C 90.11.02 (BTD): Set CXALPH=(1.,0.) at vacuum sites.
C 91.04.30 (BTD): Modified to include both O[(kd)^2] correction term
C                 from Goedecke & Obrien (1988) in addition to
C                 radiative reaction correction.
C 91.05.07 (BTD): Modified to allow easy choice among three methods
C                 for computing polarizability.
C 91.05.07 (BTD): Added call to WRIMSG to record which method in use
C 91.05.08 (BTD): Added CALPHA to argument list.
C 91.05.09 (BTD): Added printing of kd and magnitude of correction
C                 terms.
C 91.05.13 (BTD): Experiment with use of approximate directional
C                 average for coefficient of CXEPS in Lattice
C                 Disperision Relation theory
C 91.05.13 (BTD): Corrected error in radiative reaction correction
C                 (error presumably introduced during last week)
C 91.05.14 (BTD): Added separate options LDRXYZ and LDRAVG
C 91.05.15 (BTD): Added option LDR000 to omit CXEPS-dependent
C                 correction term
C 91.05.30 (BTD): Changed LDRXYZ -> LDR100
C                 Added option LDR111
C 91.09.12 (BTD): Corrected error in numerical coefficient for
C                 LDRAVG case
C 91.09.17 (BTD): Eliminate options LDR000,LDRXYZ,LDRAVG
C                 Introduce option LATTDR (LATTice Dispersion Relation)
C                 which includes explicit dependence
C                 on direction and polarization state
C                 remove AK1 from argument list
C                 add AKR, CXE0R to argument list
C 92.05.14 (BTD): Introduce option LDRISO to experiment with
C                 using average directional correction term
C                 rather than using correction for incident direction
C                 and polarization
C 92.05.16 (BTD): Correct error in LDRISO option: average SUM should be
C                 3/15 rather than 4/15
C 97.11.02 (BTD): Add DX to argument list to allow use with noncubic
C                 lattices (additional modifications still required!!)
C 97.12.26 (BTD): Add CXALOF to argument list to allow use with noncubic
C                 lattices (additional modifications still required).
C 97.12.30 (BTD): Add code to evaluate alpha for noncubic case,
C                 using subroutine NONCUBIC to evaluate the lattice
C                 sums R0,R1,R2,R3
C 98.01.14 (BTD): Change sign of radiative reaction correction term.
C 98.01.19 (BTD): Change treatment of R_1,C3, and C4
C                 and output value of C4
C                 temporary modification to allow value of C4 to be
C                 read in from file 'alpha.par'
C 98.01.22 (BTD): Minor change in computation of radiative reaction
C                 correction.
C 98.03.10 (BTD): set C4=-C3, disable reading C4 from 'alpha.par'
C 98.04.27 (BTD): declared IC1,IC2,IC3 as integers.
C 99.02.09 (BTD): experiment with change in expression used to calculate
C                 off-diagonal elements of polarizability tensor
C                 experiment with C4=-C3-R1 to "cancel" the contribution
C                 of R1 to the off-diagonal terms
C 03.01.29 (BTD): remove code to calculate alpha for noncubic lattice
C                 (hold for release in future version)
c 04.02.26 (BTD): add new option 'GKDLDR' to use Gutkowicz-Krusin
c                 and Draine (2004) lattice dispersion relation
c 04.03.31 (BTD): replace WRITE(0,... with CALL WRIMSG(...
c 04.04.01 (BTD): added DUM13,DUM14 to COMMON/M6/ to accomodate use of
c                 COMMON/M6/ in communicating NPY,NPZ to subroutineS
c                 MATVEC and CMATVEC
c 04.05.21 (BTD): cleanup -- eliminated a number of unused local
c                 variables
C end history
C Copyright (C) 1993,1996,1997,1998,1999,2003,2004
c               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
      PI=4.*ATAN(1.)
      AK2=AKR(1)*AKR(1)+AKR(2)*AKR(2)+AKR(3)*AKR(3)
      AK1=SQRT(AK2)
      CXRR=-(AK1*AK2/1.5)*CXI

C*** EMKD = |m|*k_0*d , where |m|=refractive index
C                             k_0 = wave vector in vacuo
C                             d = lattice spacing

      EMKD=SQRT(CABS(CXEPS(1)))*AK1

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

C*** Lattice dispersion relation (Draine & Goodman 1993)

      IF(CALPHA.EQ.'LATTDR')THEN
         WRITE(CMSGNM,FMT='(A,F6.4)')
     &         'Lattice dispersion relation for |m|k_0d=',EMKD
         CALL WRIMSG('ALPHA ',CMSGNM)

C*** Compute sum (a_j*e_j)^2 , where a_j=unit propagation vector
C                                    e_j=unit polarization vector

         SUM=0.0
         DO L=1,3
            SUM=SUM+(AKR(L)*CABS(CXE0R(L)))**2
         ENDDO
         SUM=SUM/AK2
         B1=-1.8915316*AK2
         B2=(0.1648469-1.7700004*SUM)*AK2
         DO L=1,3
            DO IA=1,NAT
               IC=ICOMP(IA,L)
               IF(IC.GT.0)THEN

C*** First compute Clausius-Mossotti polarizability:

                  CXTERM=(.75/PI)*(CXEPS(IC)-1.)/(CXEPS(IC)+2.)

C*** Determine polarizability by requiring that infinite lattice of
C    dipoles have dipersion relation of continuum.

                  CXTERM=CXTERM/(1.+CXTERM*(B1+CXEPS(IC)*B2))

C*** Radiative-reaction correction:

                  CXALPH(IA,L)=CXTERM/(1.+CXTERM*CXRR)

c set off-diagonal terms to zero

                  CXALOF(IA,L)=0.

               ELSEIF(IC.EQ.0)THEN

C To avoid divisions by zero, etc., set CXALPH=1 for vacuum sites.

                  CXALPH(IA,L)=1.
                  CXALOF(IA,L)=0.
               ENDIF
            ENDDO
         ENDDO
         RETURN

c*** Lattice dispersion relation: modified 
c    (Gutkowicz-Krusin & Draine 2004)

      ELSEIF(CALPHA.EQ.'GKDLDR')THEN
         WRITE(CMSGNM,FMT='(A,F6.4)')
     &         'GKDLDR Lattice dispersion relation for |m|k_0d=',EMKD
         CALL WRIMSG('ALPHA ',CMSGNM)

C B1 = (c_1/pi)*ak2 = (-5.9424219/pi)*ak2 = -1.8915316*ak2
C B2 = (c_2/pi)*ak2 = (0.5178819/pi)*ak2 = 0.1648469*ak2
C B3 = -[(3c_2+c_3)/pi]*ak2 = -[(3*0.5178819+4.0069747)/pi]*ak2
C                           = -1.7700004*ak2
C B3L = B3*A(I)**2 where a_i = unit vector in direction of propagation

         B1=-1.8915316*AK2
         B2=0.1648469*AK2
         B3=-1.7700004*AK2
         DO L=1,3
            B3L=B3*AKR(L)*AKR(L)/AK2
            DO IA=1,NAT
               IC=ICOMP(IA,L)
               IF(IC.GT.0)THEN

C*** First compute Clausius-Mossotti polarizability:

                  CXTERM=(.75/PI)*(CXEPS(IC)-1.)/(CXEPS(IC)+2.)

C*** Determine polarizability by requiring that infinite lattice of
C    dipoles have dipersion relation of continuum.


                  CXTERM=CXTERM/(1.+CXTERM*(B1+CXEPS(IC)*(B2+B3L)))

C*** Radiative-reaction correction:

                  CXALPH(IA,L)=CXTERM/(1.+CXTERM*CXRR)

c set off-diagonal terms to zero

                  CXALOF(IA,L)=0.

               ELSEIF(IC.EQ.0)THEN

C To avoid divisions by zero, etc., set CXALPH=1 for vacuum sites.

                  CXALPH(IA,L)=1.
                  CXALOF(IA,L)=0.
               ENDIF
            ENDDO
         ENDDO
         RETURN
      ELSE
         WRITE(CMSGNM,FMT='(A)')
     &      'Error: invalid option for subroutine ALPHA'
         CALL WRIMSG('ALPHA ',CMSGNM)
         STOP
      ENDIF
      END
