      SUBROUTINE TAR2SP(A1,A2,A_1,B_1,A_2,B_2,PHI,PRINAX,
     &                   CDESCR,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
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        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 end history
C
C Copyright (C) 1996, B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C
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)
C** Local variables:
      CHARACTER CMSGNM*70
      INTEGER JA,JX,JY,JZ,LMX1,LMX2,LMY1,LMY2,LMZ1,LMZ2,
     &   NAT1,NAT2
      REAL AX2,AY2,AZ2,FXX,FYY,FYZ,FZZ,
     &   R,RX2,RXY2,RYZ2,RZ2,X,XOFF,Y,YOFF,Z,ZOFF
C***********************************************************************
c*** diagnostic
      write(0,*)'entered tar2sp, ioshp=',ioshp
      write(0,*)'a_1,b_1,a_2,b_2=',a_1,b_1,a_2,b_2
c***
C
C Routine to construct pseudo-spheroidal target aray.
C With occupied array sites contained within spheroidal surface
C defined by (X/A_1)**2+(Y/B_1)**2+(Z/B_1)**2=0.25
C Ideal volume V=(pi/6)*A_1*B_1*B_1
C
C Dipoles are located at sites
C (x,y,z)=(I+XOFF,J+YOFF,Z+KOFF), I,J,K=integers
C                                 XOFF,YOFF,ZOFF=constants
C
C Criterion for choosing XOFF:
C If B_1+B_2 is close to an even integer, take XOFF=1/2
C If B_1+B_2 is close to an odd integer, take XOFF=0
C
      JX=INT(B_1+B_2+.5)
      IF(2*(JX/2).EQ.JX)THEN
         XOFF=0.5
      ELSE
         XOFF=0.
      ENDIF
C 
C Criteria for YOFF and ZOFF are designed to optimize approximation
C for first spheroid, which is aligned with x,y,z axes.
C (Second spheroid need not be).
C Criterion for YOFF:
C If A_1 is close to an even integer, take YOFF=1/2
C IF A_1 is close to an odd integer, take YOFF=0
      JY=INT(A_1+.5)
      IF(2*(JY/2).EQ.JY)THEN
         YOFF=0.5
      ELSE
         YOFF=0.
      ENDIF
C
C Similar criterion for ZOFF:
C If B_1 is close to an even integer, take ZOFF=1/2
C If B_1 is close to an odd integer, take ZOFF=0
      JZ=INT(B_1+.5)
      IF(2*(JZ/2).EQ.JZ)THEN
         ZOFF=0.5
      ELSE
         ZOFF=0.
      ENDIF
C
      NAT=0
C             
C Determine list of occupied sites in first spheroid
C
      LMX1=-INT(.5*B_1+.5)
      LMX2=INT(.5*B_1-.25)
      LMY1=-INT(.5*A_1+.5)
      LMY2=INT(.5*A_1-.25)
      LMZ1=-INT(.5*B_1+.5)
      LMZ2=INT(.5*B_1-.25)
      AX2=B_1*B_1
      AY2=A_1*A_1
      AZ2=B_1*B_1
      DO 0300 JZ=LMZ1,LMZ2
         Z=REAL(JZ)+ZOFF
         RZ2=Z*Z/AZ2
         IF(RZ2.LT.0.25)THEN
            DO 0200 JY=LMY1,LMY2
               Y=REAL(JY)+YOFF
               RYZ2=RZ2+Y*Y/AY2
               IF(RYZ2.LT.0.25)THEN
                  DO 0100 JX=LMX1,LMX2
                     X=REAL(JX)+XOFF
                     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
      LMX1=INT(.5*B_1-.5)
      LMX2=INT(.5*B_1+B_2-.25)
      LMY1=-INT(.5*MAX(A_2,B_2)+.5)
      LMY2=INT(.5*MAX(A_2,B_2)-.25)
      LMZ1=LMY1
      LMZ2=LMY2
      FXX=1./B_2**2
      FYY=(COS(3.1415927*PHI/180.)/A_2)**2+
     &    (SIN(3.1415927*PHI/180.)/B_2)**2
      FZZ=(SIN(3.1415927*PHI/180.)/A_2)**2+
     &    (COS(3.1415927*PHI/180.)/B_2)**2
      FYZ=2.*SIN(3.1415927*PHI/180.)*COS(3.1415927*PHI/180.)*
     &    (1./A_2**2-1./B_2**2)
c*** diagnostic
      write(0,*)'lmx1,lmx2=',lmx1,lmx2
      write(0,*)'lmy1,lmy2=',lmy1,lmy2
      write(0,*)'lmz1,lmz2=',lmz1,lmz2
      write(0,*)'fxx,fyy,fzz,fyz=',fxx,fyy,fzz,fyz
c***
      DO 0600 JX=LMX1,LMX2
         X=REAL(JX)+XOFF
         RX2=FXX*(X-.5*(B_1+B_2))**2
         IF(RX2.LT.0.25)THEN
            DO 0500 JY=LMY1,LMY2
               Y=REAL(JY)+YOFF
               RXY2=RX2+FYY*Y*Y
               DO 0400 JZ=LMZ1,LMZ2
                  Z=REAL(JZ)+ZOFF
                  R=RXY2+FZZ*Z*Z+FYZ*Y*Z
                  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','TARELL',' NAT.GT.MXNAT ')
      ENDIF
C
      DO 0900 JX=1,3
         DO 0700 JA=1,NAT1
            ICOMP(JA,JX)=1
 0700    CONTINUE
         DO 0800 JA=NAT1+1,NAT
            ICOMP(JA,JX)=1
 0800    CONTINUE 
 0900 CONTINUE
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 0010 JX=1,3
            A1(JX)=0.
            A2(JX)=0.
 0010    CONTINUE
         A1(1)=1.
         A2(2)=1.
      ELSE
         CALL PRINAXIS(MXNAT,NAT,ICOMP,IXYZ,A1,A2)
      ENDIF
C
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
         DO 40 JX=1,NAT
            WRITE(IOSHP,FMT=9030)JX,IXYZ(JX,1),IXYZ(JX,2),IXYZ(JX,3)
   40    CONTINUE
         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',/,
     &'     JA  IX  IY  IZ')
 9030 FORMAT(I7,3I4)
      END
