      SUBROUTINE EVALQ(CXADIA,CXAOFF,AK,NAT3,E02,CXE,CXP,
     &                 CABS,CEXT,CPHA,MXN3,IMETHD)
      IMPLICIT NONE
C*** Arguments:
      REAL CABS,CEXT,CPHA,E02
      INTEGER IMETHD,MXN3,NAT3
      COMPLEX CXE(MXN3),
     &        CXP(MXN3),
     &        CXADIA(MXN3),
     &        CXAOFF(MXN3)
      REAL AK(3)
C
C*** Local variables:
      COMPLEX CXA,CXI,DCXA,RABS
      REAL AK1,AK2,AK3,PI
      INTEGER J1,J2,J3,NAT
C
C*** Intrinsic functions:
      INTRINSIC AIMAG,CONJG,REAL,SQRT
C
C*** SAVE statements:
      SAVE CXI
C
C*** Data statements:
C
      DATA CXI/(0.,1.)/
C***********************************************************************
C
C Given: CXADIA(J,1-3)=(a_11,a_22,a_33) for dipoles J=1-NAT,
C                  where symmetric 3x3 matrix a_ij is inverse of complex
C                  polarizability tensor alpha_ij for dipole J
C        CXAOFF(J,1-3)=(a_23,a_31,a_12) for dipoles J=1-NAT
C        AK(1-3) = (k_x,k_y,k_z)*d 
C                  d = (d_x*d_y*d_z)**(1/3) = effective lattice spacing
C        NAT3 = 3*number of dipoles
C        E02 = |E_0|^2 , where E_0 = incident complex E field.
C        CXE(1-NAT3) = components of E field at each dipole, in order
C                      E_1x,E_2x,...,E_NATx,E_1y,E_2y,...,E_NATy,
C                      E_1z,E_2z,...,E_NATz
C        CXP(1-NAT3) = components of polarization vector at each dipole,
C                      in order
C                      P_1x,P_2x,...,P_NATx,P_1y,P_2y,...,P_NATy,
C                      P_1z,P_2z,...,P_NATz
C        IMETHD = 0 or 1
C Finds: 
C        CEXT = extinction cross section /d**2
C  and, if IMETHD=1, also computes
C        CPHA = phase-lag cross section /d**2
C        CABS = absorption cross section /d**2
C        
C Note: present definition of CPHA is 1/2 of Martin's definition
C
C B.T.Draine, Princeton Univ. Obs., 87/1/4
C
C History:
C 88.04.28 (BTD): modifications
C 90.11.02 (BTD): modified to allow use of vacuum sites (now pass E02
C                 from calling routine instead of evaluating it here)
C 90.12.13 (BTD): modified to use IMETHD flag, to allow "fast" calls
C                 in which only CEXT is computed.
C 97.12.26 (BTD): removed CXALPH from argument list; replaced with
C                 CXADIA and CXAOFF.
C                 CXADIA and CXAOFF are diagonal and off-diagonal
C                 elements of alpha^{-1} for each dipole.
C                 Modified to properly evaluate CABS
C 98.01.01 (BTD): Correct inconsistencies in assumed data ordering.
C 98.01.13 (BTD): Examine for possible error in evaluation of Qabs
C 98.04.27 (BTD): Minor polishing.
C End history
C
C Copyright (C) 1993,1997,1998 B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C Initialization:
C Compute magnitude of kd
C
      CEXT=0.
      CABS=0.
      CPHA=0.
      PI=4.*ATAN(1.)
      AK2=0.
      DO 10 J1=1,3
         AK2=AK2+AK(J1)*AK(J1)
   10 CONTINUE
      AK1=SQRT(AK2)
      AK3=AK1*AK2
C
C Initialization complete.
C
      IF(IMETHD.EQ.0)THEN
C
C*** Compute CEXT:
C
         DO 20 J1=1,NAT3
            CEXT=CEXT+AIMAG(CXP(J1))*REAL(CXE(J1))
     &               -REAL(CXP(J1))*AIMAG(CXE(J1))
   20    CONTINUE
         CEXT=4.*PI*AK1*CEXT/E02
      ELSEIF(IMETHD.EQ.1)THEN
C
C Compute 
C C_abs=(4*pi*k/|E_0|^2)*
C       sum_J { Im[P_J*conjg(a_J*P_J)] - (2/3)*k^3*|P_J|^2 }     
C      =(4*pi*k/|E_0|^2)*
C       sum_J {-Im[conjg(P_J)*a_J*P_J] - Im[i*(2/3)*k^3*P_J*conjg(P_J)]}
C      =-(4*pi*k/|E_0|^2)*
C       Im{ sum_J [ conjg(P_J)*(a_J*P_J + i*(2/3)*k^3*P_J) ] }
C
         NAT=NAT3/3
         CXA=(0.,0.)
         RABS=CXI*AK3/1.5
         DO 40 J1=1,NAT
            J2=J1+NAT
            J3=J2+NAT
            DCXA=CONJG(CXP(J1))*((CXADIA(J1)+RABS)*CXP(J1)+
     &                           CXAOFF(J2)*CXP(J3)+CXAOFF(J3)*CXP(J2))+
     &           CONJG(CXP(J2))*((CXADIA(J2)+RABS)*CXP(J2)+
     &                           CXAOFF(J3)*CXP(J1)+CXAOFF(J1)*CXP(J3))+
     &           CONJG(CXP(J3))*((CXADIA(J3)+RABS)*CXP(J3)+
     &                           CXAOFF(J1)*CXP(J2)+CXAOFF(J2)*CXP(J1))
            CXA=CXA+DCXA
   40    CONTINUE
         CABS=-4.*PI*AK1*AIMAG(CXA)/E02
C Compute CEXT and CPHA
         CXA=(0.,0.)
         DO 50 J1=1,NAT3
            CXA=CXA+CXP(J1)*CONJG(CXE(J1))
   50    CONTINUE
         CEXT=4.*PI*AK1*AIMAG(CXA)/E02
         CPHA=2.*PI*AK1*REAL(CXA)/E02
      ENDIF
      RETURN
C
      END
