*DECK XCWTRK
      SUBROUTINE XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP,IPRT  ,
     >                  NDIM  ,ITOPT ,NVOL  ,NSUR  ,NANGL ,ISYMM ,
     >                  DENS  ,PCORN ,MXSEG ,ICODE ,TITREC)
C
C-------------------------    XCWTRK    -------------------------------
C
C 1- SUBROUTINE STATISTICS:
C     NAME     : XCWTRK
C     USE      : ANALYSE CLUSTER GEOMETRY AND PERFORM SPECULAR
C                OR ISOTROPIC TRAKING IF REQUIRED
C     MODIFIED : 92-02-18
C     AUTHOR   : G. MARLEAU
C
C 2- PARAMETERS:
C  INPUT
C     IPTRK    : POINTER TO THE EXCELL TRACKING         TYPE(C_PTR)
C     IPGEOM   : POINTER TO THE GEOMETRY                TYPE(C_PTR)
C     GEONAM   : GEOMETRY NAME                          C*12
C     IDISP    : TRACKING FILE DISPOSITION              I
C                = -1 MODIFY TRACKING FILE
C                =  0 OLD TRACKING FILE
C                =  1 NEW TRACKING FILE
C     IFTEMP   : TEMPORARY TRACKING FILE                I
C     IPRT     : PRINT OPTION                           I
C     TITREC   : TITLE FOR EXECUTION                    C*72
C  OUTPUT
C     IDISP    : TRACKING FILE DISPOSITION              I
C                = -2 NO TRAKING - ONLY ANALYSE GEOMETRY
C                     THEN ABORT (OPTION HALT)
C                = -1 MODIFY TRACKING FILE
C                =  0 OLD TRACKING FILE
C                =  1 NEW TRACKING FILE
C     NDIM     : NUMBER OF PHYSICAL DIMENSIONS          I
C     ITOPT    : TRACKING OPTION                        I
C                = 0 FINITE;   = 1 CYCLIC
C     NVOL     : NUMBER OF PHYSICAL REGIONS             I
C     NSUR     : NUMBER OF OUTER SURFACE                I
C     NANGL    : NUMBER OF ANGLES                       I
C     ISYMM    : SYMMETRY FACTOR                        I
C     DENS     : TRACK DENSITY                          R
C     PCORN    : CORNER PROXIMITY                       R
C     MXSEG    : MAXIMUM SEGMENT LENGTH                 I
C     ICODE    : ALBEDO ASSOCIATED WITH FACE            R(6)
C
C-------------------------    XCWTRK    -------------------------------
C
      USE          GANLIB
      IMPLICIT     NONE
      INTEGER      IOUT,NALB,NSTATE
      CHARACTER    NAMSBR*6
      PARAMETER   (IOUT=6,NALB=6,NSTATE=40,
     >             NAMSBR='XCWTRK')
C----
C  ROUTINE PARAMETERS
C----

      TYPE(C_PTR)  IPTRK,IPGEOM
      INTEGER      IDISP ,IFTEMP,IPRT  ,NDIM  ,ITOPT ,NVOL  ,NSUR  ,
     >             NANGL ,ISYMM ,MXSEG ,ICODE(NALB)
      REAL         DENS  ,PCORN
      CHARACTER    GEONAM*12,TITREC*7
C----
C  REDGET VARIABLES
C----
      INTEGER     ITYPLU,INTLIR
      CHARACTER   CARLIR*12
      REAL        REALIR  
      DOUBLE PRECISION DBLLIR
C----
C  LOCAL VARIABLES
C---- 
      LOGICAL      SWZERO
      CHARACTER    COMENT*80
      INTEGER      NCODE(NALB),IMS(NALB)
      REAL         ALBEDO(NALB) 
      INTEGER      ISTATE(NSTATE)
      REAL         EXTKOP(NSTATE)
      INTEGER      ILENGT,ITYLCM,NANGR ,NCOMNT,NCOR  ,NALBG,
     >             MSROD ,MAROD ,MNAN  ,NRT   ,NSURX ,NBAN ,
     >             NUNK  ,JJ    ,IHS
      REAL         COTE  ,RADMIN 
C----
C  ALLOCATABLE ARRAYS
C----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,NRINFO,NRODS,
     > NRODR,NXRI
      REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,RAN,RODS,RODR
C----
C  DEFAULT TRACKING OPTIONS:
C----
      PCORN=0.0
      CALL XDISET(ISTATE,NSTATE,0)
      CALL XDRSET(EXTKOP,NSTATE,0.0)
      CALL LCMLEN(IPTRK,'STATE-VECTOR',ILENGT,ITYLCM)
      IF(ILENGT .LE. 0 .OR. ILENGT .GT. NSTATE) THEN
        ITOPT=0
        NANGR=15
        ISYMM=1
        DENS=0.0
      ELSE
        CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
        CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP)
        ITOPT=ISTATE(9)
        NANGR=ISTATE(11)
        ISYMM=ISTATE(12)
        DENS=EXTKOP(2)
      ENDIF
C----
C  READ THE NEW TRACKING OPTIONS.
C----
      IF(IDISP .LE. 0) GO TO 200
 100  CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
      IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//
     >  ': CHARACTER DATA EXPECTED.')
      IF((CARLIR .EQ. 'TISO') .OR. (CARLIR .EQ. 'TSPC')) THEN
        IF(CARLIR .EQ. 'TSPC') THEN
          ITOPT=1
          SWZERO=.TRUE.
        ELSE
          ITOPT=0
        ENDIF
C----
C  2-D QUADRATURE PARAMETERS (ANGLE AND SPACE).
C----
        CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
        IF(ITYPLU .EQ. 3) THEN
          IF(ITOPT .EQ. 1 .AND. CARLIR .EQ. 'MEDI') THEN
            SWZERO=.FALSE.
          ELSE
            CALL XABORT('XCWTRK: *MEDI* KEYWORD EXPECTED.')
          ENDIF
          CALL REDGET(ITYPLU,NANGR,REALIR,CARLIR,DBLLIR)
        ENDIF
        IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR//
     >    ': INTEGER DATA EXPECTED.') 
        NANGR=INTLIR
        CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
        IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR//
     >    ': REAL DATA EXPECTED.')
        DENS=REALIR
      ELSE IF(CARLIR .EQ. 'HALT') THEN
C----
C  NO TRACKING OPTION
C----
        IDISP=-2
      ELSE IF(CARLIR .EQ. 'SYMM') THEN
C----
C  SYMMETRY FACTOR
C----
        CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
        IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR//
     >    ': INTEGER DATA EXPECTED.')
        ISYMM=INTLIR
      ELSE IF(CARLIR .EQ. ';') THEN
        NANGL=NANGR
        GO TO 200
      ELSE
        CALL XABORT(NAMSBR//': INVALID KEYWORD.')
      ENDIF
      GO TO 100
 200  CONTINUE
C----
C  Set NANGL for specular tracking to a valid value
C----
      IF(ITOPT .EQ. 1) THEN
        NANGL=MIN(30,NANGL)
        IF(NANGL .GT. 24) THEN
          NANGL = 30
        ELSE IF(NANGL .GT. 20) THEN
          NANGL = 24
        ELSE IF(NANGL .GT. 18) THEN
          NANGL = 20
        ELSE IF(NANGL .GT. 14) THEN
          NANGL = 18
        ELSE IF(NANGL .GT. 12) THEN
          NANGL = 14
        ELSE IF(NANGL .GT. 8) THEN
          NANGL = 12
        ELSE
          NANGL = 8
        ENDIF
        ISYMM=1
      ENDIF
C----
C  SAVE EXCELL SPECIFIC TRACKING INFORMATION.
C----
      ISTATE(1)=NVOL
      ISTATE(5)=NSUR
      ISTATE(9)=ITOPT
      ISTATE(11)=NANGR
      ISTATE(12)=ISYMM
      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE)
      EXTKOP(2)=DENS
      CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP)
C----
C  ANALYZE GEOMETRY AND STORE DESCRIPTION ON TRACKING STRUCTURE
C---- 
      CALL AXGXCW(IPGEOM,IPTRK ,IPRT  ,GEONAM,ISYMM )
C----
C  READ TRACKING STRUCTURE
C     KEYMRG   : INTEGER MERGE VECTOR
C     VOLSUR   : REAL VOLUME-SURFACE VECTOR
C     MATALB   : INTEGER MATERIAL-FACE VECTOR
C----
      CALL XDISET(ISTATE,NSTATE,0)
      CALL LCMSIX(IPTRK,'EXCELL      ',1)
      CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE       )
      NDIM  = ISTATE(1)
      NSUR  = ISTATE(2)
      NVOL  = ISTATE(3)
      NSURX = ISTATE(4)
      NBAN  = ISTATE(5)
      NUNK  = ISTATE(6)
      NRT   = ISTATE(7)
      MSROD = ISTATE(8)
      MAROD = ISTATE(9)
      MNAN  = ISTATE(10)
      ALLOCATE(KEYMRG(NUNK),VOLSUR(NUNK),MATALB(NUNK))
      ALLOCATE(NRINFO(2*MNAN),NRODS(3*NRT),NRODR(NRT),NXRI(NRT*NBAN))
      ALLOCATE(RAN(NBAN),RODS(2*NRT),RODR(MSROD*NRT))
      CALL LCMGET(IPTRK,'RAN         ',RAN   )
      IF(NSURX .EQ. 4)
     >CALL LCMGET(IPTRK,'COTE        ',COTE  )
      CALL LCMGET(IPTRK,'RADMIN      ',RADMIN)
      CALL LCMGET(IPTRK,'NRODS       ',NRODS )
      CALL LCMGET(IPTRK,'RODS        ',RODS  )
      CALL LCMGET(IPTRK,'NRODR       ',NRODR )
      CALL LCMGET(IPTRK,'RODR        ',RODR  )
      CALL LCMGET(IPTRK,'NRINFO      ',NRINFO)
      CALL LCMGET(IPTRK,'NXRI        ',NXRI  )
      CALL LCMGET(IPTRK,'KEYMRG      ',KEYMRG)
      CALL LCMGET(IPTRK,'MATALB      ',MATALB)
      CALL LCMGET(IPTRK,'VOLSUR      ',VOLSUR)
      CALL LCMSIX(IPTRK,'EXCELL      ',2)
      CALL LCMGET(IPTRK,'ALBEDO      ',ALBEDO)
      CALL LCMGET(IPTRK,'ICODE       ',ICODE )
      CALL LCMGET(IPTRK,'NCODE       ',NCODE )
      IF(ISYMM.GT.1) THEN
        DO 110 IHS=1,NALB
          IMS(IHS)=1
 110    CONTINUE 
      ELSE 
        DO 111 IHS=1,NALB
          IMS(IHS)=IHS
 111    CONTINUE
      ENDIF
      IF(IDISP .EQ. 1) THEN
        MXSEG=4*(NBAN+1+NRT*MSROD*MAROD)
        IF(ITOPT .EQ. 1) THEN
          MXSEG=16*NANGL*MXSEG
        ENDIF
        NCOMNT=5
        NCOR=1
        NALBG=NALB
        WRITE(IFTEMP) '$TRK',NCOMNT,0
        COMENT='CREATOR  : DRAGON'
        WRITE(IFTEMP) COMENT
        COMENT='MODULE   : XCWTRK'
        WRITE(IFTEMP) COMENT
        COMENT='TYPE     : CLUSTER'
        WRITE(IFTEMP) COMENT
        COMENT='GEOMETRY : '//GEONAM
        WRITE(IFTEMP) COMENT
        COMENT=TITREC
        WRITE(IFTEMP) COMENT
        WRITE(IFTEMP) NDIM,ITOPT,NVOL,NSUR,NALBG,NCOR,NANGL,MXSEG
        WRITE(IFTEMP) (VOLSUR(JJ),JJ=1,1+NSUR+NVOL)
        WRITE(IFTEMP) (MATALB(JJ),JJ=1,1+NSUR+NVOL)
        WRITE(IFTEMP) (ICODE(JJ),JJ=1,NALBG)
        WRITE(IFTEMP) (ALBEDO(JJ),JJ=1,NALBG)
C----
C  SET DEFAULT TRACKING DENSITY
C----
        IF(DENS .EQ. 0.0) DENS=5.0/RADMIN
        IF(ITOPT .EQ. 1) THEN
C----
C  SPECULAR TRACKING
C----
          CALL XCWSCL(NDIM  ,NSURX ,NVOL  ,NBAN  ,NRT   ,MSROD ,MAROD ,
     >                NANGL ,DENS  ,IFTEMP,IPRT  ,NCODE ,SWZERO,NRINFO,
     >                RAN   ,COTE  ,NRODS ,RODS  ,NRODR ,RODR  ,MXSEG ,
     >                NXRI  ,IMS   )
        ELSE
C----
C  ISOTROPIC TRACKING
C----
          CALL XCWICL(NDIM  ,NSURX ,NVOL  ,NBAN  ,NRT   ,MSROD ,MAROD ,
     >                NANGL ,DENS  ,ISYMM ,IFTEMP,IPRT  ,NRINFO,RAN   ,
     >                COTE  ,NRODS ,RODS  ,NRODR ,RODR  ,MXSEG ,NXRI  ,
     >                IMS)
        ENDIF
      ENDIF
C----
C  RELEASE BLOCKS FOR GEOMETRY
C----
      DEALLOCATE(RODR,RODS,RAN)
      DEALLOCATE(NXRI,NRODR,NRODS,NRINFO)
      DEALLOCATE(MATALB,VOLSUR,KEYMRG)
      RETURN
      END
