      SUBROUTINE TARNSP(A1,A2,DIAMX,PRINAX,DX,CFLSHP,CDESCR,
     &                  IDVSHP,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
      IMPLICIT NONE

C** Arguments:

      CHARACTER CDESCR*67,CFLSHP*80
      INTEGER IDVSHP,IOSHP,MXNAT,NAT
      INTEGER*2 ICOMP(MXNAT,3),IXYZ(MXNAT,3)
      REAL DIAMX,PRINAX
      REAL A1(3),A2(3),DX(3)

C** Local variables:

      INTEGER NSPHMX
      PARAMETER(NSPHMX=100)
      CHARACTER CMSGNM*70
      LOGICAL OCC
      INTEGER JA,JX,JY,JZ,LMX1,LMX2,LMY1,LMY2,LMZ1,LMZ2,NSPH
      REAL R2,SCALE,X,XMAX,XMIN,Y,YMAX,YMIN,Z,ZMAX,ZMIN
      REAL ALPHA(3),AS(NSPHMX),XS(NSPHMX),YS(NSPHMX),ZS(NSPHMX)

C***********************************************************************
C Routine to construct multisphere target
C
C Input:
C        DIAMX =max extent in X direction/d
C        PRINAX=0 to set A1=(1,0,0), A2=(0,1,0)
C              =1 to use principal axes for vectors A1 and A2
C        DX(1-3)=(dx,dy,dz)/d where dx,dy,dz=lattice spacings in x,y,z
C                directions, and d=(dx*dy*dz)**(1/3)=effective lattice
C                spacing
C        CFLSHP= name of file containing locations and radii of spheres
C        IOSHP =device number for "target.out" file
C              =-1 to suppress printing of "target.out"
C        MXNAT =dimensioning information (max number of atoms)
C
C and, from input file CFLSHP:
C
C        NSPH              = number of spheres
C        one descriptive line which will be ignored (may be blank)
C        XS(1) YS(1) ZS(1) AS(1)
C        XS(2) YS(2) ZS(2) AS(2)
C        ...
C        XS(NSPH) YS(NSPH) ZS(NSPH) AS(NSPH)
C
C where XS(J),YS(J),ZS(J) = x,y,z coordinates in target frame, in
C                                 arbitrary units, of center of sphere J
C        AS(J)            = radius of sphere J (same arbitrary units)
C
C units used for XS,YS,ZS, and AS are really arbitrary: actual size of 
C overall target, in units of lattice spacing d, is controlled by
C parameter SHPAR(1) in ddscat.par
C
C Output:
C        A1(1-3)=(1,0,0)=unit vector defining target axis 1 in Target Frame
C        A2(1-3)=(0,1,0)=unit vector defining target axis 2 in Target Frame
C        NAT=number of atoms in target
C        IXYZ(1-NAT,1-3)=x/d,y/d,z/d for atoms of target
C        ICOMP(1-NAT,1-3)=composition identifier (currently 1 1 1)
C        CDESCR=description of target (up to 67 characters)
C
C B.T.Draine, Princeton Univ. Obs., 2000.06.12
C
C History:
C 00.06.12 (BTD) adapted to version 6.0 (introduce DX)
C 00.11.02 (BTD) write ICOMP to target.out
C 01.01.13 (BTD) corrected comments
C 01.04.21 (BTD) corrected comments
C 01.04.21 (BTD) corrected typo: changed
C                      YMAX=YS(1)+YS(1)
C                to    YMAX=YS(1)+AS(1)
C                Thanks to Ivan O. Sosa Perez (UNAM) for discovering
C                this error.
C 03.06.06 (BTD) corrected error in setting LMX1,...,LMZ2
C 03.11.06 (BTD) modified to use new version of PRINAXIS with eigenvalues
C                in argument list
C 04.03.19 (BTD) revert to previous version of PRINAXIS
C                change CFLSHP*13 to CFLSHP*80 to accomodate long file
c                names
c 04.05.23 (BTD) modified to obtain eigenvalues ALPHA from PRINAXIS
c                modified arg list of PRINAXIS to conform to change
C end history
C
C Copyright (C) 2000,2001,2003,2004 B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************

C Read parameters of spheres:

      OPEN(UNIT=IDVSHP,FILE=CFLSHP)
      READ(IDVSHP,*)NSPH
      READ(IDVSHP,*)
      DO JX=1,NSPH
         READ(IDVSHP,*)XS(JX),YS(JX),ZS(JX),AS(JX)
      ENDDO

      CLOSE(IDVSHP)

C Dipoles are located at sites
C (x,y,z)=(I,J,K), I,J,K=integers

C Determine max extent in X direction:

      XMIN=XS(1)-AS(1)
      XMAX=XS(1)+AS(1)
      YMIN=YS(1)-AS(1)
      YMAX=YS(1)+AS(1)
      ZMIN=ZS(1)-AS(1)
      ZMAX=ZS(1)+AS(1)
      IF(NSPH.GT.1)THEN
         DO JX=2,NSPH
            IF(XS(JX)-AS(JX).LT.XMIN)XMIN=XS(JX)-AS(JX)
            IF(XS(JX)+AS(JX).GT.XMAX)XMAX=XS(JX)+AS(JX)
            IF(YS(JX)-AS(JX).LT.YMIN)YMIN=YS(JX)-AS(JX)
            IF(YS(JX)+AS(JX).GT.YMAX)YMAX=YS(JX)+AS(JX)
            IF(ZS(JX)-AS(JX).LT.ZMIN)ZMIN=ZS(JX)-AS(JX)
            IF(ZS(JX)+AS(JX).GT.ZMAX)ZMAX=ZS(JX)+AS(JX)
         ENDDO
      ENDIF
      SCALE=DIAMX/(XMAX-XMIN)

C Now determine min,max values of I,J,K:

      LMX1=NINT(SCALE*XMIN/DX(1)-0.01)
      LMX2=NINT(SCALE*XMAX/DX(1)+0.01)
      LMY1=NINT(SCALE*YMIN/DX(2)-0.01)
      LMY2=NINT(SCALE*YMAX/DX(2)+0.01)
      LMZ1=NINT(SCALE*ZMIN/DX(3)-0.01)
      LMZ2=NINT(SCALE*ZMAX/DX(3)+0.01)

C Convert AS to squared radius:

      DO JX=1,NSPH
         AS(JX)=(SCALE*AS(JX))**2
         XS(JX)=SCALE*XS(JX)
         YS(JX)=SCALE*YS(JX)
         ZS(JX)=SCALE*ZS(JX)
      ENDDO

C Determine list of occupied sites

      NAT=0
      DO JZ=LMZ1,LMZ2
         Z=REAL(JZ)*DX(3)
         DO JY=LMY1,LMY2
            Y=REAL(JY)*DX(2)
            DO JX=LMX1,LMX2
               X=REAL(JX)*DX(1)
               OCC=.FALSE.
               DO JA=1,NSPH
                  R2=(X-XS(JA))**2+(Y-YS(JA))**2+(Z-ZS(JA))**2
                  IF(R2.LT.AS(JA))OCC=.TRUE.
               ENDDO
               IF(OCC)THEN

C Site is occupied:

                  NAT=NAT+1
                  IXYZ(NAT,1)=JX
                  IXYZ(NAT,2)=JY
                  IXYZ(NAT,3)=JZ
               ENDIF
            ENDDO
         ENDDO
      ENDDO

      IF(NAT.GT.MXNAT)THEN
         CALL ERRMSG('FATAL','TARNSP',' NAT.GT.MXNAT ')
      ENDIF

C Homogeneous target:

      DO JA=1,NAT
         DO JX=1,3
            ICOMP(JA,JX)=1
         ENDDO
      ENDDO

c*** diagnostic
c      write(0,*)'in tarsnp: made target with NAT=',NAT,' dipoles'
c***

c Specify target axes A1 and A2
c If PRINAX=0, then
c     A1=(1,0,0) in target frame
c     A2=(0,1,0) in target frame
c If PRINAX=1., then
c     A1,A2 are principal axes of largest, second largest moment of
c     inertia

      IF(PRINAX.LE.0.)THEN
         DO JX=1,3
            A1(JX)=0.
            A2(JX)=0.
         ENDDO
         A1(1)=1.
         A2(2)=1.
      ELSE
         CALL PRINAXIS(MXNAT,NAT,ICOMP,IXYZ,DX,A1,A2,ALPHA)
      ENDIF

C***********************************************************************
C Write target description into string CDESCR

      WRITE(CDESCR,FMT='(A,I7,A)')' Multisphere cluster containing',
     &   NAT,' dipoles'

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

      CMSGNM=CDESCR
      CALL WRIMSG('TARNSP',CMSGNM)
      IF(IOSHP.GE.0)THEN
         OPEN(UNIT=IOSHP,FILE='target.out',STATUS='UNKNOWN')
         WRITE(IOSHP,FMT=9020)NSPH,DIAMX,NAT,ALPHA,A1,A2
         DO JX=1,NAT
            WRITE(IOSHP,FMT=9030)JX,IXYZ(JX,1),IXYZ(JX,2),IXYZ(JX,3),
     &                           ICOMP(JX,1),ICOMP(JX,2),ICOMP(JX,3)
         ENDDO
         CLOSE(UNIT=IOSHP)
      ENDIF

      RETURN
 9020 FORMAT(' >TARNSP multisphere target composed of ',I3,' spheres, ',
     &   'DIAMX=',F8.4,/,
     &   I7,3F8.4,' = NAT, alpha_1-3',/,
     &   3F9.5,' = A_1 vector',/,
     &   3F9.5,' = A_2 vector',/,
     &   ' 1.00 1.00 1.00 = lattice spacings (d_x,d_y,d_z)/d',/,
     &'     JA  IX  IY  IZ ICOMP(x,y,z)')
 9030 FORMAT(I7,3I4,3I2)
      END
