      SUBROUTINE TAR2SP(A1,A2,A_1,B_1,A_2,B_2,PHI,PRINAX,DX,
     &                   CDESCR,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
      IMPLICIT NONE

C Arguments:

      CHARACTER CDESCR*67
      INTEGER IOSHP,MXNAT,NAT
      INTEGER*2 ICOMP(MXNAT,3),IXYZ(MXNAT,3)
      REAL A_1,A_2,B_1,B_2,PHI,PRINAX
      REAL A1(3),A2(3),DX(3)

C Local variables:

      CHARACTER CMSGNM*70
      INTEGER JA,JX,JY,JZ,LMX1,LMX2,LMY1,LMY2,LMZ1,LMZ2,
     &   NAT1,NAT2
      REAL AX2,AY2,AZ2,COSPHI,SINPHI,U,V,
     &   R,RX2,RYZ2,RZ2,X,XC1,XC2,Y,YC1,YC2,Z,ZC1,ZC2
      REAL EIGVAL(3)

C***********************************************************************
C Routine to construct two touching spheroids from "atoms"
C    First spheroid has symmetry axis in y direction.
C    Second spheroid is displaced in x direction, with symmetry
C    axis in yz plane, in direction ey*cos(phi)+ez*sin(phi).
C    Separation between centroids=(B_1+B_2)/2
C   
C Input:
C        A_1=length/d of 1st spheroid along symm.axis  (d=lattice spacing)
C        A_2=length/d of 2nd spheroid along symm.axis
C        B_1=diameter/d of 1st spheroid
C        B_2=diameter/d of 2nd spheroid
C        PHI=angle (deg) specifying relative orientation of spheroids
C        PRINAX=0. to set A1=(1,0,0),A2=(0,1,0) in Target Framee
C              =1. to set A1,A2=principal axes of largest and second 
C                               largest moment of inertia 
C        DX(1-3)=(dx/d,dy/d,dz/d) where dx,dy,dz=lattice spacing in x,y,z
C            directions, and d=(dx*dy*dz)**(1/3)=effective lattice spacing
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 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)=1 for sites within first spheroid
C                        =2 for sites within second spheroid
C        CDESCR=description of target (up to 67 characters)
C
C B.T.Draine, Princeton Univ. Obs.
C History:
C 96.01.25 (BTD): First written.
C 96.01.26 (BTD): Replaced IX,IY,IZ by IXYZ
C 96.01.29 (BTD): Modified to add PRINAX to argument list, and
C                 call to PRINAXIS to determine principal axes if
C                 PRINAX=1.
C 97.12.26 (BTD): Added DX(3) to argument list to support nonuniform
C                 lattice spacing.
C                 *** Note: additional code modifications required
C                     to support noncubic lattice!
C 98.03.06 (BTD): If called with noncubic lattice (not yet supported)
C                 call ERRMSG and halt with fatal error.
C 98.03.07 (BTD): Modified to write DX to file "target.out" for
C                 compatibility with REASHP.
C 99.06.30 (BTD): Revised procedure for constructing target.
C                 With new prescription,
C                 should obtain a symmetric structure when called
C                 with A_1,B_1 = A_2,B_2 and PHI=0 or 90
C                 Note that we have not yet made modifications 
C                 necessary to support noncubic lattice.
C 00.11.02 (BTD): Modified to write ICOMP to target.out
C 03.11.06 (BTD): Modified to use new PRINAXIS with eigenvalues in
C                 argument list.
C 04.03.19 (BTD): Revert to previous version of PRINAXIS
C 04.05.23 (BTD): Modify argument list of PRINAXIS to conform to
C                 change in PRINAXIS (eigenvalues added to arg list)
C end history
C
C Copyright (C) 1996,1997,1998,1999,2000,2003,2004
C                B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************

C Current version of TAR2SP is restricted to cubic lattices

      IF(DX(1).NE.1..OR.DX(2).NE.1.)THEN
         CALL ERRMSG('FATAL','TAR2SP',
     &               ' tar2sp does not yet support noncubic lattice')
      ENDIF

C Routine to construct target array representing two spheroids in
C contact.
C line connecting spheroid centers is parallel to x
C symmetry axis of first spheroid is parallel to y
C symmetry axis of second spheroid is in y-z plane, at angle PHI to y
C
C First spheroid:
C Array sites contained within spheroidal surface defined by
C    ((X-XC1)/B_1)**2+((Y-YC1)/A_1)**2+((Z-ZC1)/B_1)**2=0.25
C Ideal volume V=(pi/6)*A_1*B_1*B_1
C
C Second spheroid:
C    ((X-XC2)/B_2)**2+((U-UC1)/A_1)**2+((V-VC1)/B_1)**2=0.25
C where
C    U  =  Y*cos(PHI)  +  Z*sin(PHI)
C    V  = -Y*sin(PHI)  +  Z*cos(PHI)
C   UC1 = YC1*cos(PHI) + ZC1*sin(PHI)
C   VC1 =-YC1*sin(PHI) + ZC1*cos(PHI)
C    
C Dipoles are located at sites
C (x,y,z)=(I,J,K)*d, I,J,K=integers
C
C Criterion for choosing XC1:
C Point where spheroids contact each other should be midway between
C lattice points.  Thus take XC1+0.5*B_1 = 0.5
C or XC1 = 0.5(1.-B_1)
C
C Criterion for choosing YC1 and ZC1:
C If XC1 is close to an integer, take YC1=ZC1=0
C If XC1 is close to a half-integer, take YC1=ZC1=0.5
C
C Note that other criteria are obviously possible.  For example,
C could have chosen YC1 and ZC1 to maximize number of lattice
C sites falling within spheroidal surfaces.
C
      XC1=0.5*(1.-B_1)
      IF(XC1-INT(XC1).LT.0.25.OR.XC1-INT(XC1).GT.0.75)THEN
         YC1=0.
         ZC1=0.
      ELSE
         YC1=0.5
         ZC1=0.5
      ENDIF
C
      NAT=0
C             
C Determine list of occupied sites in first spheroid
C
      LMX1=INT(XC1-.5*B_1)
      LMX2=INT(XC1+.5*B_1)
      LMY1=INT(YC1-.5*A_1)
      LMY2=INT(YC1+.5*A_1)
      LMZ1=INT(ZC1-.5*B_1)
      LMZ2=INT(ZC1+.5*B_1)
      AX2=B_1*B_1
      AY2=A_1*A_1
      AZ2=B_1*B_1
      DO 0300 JZ=LMZ1,LMZ2
         Z=REAL(JZ)-ZC1
         RZ2=Z*Z/AZ2
         IF(RZ2.LT.0.25)THEN
            DO 0200 JY=LMY1,LMY2
               Y=REAL(JY)-YC1
               RYZ2=RZ2+Y*Y/AY2
               IF(RYZ2.LT.0.25)THEN
                  DO 0100 JX=LMX1,LMX2
                     X=REAL(JX)-XC1
                     R=RYZ2+X*X/AX2
                     IF(R.LT.0.25)THEN
                        NAT=NAT+1
                        IXYZ(NAT,1)=JX
                        IXYZ(NAT,2)=JY
                        IXYZ(NAT,3)=JZ
                     ENDIF
 0100             CONTINUE
               ENDIF
 0200       CONTINUE
         ENDIF
 0300 CONTINUE
      NAT1=NAT
C
C Determine occupied sites in second spheroid
C
      XC2=XC1+.5*(B_1+B_2)
      YC2=YC1
      ZC2=ZC1
      LMX1=INT(XC2-.5*B_2)
      LMX2=INT(XC2+.5*B_2)
C
C This is not time-consuming, so no need to optimize choices of 
C LMY1,LMY2,LMZ1,LMZ2
C
      LMY1=INT(YC1-.5*MAX(A_2,B_2))
      LMY2=INT(YC1+.5*MAX(A_2,B_2))
      LMZ1=INT(ZC1-.5*MAX(A_2,B_2))
      LMZ2=INT(ZC1+.5*MAX(A_2,B_2))
      SINPHI=SIN(3.1415927*PHI/180.)
      COSPHI=COS(3.1415927*PHI/180.)
C
C transform (y,z) -> (u,v) with u=y*cos(phi)-z*sin(phi)
C                               v=y*sin(phi)+z*cos(phi)
C
      DO 0600 JX=LMX1,LMX2
         X=REAL(JX)-XC2
         RX2=(X/B_2)**2
         IF(RX2.LT.0.25)THEN
            DO 0500 JY=LMY1,LMY2
               Y=REAL(JY)-YC2
               DO 0400 JZ=LMZ1,LMZ2
                  Z=REAL(JZ)-ZC2
                  U=(COSPHI*Y-SINPHI*Z)/A_2
                  V=(SINPHI*Y+COSPHI*Z)/B_2
                  R=RX2+U**2+V**2
                  IF(R.LT.0.25)THEN
C Site is occupied:
                     NAT=NAT+1
                     IXYZ(NAT,1)=JX
                     IXYZ(NAT,2)=JY
                     IXYZ(NAT,3)=JZ
                  ENDIF
 0400          CONTINUE
 0500       CONTINUE
         ENDIF
 0600 CONTINUE
      NAT2=NAT-NAT1
      IF(NAT.GT.MXNAT)THEN
          CALL ERRMSG('FATAL','TAR2SP',' NAT.GT.MXNAT ')
      ENDIF
C
      DO JX=1,3
         DO JA=1,NAT1
            ICOMP(JA,JX)=1
         ENDDO
         DO JA=NAT1+1,NAT
            ICOMP(JA,JX)=2
         ENDDO
      ENDDO

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,EIGVAL)
      ENDIF

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

      WRITE(CDESCR,FMT='(A,I7,A,I7,A,I7,A)')
     &      ' Spheroids with',NAT1,' +',NAT2,'=',NAT,' dipoles'

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

      CMSGNM=CDESCR
      CALL WRIMSG('TAR2SP',CMSGNM)
      IF(IOSHP.GE.0)THEN
         OPEN(UNIT=IOSHP,FILE='target.out',STATUS='UNKNOWN')
         WRITE(IOSHP,FMT=9020)A_1,B_1,A_2,B_2,PHI,NAT,NAT1,NAT2,A1,A2,DX
         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(' >TAR2SP: touching spheroids, A_1,B_2,A_2,B_2,PHI=',5F8.4,
     &/,3I7,' = NAT,NAT1,NAT2',/,
     &3F9.4,' = A_1 vector',/,
     &3F9.4,' = A_2 vector',/,
     &3F9.6,' = lattice spacings (d_x,d_y,d_z)/d',/,
     &'     JA  IX  IY  IZ ICOMP(x,y,z)')
 9030 FORMAT(I7,3I4,3I2)
      END
