      SUBROUTINE TARGET(A1,A2,CSHAPE,CFLSHP,IDVSHP,IOSHP,CDESCR,MXNAT,
     &                  SHPAR,NAT,IXYZ,ICOMP,IDVOUT,
     &                  MXN3,NAT3)
C
C Arguments:
      CHARACTER CDESCR*67,CFLSHP*13,CSHAPE*6
      INTEGER IDVOUT,IDVSHP,IOSHP,MXNAT,NAT,MXN3,NAT3
      REAL A1(3),A2(3),SHPAR(6)
      INTEGER*2 IXYZ(MXNAT,3),ICOMP(MXNAT,3)
      EXTERNAL ERRMSG,REASHP,TARCYL,TARELL,TARHEX,TARREC,TARTET
C
C Local variables:
      INTEGER BLKSIZ,IPRINAX,J,J1,L,NBLOCKS
      INTEGER XYZB(3,100)
C
C***********************************************************************
C Given:
C    CSHAPE = string describing target geometry; will determine which
C             "shape" routine is invoked.  Current options are:
C             RCTNGL, ELLIPS, CYLNDR, HEXGON, TETRAH, UNICYL, ANIELL,
C             TWOELL, TWOAEL, FRMFIL, THRELL, THRAEL, CONELL, BLOCKS,
C             DW1996, TWOSPH
C    IOSHP = device number for "target.out" file
C          = -1 to suppress printing of "target.out"
C    SHPAR(1-6) = up to 6 parameters defining target geometry
C    MXNAT = limit on largest allowed value of NAT
C    MXN3  = 3*MXNAT
C    IDVOUT = 1 to print out information on target shape
C            -1 to suppress printing information on target shape
C    CFLSHP = name of target shape file if CSHAPE='FRMFIL'
C    IDVSHP = device number to use to read target shape if
C             CSHAPE='FRMFIL'
C Returns:
C    A1,A2 = two 3-vectors defining initial target orientation
C    CDESCR = string describing target
C    NAT = number of dipoles in target
C    NAT3 = 3*NAT
C    IXYZ(1-NAT,1-3)=integers fixing x,y,z coordinates of
C         occupied sites in target
C    ICOMP(1-NAT,1-3)=composition for E in x,y,z direction at each site
C
C P.J.Flatau, Colorado State University
C B.T.Draine, Princeton Univ. Observatory
C History:
C 90.11.08 (BTD): Changed DO...ENDDO to DO #...# CONTINUE
C 90.12.02 (BTD): Changed ordering of data in ICOMP
C 90.12.14 (BTD): Changed option MKRECT -> RCTNGL
C 91.05.02 (BTD): Added IDVOUT to argument list
C                 Added IDVOUT to argument list for subr. REASHP
C 91.05.23 (BTD): Added A1,A2 to arg. list for subr. REASHP
C 91.11.12 (BTD): Added IDVSHP to arg. list for TARGET and REASHP
C 92.09.21 (BTD): Added option UNIELL (uniaxial ellipsoid)
C 93.01.07 (BTD): Added option TWOELL (two touching ellipsoids,
C                 consisting of materials 1 and 2)
C 92.01.07 (BTD): Added option TWOAEL (two touching anisotropic
C                 ellipsoids, 1st with diel.fnc.1,2,3 along x,y,z
C                 2nd with diel.fnc.4,5,6 along x,y,z
C 92.01.19 (BTD): Added option THRELL (three touching anisotropic
C                 ellipsoids, 1st with diel.fnc.1,2,3 along x,y,z
C                 2nd with diel.fnc.4,5,6 along x,y,z
C                 3rd with diel.fnc.7,8,9 along x,y,z
C 93.03.12 (BTD): Changed CDESCR*60 -> CDESCR*67
C                 Moved WRITE(IDVOUT,9010) from DDSCAT to TARGET
C 93.12.14 (BTD): Corrected handling of THRELL (had assigned
C                 ICOMP=1 to 50% of sites, ICOMP=2 to other 50%)
C 94.01.27 (BTD): Replaced SHPAR1,SHPAR2,SHPAR3 by SHPAR(1-6) to
C                 allow up to 6 shape parameters
C                 Added call to TARCEL to generate two concentric
C                 ellipsoids
C 94.03.21 (BTD): Changed "CONCEL" to "CONELL" for consistency with
C                 REAPAR
C 95.12.11 (BTD): Modified to handle "BLOCKS" as target option, using
C                 subroutine TARBLOCKS
C 96.01.04 (BTD): Modified to handle "DW1996" as target option
C 96.01.25 (BTD): Modified to handle "TWOSPH" as target option
C 96.01.26 (BTD): Replaced IX,IY,IZ by IXYZ
C 96.01.29 (BTD): Added variable IPRINAX to control choice of axes A1,A2
C                 in option BLOCKS
C 97.06.04 (BTD): Corrected bug in handling of option "UNICYL" -- was
C                 not setting composition correctly after changing REAPAR
C                 so that no longer had choice of cylinder axis.
C                 Cylinder axis is always in x direction in target frame.
C                 Thanks for Mike Wolff for calling attention to the
C                 bug.
C end history
C
C Copyright (C) 1993,1994,1995,1996 B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C********************************************************************
      IF(CSHAPE.EQ.'RCTNGL')THEN
         CALL TARREC(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Homogeneous target:
         DO 100 J=1,NAT
            DO 95 l=1,3
               ICOMP(J,L)=1
   95       CONTINUE
  100    CONTINUE
      ELSEIF(CSHAPE.EQ.'ELLIPS')THEN
         CALL TARELL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Homogeneous target:
         DO 110 J=1,NAT
            DO 105 L=1,3
               ICOMP(J,L)=1
  105       CONTINUE
  110    CONTINUE
      ELSEIF(CSHAPE.EQ.'CYLNDR')THEN
         CALL TARCYL(A1,A2,SHPAR(1),SHPAR(2),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Homogeneous target:
         DO 120 J=1,NAT
            DO 115 L=1,3
               ICOMP(J,L)=1
  115       CONTINUE
  120    CONTINUE
      ELSEIF(CSHAPE.EQ.'HEXGON')THEN
         CALL TARHEX(A1,A2,SHPAR(1),SHPAR(2),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Homogeneous target:
         DO 130 J=1,NAT
            DO 125 L=1,3
               ICOMP(J,L)=1
  125       CONTINUE
  130    CONTINUE
      ELSEIF(CSHAPE.EQ.'TETRAH')THEN
         CALL TARTET(A1,A2,SHPAR(1),CDESCR,IOSHP,MXNAT,NAT,IXYZ)
C Homogeneous target:
         DO 140 J=1,NAT
            DO 135 L=1,3
               ICOMP(J,L)=1
  135       CONTINUE
  140    CONTINUE
      ELSEIF(CSHAPE.EQ.'UNICYL')THEN
         CALL TARCYL(A1,A2,SHPAR(1),SHPAR(2),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Cylinder axis is in x direction in Target Frame.
C Assume c axis to be parallel to cylinder axis
C Assume component 1 to be dielectric const. for E par. c axis
C Assume component 2 to be dielectric const. for E perp. c axis
         DO 150 J=1,NAT
            ICOMP(J,1)=1
            ICOMP(J,2)=2
            ICOMP(J,3)=2
 150     CONTINUE
C
      ELSEIF(CSHAPE.EQ.'ANIELL')THEN
         CALL TARELL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
C Dielectric constants 1,2,3 for E along directions x,y,z in Target Frame
         DO 160 J=1,NAT
            ICOMP(J,1)=1
            ICOMP(J,2)=2
            ICOMP(J,3)=3
 160     CONTINUE
C
C TWOELL -> two touching identical ellipsoids, of materials 1 and 2
C           second ellipsoid is displaced from first in x-direction
      ELSEIF(CSHAPE.EQ.'TWOELL')THEN
         CALL TAR2EL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
         J1=NAT/2
         DO 165 J=1,J1
            ICOMP(J,1)=1
            ICOMP(J,2)=1
            ICOMP(J,3)=1
 165     CONTINUE
         DO 166 J=J1+1,NAT
            ICOMP(J,1)=2
            ICOMP(J,2)=2
            ICOMP(J,3)=2
 166     CONTINUE
C
C TWOAEL -> two touching identical ellipsoids with anisotropic
C           functions.
C           second ellipsoid is displaced from first in x-direction
C           1st ellipsoid has dielectric fcns 1,2,3 in x,y,z dirs.
C           2nd ellipsoid has dielectric fcns 4,5,6 in x,y,z dirs.
      ELSEIF(CSHAPE.EQ.'TWOAEL')THEN
         CALL TAR2EL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
         J1=NAT/2
         DO 175 J=1,J1
            ICOMP(J,1)=1
            ICOMP(J,2)=2
            ICOMP(J,3)=3
 175     CONTINUE
         DO 176 J=J1+1,NAT
            ICOMP(J,1)=4
            ICOMP(J,2)=5
            ICOMP(J,3)=6
 176     CONTINUE
C
C THRELL -> three touching identical ellipsoids, of materials 1,2,3
C           second ellipsoid is displaced from first in +x-direction
C           third ellipsoid is displaced from second in +x-direction
      ELSEIF(CSHAPE.EQ.'THRELL')THEN
         CALL TAR3EL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
         J1=NAT/3
         DO 185 J=1,J1
            ICOMP(J,1)=1
            ICOMP(J,2)=1
            ICOMP(J,3)=1
 185     CONTINUE
         DO 186 J=J1+1,2*J1
            ICOMP(J,1)=2
            ICOMP(J,2)=2
            ICOMP(J,3)=2
 186     CONTINUE
         DO 187 J=2*J1+1,NAT
            ICOMP(J,1)=3
            ICOMP(J,2)=3
            ICOMP(J,3)=3
 187     CONTINUE
C
C THRAEL -> three touching identical ellipsoids with anisotropic
C           functions.
C           second ellipsoid is displaced from first in x-direction
C           1st ellipsoid has dielectric fcns 1,2,3 in x,y,z dirs.
C           2nd ellipsoid has dielectric fcns 4,5,6 in x,y,z dirs.
C           3rd ellipsoid has dielectric fcns 7,8.9 in x,y,z dirs.
      ELSEIF(CSHAPE.EQ.'THRAEL')THEN
         CALL TAR3EL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),CDESCR,IOSHP,
     &               MXNAT,NAT,IXYZ)
         J1=NAT/3
         DO 195 J=1,J1
            ICOMP(J,1)=1
            ICOMP(J,2)=2
            ICOMP(J,3)=3
 195     CONTINUE
         DO 196 J=J1+1,2*J1
            ICOMP(J,1)=4
            ICOMP(J,2)=5
            ICOMP(J,3)=6
 196     CONTINUE
         DO 197 J=2*J1+1,NAT
            ICOMP(J,1)=7
            ICOMP(J,2)=8
            ICOMP(J,3)=9
 197     CONTINUE
C
C CONELL -> two concentric ellipsoids with isotropic dielectric functions
C           1 (inner) and 2 (outer)
      ELSEIF(CSHAPE.EQ.'CONELL')THEN
         CALL TARCEL(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),SHPAR(4),SHPAR(5),
     &               SHPAR(6),CDESCR,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
C
C TAR2SP -> two touching spheroids
C
      ELSEIF(CSHAPE.EQ.'TWOSPH')THEN
         CALL TAR2SP(A1,A2,SHPAR(1),SHPAR(2),SHPAR(3),SHPAR(4),SHPAR(5),
     &               SHPAR(6),CDESCR,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
C
C BLOCKS -> target is constructed from identical cubic blocks
C           locations of blocks, and size of blocks (lattice units)
C           is specified in file 'blocks.par'
C           file structure:
C              target description
C              IPRINAX = 0 (a1=100,a2=010) or 1 (a1,a2=principal axes)
C              N = number of blocks
C              SIZE = width of one block, in lattice units
C              X Y Z = location of block 1 (in units of block width)
C              ...
C              X Y Z =    "     "    "   N  "   "    "    "     "
C
      ELSEIF(CSHAPE.EQ.'BLOCKS')THEN
         OPEN(UNIT=IDVSHP,FILE='blocks.par',STATUS='OLD',
     &        FORM='FORMATTED')
         READ(IDVSHP,FMT='(A67)')CDESCR
         READ(IDVSHP,*)IPRINAX
         READ(IDVSHP,*)NBLOCKS
         READ(IDVSHP,*)BLKSIZ
         DO J=1,NBLOCKS
            READ(IDVSHP,*)XYZB(1,J),XYZB(2,J),XYZB(3,J)
         ENDDO
         CLOSE(IDVSHP)
         CALL TARBLOCKS(A1,A2,NBLOCKS,BLKSIZ,XYZB,IPRINAX,IOSHP,
     &                  CDESCR,MXNAT,NAT,IXYZ,ICOMP)
C
C Homogeneous target:
C
         DO J=1,NAT
            DO L=1,3
               ICOMP(J,L)=1
            ENDDO
         ENDDO
C
C DW1996 -> the 13-cube target studied by Draine & Weingartner 1996
C           SHPAR(1)=width per block in lattice units
C
      ELSEIF(CSHAPE.EQ.'DW1996')THEN
         IPRINAX=1
         NBLOCKS=13
         BLKSIZ=SHPAR(1)
         XYZB(1,1)=0.
         XYZB(2,1)=1.
         XYZB(3,1)=0.
         XYZB(1,2)=1.
         XYZB(2,2)=1.
         XYZB(3,2)=0.
         XYZB(1,3)=0.
         XYZB(2,3)=2.
         XYZB(3,3)=0.
         XYZB(1,4)=1.
         XYZB(2,4)=2.
         XYZB(3,4)=0.
         XYZB(1,5)=0.
         XYZB(2,5)=1.
         XYZB(3,5)=1.
         XYZB(1,6)=1.
         XYZB(2,6)=1.
         XYZB(3,6)=1.
         XYZB(1,7)=0.
         XYZB(2,7)=2.
         XYZB(3,7)=1.
         XYZB(1,8)=1.
         XYZB(2,8)=2.
         XYZB(3,8)=1.
         XYZB(1,9)=2.
         XYZB(2,9)=1.
         XYZB(3,9)=0.
         XYZB(1,10)=2.
         XYZB(2,10)=2.
         XYZB(3,10)=0.
         XYZB(1,11)=0.
         XYZB(2,11)=0.
         XYZB(3,11)=1.
         XYZB(1,12)=0.
         XYZB(2,12)=0.
         XYZB(3,12)=2.
         XYZB(1,13)=0.
         XYZB(2,13)=1.
         XYZB(3,13)=2.
         CALL TARBLOCKS(A1,A2,NBLOCKS,BLKSIZ,XYZB,IPRINAX,IOSHP,
     &                  CDESCR,MXNAT,NAT,IXYZ,ICOMP)
         CDESCR='13-cube target used by Draine & Weingartner 1996'
C Homogeneous target:
         DO J=1,NAT
            DO L=1,3
               ICOMP(J,L)=1
            ENDDO
         ENDDO
C
C add any other specific shape routines here
C
      ELSEIF(CSHAPE.EQ.'FRMFIL')THEN
         CALL REASHP(CFLSHP,IDVOUT,IDVSHP,A1,A2,CDESCR,MXNAT,NAT,
     &                IXYZ,ICOMP,MXN3,NAT3)
      ELSE
         CALL ERRMSG('FATAL','TARGET',
     &               ' Uknown shape requested: check ddscat.par')
      ENDIF
C Check to see that arrays are large enough
      IF(NAT.GT.MXNAT)CALL ERRMSG('FATAL','TARGET',
     &                ' MXNAT < NAT; must increase MXNAT in DDSCAT')
C Write out target description
      WRITE(IDVOUT,FMT=9010)CDESCR,NAT
C
C Before returning, compute:
C
      NAT3=3*NAT
      RETURN
 9010 FORMAT(' >TARGET:',A,/,
     &       7X,I7,' = NAT0 = number of dipoles in target')
      END
