path: root/Dragon/src/XELDRV.f

*DECK XELDRV
      SUBROUTINE XELDRV(IPTRK ,IPGEOM,IPRT  ,MAXPTS,NANIS ,NORE  ,
     >                  LMERG ,KSPEC ,KTOPT ,TITREC,CUTOFX,CFTRAK,
     >                  IFTRAK,IDISP ,ISYMM ,LCACT ,NMU   ,INSB  ,
     >                  NBATCH,LBIHET,LPRISM,IZ,DELU,FRTM)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Read a Dragon tracking file to compute pij, normalize a tracking 
* file to Dragon format and produce a new tracking file in Dragon 
* format.
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): R. Roy
*
*Parameters: input
* IPTRK   pointer to the excell tracking (L_TRACK).
* IPGEOM  pointer to the geometry (L_GEOM).
* IPRT    tracking print level.
* MAXPTS  number of zones according to user.
* NANIS   anisotropy of the solution.
* NORE    track normalization flag (<=0: yes; =1: no).
* LMERG   type of volume normalization.
* KSPEC   kind of pij integration (=0: isotr.; =1: spec.).
* KTOPT   tracking type option.
* TITREC  title for this case.
* CUTOFX  mfp cutoff for specular integration.
* CFTRAK  name of the sequential binary tracking file.
* IFTRAK  unit of the sequential binary tracking file.
* IDISP   mode of the sequential binary tracking file.
* LCACT   type of polar integration for the method of characteristics.
* NMU     number of polar angles for the method of characteristics.   
* ISYMM   symmetry factor.
* INSB    type of vectorization for the calculation of CP matrices.
* NBATCH  number of tracks assigned to each OpenMP core.
* LBIHET  activation flag for the double heterogeneity option.
* LPRISM  flag for 3D prismatic geometry.
* IZ      projection axis for 3D prismatic geometry.
* DELU    user defined track spacing for 3D prismatic tracking.
* FRTM    minimum volume fraction of the grain in the representative 
*         volume for She-Liu-Shi model.
*
*-----------------------------------------------------------------------
*
      USE             GANLIB
      IMPLICIT        NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER       TITREC*72,CFTRAK*12
      TYPE(C_PTR)     IPTRK,IPGEOM
      INTEGER         IPRT,MAXPTS,NANIS,NORE,LMERG,KSPEC,KTOPT,IFTRAK,
     >                IDISP,ISYMM,LCACT,NMU,INSB,NBATCH,IZ
      REAL            CUTOFX,DELU,FRTM
      LOGICAL         LPRISM,LBIHET
*----
*  LOCAL VARIABLES
*----
      INTEGER         NSTATE
      PARAMETER      (NSTATE=40)
      INTEGER         NREG,NUNKNO,IUTYPE,ISTATE(NSTATE),IFTEMP,IFILE,
     >                ITYPE,ITOPT,ITROP,NCOMNT,NTRK,IREC,IC,IR,JR,IUNK,
     >                NSOUT,IDISPO,NDIM,NV,NS,NALBGO,NCOR,NANGL,MXSEG,
     >                NPRISM,NDIMO,NSO,NVO,NUNOLD,KDROPN,KDRCLS,NUNKNX,
     >                IOUT,ITGEO,IUSED(6),ICMAX,ICODE(6),ICOLD(6),
     >                NANGLO,MXSUB,MXSUBO,MXSEGO,ILONG,IFMT,I
      LOGICAL         LEAKSW, LELCHK, SWNOGE, SWCONS, EMPTY, LCM
      REAL            ALBEDO(6),ALBOLD(6),EXTKOP(NSTATE),
     >                ZERO,ONE,DENS,PCORN
      DOUBLE PRECISION DASCRP
      CHARACTER       GEONAM*12,CORIEN(0:3,6)*4,CUSED(0:1)*6,TEXT12*12,
     >                COMENT*80,CTRK*4
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD,KEYFLX,MATOLD,MATALB,
     > KEYMRG,MATMRG
      REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,VOLOLD,VOLSUR,VOLMRG
*
      PARAMETER     ( IUTYPE=2, IOUT=6, ZERO=0.0, ONE=1.0 )
*
      DATA          (( CORIEN(JR,IR),IR=1,6),JR=0,3)
     >              / ' 1  ',' 2  ',' 3  ',' 4  ',' 5  ',' 6  ',
     >                '****',' R+ ','****','****',' Z- ',' Z+ ',
     >                'HBC ','****','****','****',' Z- ',' Z+ ',
     >                ' X- ',' X+ ',' Y- ',' Y+ ',' Z- ',' Z+ '/
      DATA           ( CUSED(JR),JR=0,1 ) / 'UNUSED','  USED' /
*----
*  SCRATCH STORAGE ALLOCATION
*   MATCOD  material numbers for zones in the supercell.
*   VOLUME  volumes of zones in the supercell.
*   KEYFLX  zone key for the unknown vectors (fluxes...).
*----
      ALLOCATE(MATCOD(MAXPTS),KEYFLX(MAXPTS))
      ALLOCATE(VOLUME(MAXPTS))
*
      NPRISM=0
      IF( IPRT.GT.0 ) WRITE(IOUT,'(1X,A72//)') TITREC
      SWNOGE= .NOT.C_ASSOCIATED(IPGEOM)
      IF(SWNOGE) THEN
         GEONAM=' '
         IF(INSB.EQ.2) CALL XABORT('XELDRV: GEOMETRY REQUESTED')
      ELSE
         CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM)
      ENDIF
      NTRK  = 0
*
      IF( IPRT.GT.0 )THEN
         WRITE(IOUT,'(1H )')
         IF( SWNOGE )THEN
            WRITE(IOUT,'(27H ECHO = >>>   NO GEOMETRY     )')
         ELSE
            WRITE(IOUT,'(27H ECHO = >>> GEOMETRY NAME: ,A8)') GEONAM
         ENDIF
         WRITE(IOUT,'(27H ECHO = >>> TRACKING FILE: ,A8)') CFTRAK
         IF(     IDISP.EQ.-1 )THEN
            WRITE(IOUT,'(27H ECHO = >>>          DISP: ,A4)') 'MODT'
         ELSEIF( IDISP.EQ. 0 )THEN
            WRITE(IOUT,'(27H ECHO = >>>          DISP: ,A4)') 'OLDT'
         ELSEIF( IDISP.EQ.+1 )THEN
            WRITE(IOUT,'(27H ECHO = >>>          DISP: ,A4)') 'NEWT'
         ENDIF
         IF( NORE.EQ.-1 )THEN
            WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-BY ANGLE     )')
         ELSEIF( NORE.EQ. 0 )THEN
            WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-GLOBAL       )')
         ELSEIF( NORE.EQ.+1 )THEN
            WRITE(IOUT,'(36H ECHO = >>> NOT NORMALIZED          )')
         ENDIF
      ENDIF
*----
*  1)  REWIND TRACKING FILE --------------------------------------------
*----
      IF((IFTRAK.EQ.0).AND.(INSB.NE.2)) THEN
         CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE YET D'
     >   //'EFINED')
      ELSE IF((IFTRAK.NE.0).AND.(INSB.EQ.2)) THEN
         CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE EXPEC'
     >   //'TED WITH OPTION XCLL')
      ENDIF
      IF(INSB.NE.2) REWIND IFTRAK
*----
*  1.2) GET HEADER INFORMATIONS FROM *OLDT*/*MODT* FILES
*----
      NUNOLD= 0
      IFMT= 0
      IF( IDISP.LE.0 )THEN
         IREC= 1
         READ(IFTRAK,ERR=997) CTRK,NCOMNT,NTRK,IFMT
         DO 10 IC= 1, NCOMNT
            IREC= IREC+1
            READ (IFTRAK,ERR=997) COMENT
   10    CONTINUE
         IREC= IREC+1
         READ (IFTRAK,ERR=997) NDIMO,ITOPT,NVO,NSO,NALBGO,
     >                         NCOR,NANGL,MXSUB,MXSEG
         IF( NALBGO.LE.0.OR.NALBGO.GT.6 )THEN
            CALL XABORT('XELDRV: NALBG.GT.6.OR.NALBG.LE.0'//
     >                  ' ON TRACKING FILE')
         ENDIF
         NUNOLD= NVO+NSO+1
         ALLOCATE(VOLOLD(NUNOLD),MATOLD(NUNOLD))
         IREC= IREC+1
         READ (IFTRAK,ERR=997) (VOLOLD(IR),IR=1,NUNOLD)
         IREC= IREC+1
         READ (IFTRAK,ERR=997) (MATOLD(IR),IR=1,NUNOLD)
         IREC= IREC+1
         READ (IFTRAK,ERR=997) ( ICOLD(IR),IR=1,NALBGO)
         IREC= IREC+1
         READ (IFTRAK,ERR=997) (ALBOLD(IR),IR=1,NALBGO)
         IREC= IREC+1
         READ (IFTRAK,ERR=997) (DASCRP,IR=0,NDIMO*NANGL-1)
         IREC= IREC+1
         READ (IFTRAK,ERR=997) (DASCRP,IR=0,NANGL-1)
         REWIND IFTRAK
      ENDIF
*----
*  1.3) OPEN TEMP TRACKING FILE FOR *MODT*/*NEWT* FILES
*----
      ITROP = 0
      IF((IDISP.NE.0).AND.(INSB.NE.2)) THEN
         IFILE= KDROPN('DUMMYSQ',0,IUTYPE,0)
         IF( IFILE.LE.0 ) GO TO 998
         IF( IFILE.EQ.IFTRAK ) CALL XABORT('XELDRV: BAD TRACKING UNIT')
         IFTEMP = IFILE
         REWIND IFTEMP
         IF( IDISP.LT.0 )THEN
*
*           FOR *MODT* FILES, MAIN TRACKING IS COPIED ON TEMPORARY
            CALL XELCOP( IFTRAK, IFTEMP )
         ENDIF
      ENDIF
*----
*  2)  GET GEOMETRIC INFORMATIONS AND TRACK IF NECESSARY----------------
*----
      IF( SWNOGE )THEN
*----
*  2.1)  NO GEOMETRY, GET INFORMATIONS FROM *OLDT*/*MODT* FILE
*----
         IF(IDISP.GT.0) CALL XABORT('XELDRV: A RHS BINARY TRACKING FIL'
     >   //'E OR A RHS GEOMETRY MUST BE DEFINED.')
         NDIM=  NDIMO
         NSOUT= NSO
         NREG=  NVO
         NS=    NSO
         NV=    NVO
         NUNKNX= NUNOLD
         IF( NREG.GT.MAXPTS ) THEN
           WRITE(IOUT,'(28H ****** XELDRV ERROR  ******,/
     >      28H NUMBER OF REGION COMPUTED =,I10/
     >      28H MAXIMUM NUMBER OF REGION  =,I10)') NREG,MAXPTS
           CALL XABORT('XELDRV: MAXR TOO SMALL')
         ENDIF
         ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX))
         IUNK=  0
         DO 20 IR= -NS, NV
            VOLSUR(IUNK+1)= VOLOLD(IUNK+1)
            MATALB(IUNK+1)= MATOLD(IUNK+1)
            KEYMRG(IUNK+1)= IR
            IUNK= IUNK+1
   20    CONTINUE
         ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX))
         DO 21 IUNK=1,NUNKNX
             VOLMRG(IUNK)= VOLOLD(IUNK)
             MATMRG(IUNK)= MATOLD(IUNK)
   21    CONTINUE
         DEALLOCATE(MATOLD,VOLOLD)
         DO 25 IR= 1, NALBGO
             ICODE(IR)=  ICOLD(IR)
   25    CONTINUE
         ITGEO= 0
      ELSE
*----
*  2.2)  THERE IS A GEOMETRY, GO TO EXCELL MODULES TO ANALYZE IT
*----
         ISTATE(:NSTATE)=0
         CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE)
         ITYPE= ISTATE(1)
         IF( ITYPE.EQ.3.OR.ITYPE.EQ.6 )THEN
            ITGEO= 1
         ELSEIF( ITYPE.EQ. 8 .OR. ITYPE.EQ. 9 .OR.
     >           ITYPE.EQ.24 .OR. ITYPE.EQ.25 )THEN
            ITGEO= 2
         ELSEIF( ITYPE.EQ. 5 .OR. ITYPE.EQ. 7 .OR. ITYPE.EQ.20 .OR.
     >           ITYPE.EQ.21 .OR. ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN
            ITGEO= 3
         ELSE
            ITGEO= 0
         ENDIF
         IDISPO= IDISP
         NANGLO= NANGL
         MXSUBO= MXSUB
         MXSEGO= MXSEG
         IF((INSB.EQ.2).AND.(ITGEO.NE.3)) THEN
            CALL XABORT('XELDRV: XCELL TRACKING NOT AVAILABLE.')
         ENDIF
         IF( ISTATE(13).GE.1 )THEN
           IF( ITYPE.EQ.3.OR.ITYPE.EQ.20.OR.ITYPE.EQ.24 )THEN
*----
*  2.2.1.1)     EXCELL DRIVER FOR CLUSTER SINGLE CELLS
*----
             CALL XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP,
     >                   IPRT  ,NDIM  ,ITOPT ,NV    ,NS    ,NANGL ,
     >                   ISYMM ,DENS  ,PCORN ,MXSUB ,MXSEG ,ICODE ,
     >                   TITREC)
             ITROP=3
           ELSE
             CALL XABORT('XELDRV: ONLY ONE-CELL TUBE/CARCEL/HEXCEL'//
     >                   ' CLUSTERS ARE AVAILABLE')
           ENDIF
         ELSEIF( ITGEO.EQ.2 )THEN
*----
*  2.2.1.2)  EXCELL DRIVER FOR HEXAGONAL 2D/3D ASSEMBLIES
*----
           CALL XHXTRK(IPTRK ,IPGEOM,GEONAM,IDISP,IFTEMP,
     >                 IPRT  ,NDIM  ,ITOPT ,NV   ,NS    ,NANGL ,
     >                 ISYMM ,DENS  ,PCORN ,MXSEG,ICODE ,TITREC)
           MXSUB=1
           ITROP=2
         ELSEIF( ITGEO.EQ.3 )THEN
*----
*  2.2.1.3)  EXCELL DRIVER FOR CARTESIAN 2D/3D ASSEMBLIES
*----
            CALL XELTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP,
     >                  IPRT  ,NDIM  ,ITOPT ,NV    ,NS    ,NANGL ,
     >                  ISYMM ,DENS  ,PCORN ,MXSUB ,MXSEG ,ICODE ,
     >                  TITREC,INSB  ,IZ    ,LPRISM,NPRISM)
            ITROP=1
*----
*  For case with intrinsic symmetry
*  tracking performed on unfolded geometry assuming angular and spatial
*  symmetry
*  Normalization must be on global volume since only this option
*  makes sense.
*----  
            IF((ISYMM .GT. 1).AND.(LMERG .EQ. 0)) LMERG=1
         ELSE
            CALL XABORT('XELDRV: INVALID TYPE OF GEOMETRY')
         ENDIF
         IF((INSB.EQ.2).AND.(NDIM.NE.3)) THEN
            CALL XABORT('XELDRV: XCELL OPTION LIMITED TO 3D GEOMETRY.')
         ENDIF
*----
*  2.2.1.4)  RECOVER KEYMRG, MATALB AND VOLSUR
*----
         NUNKNX= NV+NS+1
         CALL LCMSIX(IPTRK,'EXCELL      ',1)
         CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
         IF(NUNKNX.NE.ISTATE(6)) CALL XABORT('XELDRV: INVALID NUNKNX.')
         ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX))
         CALL LCMGET(IPTRK,'KEYMRG      ',KEYMRG)
         CALL LCMGET(IPTRK,'MATALB      ',MATALB)
         CALL LCMGET(IPTRK,'VOLSUR      ',VOLSUR)
         CALL LCMSIX(IPTRK,'EXCELL      ',2)
*----
*  2.2.2)  MERGE SURFACES AND ZONES FOR THIS GEOMETRY
*----
         ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX))
         CALL XELCMP( NS,   NV, VOLSUR, MATALB, KEYMRG,
     >               NSOUT,  NREG, VOLMRG, MATMRG, ITGEO, ICODE)
         IF( NREG.GT.MAXPTS ) THEN
           WRITE(IOUT,'(28H ****** XELDRV ERROR  ******,/
     >      28H NUMBER OF REGION COMPUTED =,I10/
     >      28H MAXIMUM NUMBER OF REGION  =,I10)') NREG,MAXPTS
           CALL XABORT('XELDRV: MAXR TOO SMALL')
         ENDIF
         IF((IPRT.GE.1).AND.(INSB.NE.2)) THEN
            WRITE(IOUT,6002) NANGL,ISYMM,CUTOFX,DENS,PCORN
         ENDIF
         IF(INSB.EQ.2) THEN
            IF(IDISP.NE.99) CALL XABORT('XELDRV: INCONSISTENT IDISP')
            CALL LCMGET(IPTRK,'ALBEDO',ALBOLD)
         ENDIF
*
         IF( IDISP.NE.IDISPO )THEN
           CALL XABORT('XELDRV: *HALT* OPTION REQUESTED '//
     >                 ' NO FURTHER CALCULATION IS POSSIBLE')
         ELSEIF( IDISP.GT.0 )THEN
           IF(INSB.NE.2) REWIND IFTEMP
         ELSE
           IF( NANGL.NE.NANGLO )THEN
             CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '//
     >                   ' *NANGL* PARAMETER OF TRACKING FILE')
           ENDIF
           IF( MXSEG.NE.MXSEGO )THEN
             CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '//
     >                   ' *MXSEG* PARAMETER OF TRACKING FILE')
           ENDIF
           IF( MXSUB.NE.MXSUBO )THEN
             CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '//
     >                   ' *MXSUB* PARAMETER OF TRACKING FILE')
           ENDIF
         ENDIF
*----
*  2.2.3)  CHECK CONSISTENCY BETWEEN *MODT* FILE AND GEOMETRY BEFORE
*          MERGE
*----
         SWCONS=.FALSE.
         IF( IDISP.LT.0 )THEN
            SWCONS= LELCHK(NSO  ,NVO ,VOLOLD,MATOLD,ICOLD,
     >                     NS   ,NV  ,VOLSUR,MATALB,ICODE, 0)
            IF( IPRT.GT.0 )THEN
               WRITE(IOUT,'(1H )')
               IF( SWCONS )THEN
                  WRITE(IOUT,'(70H ECHO = >>>   CONSISTENCY BETWEEN '//
     >                     'TRACKING FILE AND UNMERGED GEOMETRY    /)')
               ELSE
                  WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '//
     >                     'TRACKING FILE AND UNMERGED GEOMETRY    /)')
               ENDIF
            ENDIF
         ENDIF
*----
*  2.2.4)  CHECK CONSISTENCY BETWEEN *OLDT*/*MODT* FILE AND GEOMETRY
*          AFTER MERGE
*----
         IF( IDISP.EQ.0.OR.(IDISP.LT.0.AND.(.NOT.SWCONS)) )THEN
            IF( NDIMO.NE.NDIM )THEN
              CALL XABORT('XELDRV: DIMENSION (2-D/3-D) INCONSISTENCY')
            ENDIF
            SWCONS= LELCHK(NSO  ,NVO ,VOLOLD,MATOLD,ICOLD,
     >                     NSOUT,NREG,VOLMRG,MATMRG,ICODE,IPRT)
            IF( SWCONS )THEN
               IF( IPRT.GT.0 )THEN
                  WRITE(IOUT,'(1H )')
                  WRITE(IOUT,'(70H ECHO = >>>   CONSISTENCY BETWEEN '//
     >                     'TRACKING FILE AND   MERGED GEOMETRY    /)')
               ENDIF
            ELSE
               WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '//
     >                  'TRACKING FILE AND   MERGED GEOMETRY    /)')
               CALL XABORT('XELDRV: INCONSISTENCY OF MERGED GEOMETRY '//
     >                    'WITH OLD TRACKING FILE ' )
            ENDIF
*
*           CONSISTENCY WITH MERGED GEOMETRY
*           COPY MERGED VOLUMES INTO VOLSUR ARRAY SINCE MERGE WAS DONE
            NS= NSOUT
            NV= NREG
            IUNK=  0
            DO 50 IR= -NS, NV
               VOLSUR(IUNK+1)= VOLOLD(IUNK+1)
               MATALB(IUNK+1)= MATOLD(IUNK+1)
               KEYMRG(IUNK+1)= IR
               IUNK= IUNK+1
   50       CONTINUE
         ENDIF
      ENDIF
*----
*  3)  NORMALIZE TEMPORARY FILE FOR *MODT*/*NEWT* FILES ----------------
*----
      IF((IDISP.NE.0).AND.(INSB.NE.2))THEN
*----
*  3.1)  WARNING IF THE FILE HAS *NTRK*.NE.0
*----
         IF( NTRK.NE.0 )THEN
            WRITE(IOUT,'(1H )')
            WRITE(IOUT,'(60H ECHO = >>> WARNING: TRACKING FILE'//
     >                 ' MAY ALREADY BE NORMALIZED             /)')
         ENDIF
         IF (LPRISM) THEN   
            CALL XELCTR(IFTEMP,IFTRAK,MXSUB,MXSEG,CUTOFX,ALBOLD)
         ELSE
            CALL XELNTR( NDIM, IFTEMP, IFTRAK, NORE, LMERG,
     >                   IPRT, NS, NV, VOLSUR, MATALB, KEYMRG,
     >                   NSOUT, NREG, VOLMRG, MATMRG, CUTOFX,
     >                   ITGEO, ICODE, ALBOLD, NANGL,  MXSUB,
     >                   MXSEG)
         ENDIF
         IFILE= IFTEMP
         IFTEMP= KDRCLS(IFTEMP,2)
         IF( IFTEMP.LT.0 ) GO TO 999
      ENDIF
*----
*  4)  CHARGE GEOMETRIC ALBEDOS & GET PHYSICAL ALBEDOS IF NECESSARY ----
*----
      ICMAX= 0
      DO 60 IR= 1, 6
        ALBEDO(IR)= ONE
        IUSED(IR)= 0
        ICMAX= MAX(ICMAX,ICODE(IR))
        IF( ICODE(IR).LT.0 ) ALBEDO(IR)= ALBOLD(-ICODE(IR))
   60 CONTINUE
      IF( ICMAX.GT.0 )THEN
         CALL XABORT('XELDRV: PHYSICAL ALBEDOS NOT IMPLEMENTED')
      ENDIF
      IF( KTOPT .EQ. -1) THEN
        KTOPT= ITOPT
      ENDIF
      IF(KSPEC .EQ. -1 ) THEN
        KSPEC= KTOPT
      ELSE
        KSPEC=MIN(KSPEC,KTOPT)
      ENDIF
*----
*  5)  STOCK INFORMATION (OUTPUT TO DRAGON DRIVER) ---------------------
*----
      DO 70 IR= 1, NREG
         KEYFLX(IR)= IR
         VOLUME(IR)= VOLMRG(IR+NSOUT+1)
         MATCOD(IR)= MATMRG(IR+NSOUT+1)
   70 CONTINUE
*
*     COMPUTE LEAKAGE SWITCH
      LEAKSW=.TRUE.
      DO 80 IR= -NSOUT, -1
         IUSED(-MATMRG(IR+NSOUT+1))= 1
         LEAKSW= LEAKSW .AND. ALBEDO(-MATMRG(IR+NSOUT+1)).EQ.ONE
   80 CONTINUE
      LEAKSW=.NOT.LEAKSW
      DEALLOCATE(MATMRG,VOLMRG)
      IF( (IDISP.LE.0).AND.(.NOT.SWNOGE) )THEN
         DEALLOCATE(MATOLD,VOLOLD)
      ENDIF
*
      IF( IPRT.GT.0 )THEN
         IF( IPRT.GT.1 )THEN
            WRITE(IOUT,'(8H  SIDE  ,2X,6(7X,A4))')
     >                                  (CORIEN(ITGEO,IR),IR=1,6)
            WRITE(IOUT,'(8H  GEOM #,2X,6(7X,I4.0))')
     >                                  (MAX(0,-ICODE(IR)),IR=1,6)
            WRITE(IOUT,'(8H  PHYS #,2X,6(7X,I4.0))')
     >                                  (MAX(0,ICODE(IR)),IR=1,6)
            WRITE(IOUT,'(8H  ALBEDO,2X,1P,6E11.4)')
     >                                  (ALBEDO(IR),IR=1,6)
            WRITE(IOUT,'(8H        ,2X,6(5X,A6))')
     >                                  (CUSED(IUSED(IR)),IR=1,6)
            WRITE(IOUT,'(1H )')
         ENDIF
         WRITE(IOUT,'(1H )')
         IF( KSPEC.EQ.0 )THEN
          WRITE(IOUT,'(40H ECHO = >>> ISOTROPIC CP CALCULATION       )')
         ELSEIF( KSPEC.EQ.1 )THEN
          WRITE(IOUT,'(40H ECHO = >>>  SPECULAR CP CALCULATION       )')
          IF( CUTOFX.EQ.ZERO )THEN
             WRITE(IOUT,'(27H ECHO = >>>    NO CUT-OFF     )')
          ELSE
             WRITE(IOUT,'(27H ECHO = >>> MFP.  CUT-OFF: ,1P,E11.4 )')
     >       CUTOFX
          ENDIF
         ENDIF
         WRITE(IOUT,'(28H ECHO = >>> NB. OF REGIONS: ,I5)') NREG
      ENDIF
*----
*  5.2) RELEASE SPACE ACCORDING TO INVERSE ORDER OF ALLOCATIONS
*----
      DEALLOCATE(KEYMRG,MATALB,VOLSUR)
*
*     SAVE GENERAL TRACKING INFORMATION.
      IF(NANIS.EQ.1) THEN
         NUNKNO= NREG
      ELSE
         IF( NDIM.EQ.1 )THEN
            NUNKNO= NANIS*NREG
         ELSE IF( NDIM.EQ.2 )THEN
            NUNKNO= ((NANIS*(NANIS+1))/2)*NREG
         ELSE
            NUNKNO= NANIS*NANIS*NREG
         ENDIF
      ENDIF
      CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
      ISTATE(1)=NREG
      ISTATE(2)=NUNKNO
      IF(LEAKSW) THEN
         ISTATE(3)=0
      ELSE
         ISTATE(3)=1
      ENDIF
      IR=0
      DO 100 I=1,NREG
      IR=MAX(IR,MATCOD(I))
  100 CONTINUE
      ISTATE(4)=IR
      ISTATE(5)=NSOUT
      ISTATE(6)=NANIS
      ISTATE(7)=ITROP
      ISTATE(8)=NORE
      ISTATE(9)=KTOPT
      ISTATE(10)=KSPEC
      ISTATE(13)=LCACT
      ISTATE(14)=NMU
      ISTATE(16)=NDIM
      ISTATE(22)=INSB
      ISTATE(27)=NBATCH
      ISTATE(39)=NPRISM
      IF(LBIHET) ISTATE(40)=1
      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE)
      CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MATCOD)
      CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOLUME)
      CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYFLX)
      CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE)
      CALL LCMPUT(IPTRK,'ALBEDO',6,2,ALBEDO)
      CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP)
      EXTKOP(39)=FRTM
      EXTKOP(40)=DELU
      CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP)
      IF(IPRT.GE.1) THEN
        WRITE(IOUT,6000) IPRT,(ISTATE(IR),IR=1,12),ISTATE(22),
     >  ISTATE(16),ISTATE(27),ISTATE(39),ISTATE(40)
        WRITE(IOUT,6001)(EXTKOP(IR),IR=1,3)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(VOLUME)
      DEALLOCATE(KEYFLX,MATCOD)
      RETURN
*
 6000 FORMAT(' EXCELT PRINT LEVEL =',I8/
     > ' TRACK STATE-VECTOR'/' ------------------'/
     > ' NREG   =',I8,' (NUMBER OF REGIONS)'/
     > ' NUNKNO =',I8,' (NUMBER OF UNKNOWNS IN SYSTEM)'/
     > ' ILEAK  =',I8,' (LEAKAGE FLAG:0=PRESENT/1=ABSENT)'/
     > ' MAXMIX =',I8,' (NUMBER OF MIXTURES)'/
     > ' NSOUT  =',I8,' (NUMBER OF OUTER SURFACES)'/
     > ' NANIS  =',I8,' (FLUX ANISOTROPY ORDER)'/
     > ' ITROP  =',I8,' (GEOMETRY TYPE)'/
     > ' NORE   =',I8,' (TRACK NORMALIZATION OPTION)'/
     > ' KTOPT  =',I8,' (TYPE OF TRACKING:0=TISO/1=TSPC)'/
     > ' KSPEC  =',I8,' (TYPE OF BOUNDARY CONDITION)'/
     > ' NANGL  =',I8,' (USER-SUPPLIED NUMBER OF TRACKING ANGLES)'/
     > ' ISYMM  =',I8,' (USER-SUPPLIED TRACKING SYMMETRY FACTOR)'/
     > ' INSB   =',I8,' (TYPE OF VECTORIZATION:0=ONEG/1=ALLG/2=XCLL)'/
     > ' NDIM   =',I8,' (NUMBER OF GEOMETRIC DIMENSIONS)'/
     > ' NBATCH =',I8,' (NUMBER OF TRACKS IN EACH OPENMP CORE)'/
     > ' NPRISM =',I8,' (NUMBER OF PLANS IN 3D PRISMATIC GEOMETRIES)'/
     > ' IBIHET =',I8,' (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)'/
     > ' -----------------'/)
 6001 FORMAT(
     > ' EXCELL TRACK OPTIONS '/
     > ' CUTOFX =',F20.8,' (CUTOFF FOR TRACK LENGTH)'/
     > ' DENS   =',F20.8,' (TRACK DENSITY)'/
     > ' PCORN  =',F20.8,' (CORNER DUPLICATION DISTANCE)'/
     > ' -----------------'/)
 6002 FORMAT(
     > ' RECOMPUTED PARAMETERS '/
     > ' NANGL  =',I10  ,' (NUMBER OF TRACKING ANGLES)'/
     > ' ISYMM  =',I10  ,' (TRACKING SYMMETRY FACTOR)'/
     > ' CUTOFX =',F10.5,' (CUTOFF FOR TRACK LENGTH)'/
     > ' DENS   =',F10.5,' (TRACK DENSITY)'/
     > ' PCORN  =',F10.5,' (CORNER DUPLICATION DISTANCE)'/
     > ' -----------------'/)
*
  997 WRITE(IOUT,'(31H ERROR= RECORD DESTROYED...        )')
      WRITE(IOUT,'(31H ERROR= UNABLE TO READ  RECORD ,I10)') IREC
      WRITE(IOUT,'(31H ERROR=              ON FILE FT,I2.2)') IFILE
      CALL XABORT('XELDRV: READ  TRACKING FILE FAILED' )
  998 WRITE(IOUT,'(31H ECHO = UNABLE TO OPEN  FILE FT,I4)') IFILE
      CALL XABORT('XELDRV: OPEN FAILED')
  999 WRITE(IOUT,'(31H ECHO = UNABLE TO CLOSE FILE FT,I4)') IFILE
      CALL XABORT('XELDRV: CLOSE FAILED')
*
      END