      SUBROUTINE DIAGL(U,V,IPAR)
      IMPLICIT NONE

C Arguments:
      COMPLEX U(*), V(*)
      INTEGER IPAR(*)

C Common variables:

      CHARACTER*6 CMETHD
      INTEGER
     &   IDVOUT,MXN3F,MXNATF,MXNXF,MXNYF,MXNZF,
     &   NAT,NAT0,NAT3,NPY,NPZ,NX,NY,NZ

      COMPLEX CXADIA(1)
C-----------------------------------------------------------------------
      COMMON/M2/CXADIA
      COMMON/M6/MXNATF,MXNXF,MXNYF,MXNZF,NAT,NAT3,NAT0,NX,NY,NZ,
     &          MXN3F,IDVOUT,NPY,NPZ,CMETHD
C-----------------------------------------------------------------------


C cg package
C Left preconditioning subroutine - division by diagonal
C History:
C Originally written by P.J. Flatau, 1993
C 00.06.26 (BTD) Removed MXMEMF from COMMON/M6/
C 04.03.04 (BTD) Added NPY,NPZ to COMMON/M6/ to support periodic
C                boundary conditions
C end history
C Copyright (C) 1993,2000,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License
c-----------------------------------------------------------------------

      CALL CDIV(U,V,CXADIA,NAT3)
      RETURN
      END

      SUBROUTINE CDIV(U,V,CXA,N)
      IMPLICIT NONE

C Arguments:

      INTEGER N
      COMPLEX U(*), V(*), CXA(*)
C
C Local variables:
      INTEGER I

c-----------------------------------------------------------------------
c Part of conjugate gradient package
c needed by left preconditioning subroutine
c Copyright (C) 2003 B.T. Draine and P.J. Flatau
c This code is covered by the GNU General Public License
c-----------------------------------------------------------------------
      DO I=1,N
         V(I)=U(I)/CXA(I)
      ENDDO
      RETURN
      END

      SUBROUTINE MATVEC(CXX,CXY,IPAR)
      IMPLICIT NONE
C Arguments:
      COMPLEX CXX(*), CXY(*), IPAR(*)
C Common:
      INTEGER*2 IOCC(1)
      INTEGER
     &   IDVOUT,MXN3F,MXNATF,MXNXF,MXNYF,MXNZF,
     &   NAT,NAT0,NAT3,NPY,NPZ,NX,NY,NZ
      CHARACTER*6 CMETHD
      REAL AK(3),DX(3)
      COMPLEX CXADIA(1),CXAOFF(1),CXZC(1),CXZW(1)
C-----------------------------------------------------------------------
      COMMON/M1/AK,DX
      COMMON/M2/CXADIA
      COMMON/M3/CXZC
      COMMON/M4/CXZW
      COMMON/M5/IOCC
      COMMON/M6/MXNATF,MXNXF,MXNYF,MXNZF,NAT,NAT3,NAT0,NX,NY,NZ, 
     &          MXN3F,IDVOUT,NPY,NPZ,CMETHD
      COMMON/M7/CXAOFF

C-----------------------------------------------------------------------
C Subroutine MATVEC

C matvec  --> cxy = A cxx          'N'
C tmatvec --> cxy = A' cxx         'T'
C cmatvec --> cxy = conjg(A') cxx  'C'
C
C 
C Notice that DDSCAT has cases 'N' and 'C' implemented in CPROD
C Notice, however, that in DDSCAT 'T'='N'.
C Some CG methods use cases N, C (like Petravic).
C Some CG methods use cases N, T (like PIM)
C Some CG use all three products N, C, T  (parts of CCGPAK)
C
C Information about matrix A is transfered via commons /M1/-/M7/ with
C the main program. Arrays cxadia, cxzc, cxzwm,  iocc are properly
C dimensioned inside "cprod". You may get warning during the compilation
C about "misaligned common". Ignore these. Also notice mxnatf,
C mxn3f,mxnxf, mxnyf, mxnzf. These are defined by "parameter
C statement" in main code and this is the reason why they have "f" suffix.
C
C ipar - information array, not used, defined for compatibility
C
C History:
C 97.11.01 (BTD): modified to allow for noncubic lattice, introduced
C                 new vector DX(1-3) via COMMON/M1/
C                 added DX to argument list of CPROD
C 97.12.25 (BTD): added COMMON/M7/CXAOFF to communicate off-diagonal
C                 elements of inverse polarizability tensors.
C                 Added CXAOFF to argument list of CPROD
C 00.06.13 (BTD): Explicit declaration of all variables.
C 00.06.25 (BTD): Removed MXMEMF from COMMON/M6/
C 04.03.04 (BTD): Added NPY,NPZ to COMMON/M6/ to support periodic
C                 boundary conditions
C                 Added NPY,NPZ to argument list of CPROD
C end history
C Copyright (C) 1993,1997,2000,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************

      CALL CPROD(AK,DX,CMETHD,'N',CXADIA,CXAOFF,
     &           CXX,CXY,CXZC,CXZW,
     &           IDVOUT,IOCC,MXN3f,MXNATf,MXNXf,MXNYf,MXNZf,
     &           NAT,NAT0,NAT3,NX,NY,NZ,NPY,NPZ)
      RETURN
      END

      SUBROUTINE CMATVEC(CXX,CXY,IPAR)
      IMPLICIT NONE

C Arguments:

      COMPLEX CXX(*),CXY(*),IPAR(*)

C Common:

      INTEGER*2 IOCC(1)
      INTEGER
     &   IDVOUT,MXN3F,MXNATF,MXNXF,MXNYF,MXNZF,
     &   NAT,NAT0,NAT3,NPY,NPZ,NX,NY,NZ
      CHARACTER*6 CMETHD
      REAL AK(3),DX(3)
      COMPLEX CXADIA(1),CXAOFF(1),CXZC(1), CXZW(1)
C-----------------------------------------------------------------------
      COMMON/M1/AK,DX
      COMMON/M2/CXADIA
      COMMON/M3/CXZC
      COMMON/M4/CXZW
      COMMON/M5/IOCC
      COMMON/M6/MXNATF,MXNXF,MXNYF,MXNZF,NAT,NAT3,NAT0,NX,NY,NZ,
     &          MXN3F,IDVOUT,NPY,NPZ,CMETHD
      COMMON/M7/CXAOFF
C-----------------------------------------------------------------------
c Subroutine CMATVEC
c
C matvec  --> cxy = A cxx   
C tmatvec --> cxy = A' cxx   
C cmatvec --> cxy = conjg(A') cxx   
C History:
C 97.11.01 (BTD): modified to allow for noncubic lattice, introduced
C                 new vector DX(1-3) via COMMON/M1/
C                 added DX to argument list of CPROD
C 97.12.25 (BTD): added COMMON/M7/CXAOFF to communicate off-diagonal
C                 elements of inverse polarizability tensors.
C                 Added CXAOFF to argument list of CPROD
C 00.06.13 (BTD): Explicit declaration of all variables.
C 00.06.26 (BTD): Removed MXMEMF from COMMON/M6/
C 04.03.04 (BTD): Added NPY,NPZ to COMMON/M6/ to support periodic
C                 boundary conditions
C                 Added NPY,NPZ to argument list of CPROD
C end history
C Copyright (C) 1993,1997,2000,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************

      CALL CPROD(AK,DX,CMETHD,'C',CXADIA,CXAOFF,
     &           CXX,CXY,CXZC,CXZW,
     &           IDVOUT,IOCC,MXN3F,MXNATF,MXNXF,MXNYF,MXNZF,
     &           NAT,NAT0,NAT3,NX,NY,NZ,NPY,NPZ)
      RETURN
      END

      SUBROUTINE CPROD(AK,DX,CMETHD,CWHAT,CXADIA,CXAOFF,
     &                 CXX,CXY,CXZC,CXZW,
     &                 IDVOUT,IOCC,MXN3,MXNAT,MXNX,MXNY,MXNZ,
     &                 NAT,NAT0,NAT3,NX,NY,NZ,NPY,NPZ)
      IMPLICIT NONE

c Arguments:

      INTEGER IDVOUT,MXN3,MXNAT,MXNX,MXNY,MXNZ,
     &        NAT,NAT0,NAT3,NPY,NPZ,NX,NY,NZ
      CHARACTER CMETHD*6,CWHAT*1
      INTEGER*2 IOCC(MXNAT)
      REAL AK(3),DX(3)
      COMPLEX CXADIA(MXN3),CXAOFF(MXN3),
     &        CXX(MXN3),CXY(MXN3),CXZC(NX+1,NY+1,NZ+1,6),
     &        CXZW(MXNX*MXNY*MXNZ,*)

c Local variables:

      INTEGER J1,J2,J3
      REAL AKD

C Intrinsic functions:

      INTRINSIC CONJG

C***********************************************************************
c Subroutine CPROD

C Given:
C   AK(1-3)= k(1-3)*d , where k=k vector in vacuo
C                       d=effective lattice spacing=(dx*dy*dz)**(1/3)
C   DX(1-3)=(dx/d, dy/d, dz/d) 
C                 where dx,dy,dz=lattice spacing in x,y,z directions.
C                 By definition of effective lattice spacing d, must 
C                 have DX(1)*DX(2)*DX(3)=1
C   CMETHD = character variable specifying method used for FFT evaluation
C            (see ESELF)
C   CWHAT  = 'N' or 'C' determines what is to be done (see below)
C   CXADIA(1-NAT3) = diagonal elements of A(j,k)
C   CXAOFF(1-NAT3) = off-diagonal elements of 3x3 diagonal blocks of 
C                 A(j,k): CXAOFF(J,1-3)=a_{23},a_{31},a_{12} from 3x3
C                 matrix a_{ij} for dipole J.
C                 Recall that a_{ij} is inverse of 3x3 polarizability
C                 tensor alpha_{ij} for dipole J.
C   CXX(1-NAT3) = complex vector
C   CXZC        = (NX+1)*(NY+1)*(NZ+1)*6 array of Green function 
C                 coefficients used internally by ESELF, and generated
C                 by ESELF each time called with new k vector
C                 *****Not to be overwritten between calls to ESELF*****
C   CXZW        = complex workspace required by ESELF
C   IDVOUT      = device number for output
C   IOCC(1-NAT) = 0 or 1 if site is unoccupied or occupied
C   MXN3,MXNX,MXNY,MXNZ = dimensioning information (see DDSCAT)
C   NAT         = number of sites in extended target
C   NAT0        = number of occupied sites in extended target
C   NAT3        = 3*NAT
C   NX,NY,NZ    = extended target size is (NX*DX(1)) by (NY*DX(2)) by
C                 (NZ*DX(3))
C   NPY         = 0 to do isolated target
C               = periodicity/d(2) in y direction for periodic b.c.
C   NPZ         = 0 to do isolated target
C               = periodicity/d(3) in z direction for periodic b.c.
C
C If CWHAT = 'N', this returns CXY(j)=A(j,k)*CXX(k) (sum over k)
C          = 'C', this returns CXY(j)=conjg(A(k,j))*CXX(k) (sum over k)
C
C It is assumed that matrix A(j,k) is symmetric
C Diagonal elements of A(j,k) are in vector CXADIA(j)
C Off-diagonal terms coupling dipole component x with direction y, etc
C are stored in vector CXAOFF(j), CXAOFF(j+NAT), CXAOFF(j+2*NAT)
C Other off-diagonal elements of A(j,k) are produced internally by
C   subroutine ESELF, which uses 3d-FFT to accomplish convolution
C   of CXX with A-matrix terms coupling dipole j with other dipoles
C   (i.e., E field at j due to other dipoles)
C
C Original version of CPROD created by P.J.Flatau, Colorado State Univ.
C Subsequently modified by B.T.Draine, Princeton Univ. Obs.
C History:
C 90.11.04 (BTD): Major modification to incorporate FFT method (FFT
C                 computations are handled by ESELF).
C 90.11.08 (BTD): Remove DO...ENDDO structures; renumber DO...CONTINUEs
C 90.11.21 (BTD): Remove "CCGMVM" option: only FFT stuff retained.
C 90.12.03 (BTD): No longer necessary to change ordering of CXX and CXY
C 90.12.05 (BTD): Changed call to ESELF to eliminate MXNX,MXNY,MXNZ
C 97.11.01 (BTD): Added comments and modified to accomodate noncubic
C                 lattice. Added DX to argument list for CPROD and to
C                 argument list in call to ESELF
C 97.12.25 (BTD): Added CXAOFF to argument list.
C 97.12.28 (BTD): Modified to use CXAOFF in calculation of CXY
C 98.01.01 (BTD): Modified coding to use indices J1,J2,J3 in loops
C                 computing with CXAOFF
C 00.06.13 (BTD): Explicit declaration of all variables.
C 04.03.05 (BTD): Added NPY,NPZ to argument list to support periodic
C                 boundary conditions
C end history
C Copyright (C) 1993,1997,1998,2000,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
c-----------------------------------------------------------------------

      AKD=SQRT(AK(1)*AK(1)+AK(2)*AK(2)+AK(3)*AK(3))

C We assume that input vector CXX has zeroes for elements corresponding
C to vacuum sites.

      IF(CWHAT.EQ.'N')THEN
C***********************************************************************
C
         CALL ESELF(CMETHD,CXX,NX,NY,NZ,NPY,NPZ,AKD,DX,CXZC,CXZW,CXY)
C
C***********************************************************************
C ESELF omitted contribution from diagonal terms: add these.
C Also remember that ESELF computes -A_jk*x_k
         DO J1=1,NAT3
            CXY(J1)=CXADIA(J1)*CXX(J1)-CXY(J1)
         ENDDO

C Add contribution from off-diagonal elements of 3x3 diagonal blocks
C Version below assumes that off-diagonal elements a_ij are stored as
C CXAOFF(J,1-3)=(a_23,a_31,a_12) for dipole J.
C 97.12.28 (BTD):

         DO J1=1,NAT
            J2=J1+NAT
            J3=J2+NAT
            CXY(J1)=CXY(J1)+CXAOFF(J2)*CXX(J3)+CXAOFF(J3)*CXX(J2)
            CXY(J2)=CXY(J2)+CXAOFF(J3)*CXX(J1)+CXAOFF(J1)*CXX(J3)
            CXY(J3)=CXY(J3)+CXAOFF(J1)*CXX(J2)+CXAOFF(J2)*CXX(J1)
         ENDDO

      ELSEIF(CWHAT.EQ.'C')THEN

C Need to temporarily replace CXX by conjg(CXX)

         DO J1=1,NAT3
            CXX(J1)=CONJG(CXX(J1))
         ENDDO

C**********************************************************************
C
         CALL ESELF(CMETHD,CXX,NX,NY,NZ,NPY,NPZ,AKD,DX,CXZC,CXZW,CXY)
C
C************************************************************************
C
C ESELF omitted contribution from diagonal terms: add these.
C Also remember that ESELF computed -A_jk*conjg(x_k), while
C we seek to compute conjg(A_kj)* x_k.  Since A_kj=A_jk, we have
C conjg(A_kj)*x_k=conjg(A_jk*conjg(x_k))
C
         DO J1=1,NAT3
            CXY(J1)=CXADIA(J1)*CXX(J1)-CXY(J1)
         ENDDO
C
C Add contribution from off-diagonal elements of 3x3 diagonal blocks
C It is assumed that we have stored off-diagonal elements a_ij as
C CXAOFF(J,1-3)=(a_23,a_31,a_12) for element J
C Note that we could *probably* speed up the code by
C (1) "reducing" product vector CXY immediately after calling ESELF
C (2) restricting CXADIA to occupied sites
C (3) restricting CXAOFF to occupied sites
C but this would require modifications outside this routine, and
C therefore requires further study...
C 97.12.28 (BTD)

         DO J1=1,NAT
            J2=J1+NAT
            J3=J2+NAT
            CXY(J1)=CXY(J1)+CXAOFF(J2)*CXX(J3)+CXAOFF(J3)*CXX(J2)
            CXY(J2)=CXY(J2)+CXAOFF(J3)*CXX(J1)+CXAOFF(J1)*CXX(J3)
            CXY(J3)=CXY(J3)+CXAOFF(J1)*CXX(J2)+CXAOFF(J2)*CXX(J1)
         ENDDO

C Now compute conjugate of CXY, and restore CXX:

         DO J1=1,NAT3
            CXY(J1)=CONJG(CXY(J1))
            CXX(J1)=CONJG(CXX(J1))
         ENDDO
      ELSE
         WRITE(IDVOUT,FMT=*)' Error in CPROD: CWHAT= ',CWHAT
      ENDIF

C*** Now must "clean" product vector CXY:
C    (zero out elements corresponding to vacuum sites)

      IF(NAT0.LT.NAT)CALL NULLER(CXY,IOCC,MXNAT,MXN3,NAT)
      RETURN
      END

