      SUBROUTINE EVALQ(CXALPH,AK,NAT3,E02,CXE,CXP,CABS,CEXT,CPHA,MXN3,
     &                 IMETHD)
C*** Arguments:
      REAL CABS,CEXT,CPHA
      INTEGER IMETHD,MXN3,NAT3
      COMPLEX CXE(MXN3),
     &        CXP(MXN3),
     &        CXALPH(MXN3)
      REAL AK(3)
C
C*** Local variables:
      COMPLEX CXA,CXI
      REAL AK1,AK2,AK3,ALPHA2,ALPHSQ,E02,PI,RABS
      INTEGER J
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: CXALPH(1-NAT3) = polarizability vector
C        AK(1-3) = (k_x,k_y,k_z)*d (d=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
C        CXP(1-NAT3) = components of polarization vector at each dipole
C        IMETHD = 0 or 1
C Finds: 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
C Copyright (C) 1993, 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 J=1,3
         AK2=AK2+AK(J)*AK(J)
   10 CONTINUE
      AK1=SQRT(AK2)
      AK3=AK1*AK2
C
C Initialization complete.
      IF(IMETHD.EQ.0)THEN
C*** Compute CEXT:
         DO 20 J=1,NAT3
            CEXT=CEXT+AIMAG(CXP(J))*REAL(CXE(J))
     &               -REAL(CXP(J))*AIMAG(CXE(J))
   20    CONTINUE
         CEXT=4.*PI*AK1*CEXT/E02
      ELSEIF(IMETHD.EQ.1)THEN
C Compute CABS
         DO 40 J=1,NAT3
            ALPHA2=AIMAG(CXALPH(J))
            ALPHSQ=CONJG(CXALPH(J))*CXALPH(J)
c*** diagnostic
c      if(alphsq.le.0.)then
c         write(0,*)'in evalq, having trouble, nat3=',nat3
c         write(0,*)'j=',j,' cxalpha(j)=',cxalph(j)
c      endif
c***
            RABS=ALPHA2/ALPHSQ-AK3/1.5
            CABS=CABS+CONJG(CXP(J))*CXP(J)*RABS
   40    CONTINUE
         CABS=4.*PI*AK1*CABS/E02
C Compute CEXT and CPHA
         CXA=(0.,0.)
         DO 50 J=1,NAT3
            CXA=CXA+CXP(J)*CONJG(CXE(J))
   50    CONTINUE
         CEXT=4.*PI*AK1*AIMAG(CXA)/E02
         CPHA=2.*PI*AK1*REAL(CXA)/E02
      ENDIF
      RETURN
C
      END
