      SUBROUTINE TARSLB(A1,A2,XV,YV,ZV,F1,F2,F3,
     &                  DX,CDESCR,IOSHP,MXNAT,NAT,IXYZ,ICOMP)
      IMPLICIT NONE
C***********************************************************************
C Routine to construct rectangular prism from "atoms"
C with layered structure
C slab has dimensions a,b,c in x,y,z dimensions
C current version allows for up to 4 layers
C slab is layered in x direction
C   0  < x < f1*a is composition 1
C f1*a < x < f2*a is composition 2
C f2*a < x < f3*a is composition 3
C f3*a < x <  a   is composition 4
C
C for fewer than 4 layers, let x2=x3=0 (for two layers)
C                           or x3=0    (for three layers)
C
C Input:
C        XV=(x-length)/d    (d=lattice spacing)
C        YV=(y-length)/d
C        ZV=(z-length)/d
C        F1,F2,F3 = interface locators (see above)
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        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)=unit vector (1,0,0) defining target axis 1 in Target Frame
C        A2(1-3)=unit vector (0,1,0) 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
C
C B.T.Draine, Princeton Univ. Obs.
C History:
C 98.12.29 (BTD): Created using TARREC as starting material.
C 00.11.02 (BTD): Write ICOMP to target.out
C end history
C
C Copyright (C) 1998,2000 B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
C Arguments:
      REAL F1,F2,F3,XV,YV,ZV
      INTEGER IOSHP,MXNAT,NAT
      CHARACTER CDESCR*67
      INTEGER*2 ICOMP(MXNAT,3),IXYZ(MXNAT,3)
      REAL A1(3),A2(3),DX(3)
C
C Local variables:
      INTEGER JA,JX,JY,JZ,NCOMP,NX,NX1,NX2,NX3,NY,NZ
      CHARACTER CMSGNM*70
C
C External subroutines:
      EXTERNAL ERRMSG
C
C Intrinsic functions:
      INTEGER IFIX
      INTRINSIC IFIX
C***********************************************************************

      IF(F2.LE.0.)THEN
         NCOMP=2
      ELSE
         IF(F3.LE.0.)THEN
            NCOMP=3
         ELSE
            NCOMP=4
         ENDIF
      ENDIF
      NX=IFIX(XV/DX(1)+0.5)
      NY=IFIX(YV/DX(2)+0.5)
      NZ=IFIX(ZV/DX(3)+0.5)
      WRITE(CMSGNM,FMT='(A,3I4)')
     &      ' Layered slab; NX,NY,NZ=',NX,NY,NZ
      WRITE(CDESCR,FMT='(A,3I4)')
     &      ' Layered slab; NX,NY,NZ=',NX,NY,NZ
C
      NX1=IFIX(F1*NX+0.5)
      NX2=NX
      NX3=NX
      IF(NCOMP.GE.3)NX2=IFIX(F2*NX+0.5)
      IF(NCOMP.EQ.4)NX3=IFIX(F3*NX+0.5)
C
C Specify target axes A1 and A2
C Convention: A1 will be (1,0,0) in target frame
C             A2 will be (0,1,0) in target frame
C
      DO 0100 JA=1,3
         A1(JA)=0.
         A2(JA)=0.
 0100 CONTINUE
      A1(1)=1.
      A2(2)=1.
C               
C Now populate lattice:
      NAT=0
      DO JZ=1,NZ
         DO JY=1,NY
            DO JX=1,NX1
               NAT=NAT+1
               IF(NAT.GT.MXNAT)THEN
                  CALL ERRMSG('FATAL','TARSLB',' NAT.GT.MXNAT')
               ENDIF
               IXYZ(NAT,1)=JX
               IXYZ(NAT,2)=JY
               IXYZ(NAT,3)=JZ
               ICOMP(NAT,1)=1
               ICOMP(NAT,2)=1
               ICOMP(NAT,3)=1
            ENDDO
            DO JX=NX1+1,NX2
               NAT=NAT+1
               IF(NAT.GT.MXNAT)THEN
                  CALL ERRMSG('FATAL','TARSLB',' NAT.GT.MXNAT')
               ENDIF
               IXYZ(NAT,1)=JX
               IXYZ(NAT,2)=JY
               IXYZ(NAT,3)=JZ
               ICOMP(NAT,1)=2
               ICOMP(NAT,2)=2
               ICOMP(NAT,3)=2
            ENDDO
         ENDDO
      ENDDO
      IF(NCOMP.GE.3)THEN
         DO JZ=1,NZ
            DO JY=1,NY
               DO JX=NX2+1,NX3
                  NAT=NAT+1
                  IF(NAT.GT.MXNAT)THEN
                     CALL ERRMSG('FATAL','TARSLB',' NAT.GT.MXNAT')
                  ENDIF
                  IXYZ(NAT,1)=JX
                  IXYZ(NAT,2)=JY
                  IXYZ(NAT,3)=JZ
                  ICOMP(NAT,1)=3
                  ICOMP(NAT,2)=3
                  ICOMP(NAT,3)=3
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF(NCOMP.EQ.4)THEN
         DO JZ=1,NZ
            DO JY=1,NY
               DO JX=NX3+1,NX
                  NAT=NAT+1
                  IF(NAT.GT.MXNAT)THEN
                     CALL ERRMSG('FATAL','TARSLB',' NAT.GT.MXNAT')
                  ENDIF
                  IXYZ(NAT,1)=JX
                  IXYZ(NAT,2)=JY
                  IXYZ(NAT,3)=JZ
                  ICOMP(NAT,1)=4
                  ICOMP(NAT,2)=4
                  ICOMP(NAT,3)=4
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF(NAT.GT.MXNAT)THEN
         CALL ERRMSG('FATAL','TARREC',' NAT.GT.MXNAT ')
      ENDIF
      WRITE(CMSGNM,FMT='(A, I7, A)')
     &      '  Rectangular prism of NAT=',NAT,' dipoles'
      IF(IOSHP.GE.0)THEN
         OPEN(UNIT=IOSHP,FILE='target.out',STATUS='UNKNOWN')
         WRITE(IOSHP,FMT=9020)XV,YV,ZV,NAT,A1,A2,DX
         DO JA=1,NAT
            WRITE(IOSHP,FMT=9030)JA,IXYZ(JA,1),IXYZ(JA,2),IXYZ(JA,3),
     &                           ICOMP(JA,1),ICOMP(JA,2),ICOMP(JA,3)
         ENDDO
         CLOSE(UNIT=IOSHP)
      ENDIF

      RETURN
 9020 FORMAT (' >TARREC   rectangular prism; AX,AY,AZ=',3F8.4,/,
     &I7,' = NAT',/,
     &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
