Initial commit from Polytechnique Montreal

1 files changed, 609 insertions, 0 deletions

diff --git a/Dragon/src/XELNTR.f b/Dragon/src/XELNTR.f
new file mode 100644
index 0000000..af747b5
--- /dev/null
+++ b/Dragon/src/XELNTR.f
@@ -0,0 +1,609 @@
+*DECK XELNTR
+      SUBROUTINE XELNTR(   NDIM,  IFOLD, IFTRAK,   NORE,  LMERG,
+     >                     IPRT,     NS,     NV,  VOLIN,  MATIN,
+     >                    MRGIN,  NSOUT,  NVOUT, VOLOUT, MATOUT,
+     >                   CUTOFX,  ITGEO,  ICODE, ALBEDO,  NANGL,
+     >                      KIN,    LIN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute renormalized tracks to obtain true volume values. The file 
+* IFOLD contains the old tracks while the file IFTRAK will contain the 
+* normalized tracks.
+*
+*Copyright:
+* Copyright (C) 1991 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
+* NDIM    number of dimensions.                  
+* IFOLD   unnormalized tracking file number (at input).     
+* IFTRAK  normalized tracking file number (at output).    
+* NORE    integer flag for normalization:               
+*         -1 normalize to volume (angle dependent);  
+*          0 normalize to volume (angle independent);
+*          1 do not normalize.                       
+* LMERG   second integer flag for normalization:        
+*          0 preserve volumes of fine regions;       
+*          1 preserve volumes of merged regions .    
+* IPRT    intermediate printing level for prinout.     
+* NS      number of surfaces before merging.                
+* NV      number of zones before merging.                   
+* VOLIN   volumes and surfaces before merging.           
+* MATIN   material numbers before merging.                  
+* MRGIN   merging index.                               
+* NSOUT   number of surfaces after  merging.                
+* NVOUT   number of zones after  merging.                   
+* VOLOUT  volumes and surfaces after  merging.           
+* MATOUT  material numbers before merging.                  
+* CUTOFX  cutoff factor.                               
+* ITGEO   kind of geometry.                            
+* ICODE   index of boundary conditions.                
+* NANGL   number of angles to renormalize tracks by angle.  
+* KIN     max. number of subtracks in a single track.       
+* LIN     max. number of track segments in a single track.  
+*
+*Parameters: output
+* ALBEDO  geometric albedos on external faces.         
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT           NONE
+*
+      INTEGER            NDIM,IFOLD,IFTRAK,NORE,LMERG,IPRT,NS,NV,
+     >                   MATIN(-NS:NV),MRGIN(-NS:NV),NSOUT,NVOUT,
+     >                   MATOUT(-NSOUT:NVOUT),ITGEO,ICODE(6),NANGL,
+     >                   KIN,LIN
+      INTEGER            IANG,IC,IL,IP,IR,ISPEC,ITRAK,IVS,IVSC,JR,
+     >                   LINE,MNSUR,MXSUB,MXSEG,MXVOL,NANG2,NBTRK,
+     >                   NCOMNT,IOUT,JL,NALBG,NCOR,NSCRP,NSURC,NSURM,
+     >                   NVOLC,NVOLM,NTMP,NSREN,NVREN,IPREN,NCSEG,
+     >                   NOLDS,NNEWS,IFMT,II,NSUB,IND,IREG,IVSMAX(2)
+      REAL               ERRCUR
+      REAL               VOLIN(-NS:NV),VOLOUT(-NSOUT:NVOUT),
+     >                   ASCRP,ALBEDO(6),ERRSUR,ERRVOL,CUTOFX,VOLMIN,
+     >                   TMPERR(10),ERRVM,ERRSM
+      DOUBLE PRECISION   APRSUR,APRVOL,TOTVOL,TOTSUR,ZERO,ONE,TWO,
+     >                   FOUR,HALF,QUART,HUND,PI,FACVOL,FACSUR,VOLREF,
+     >                   AVGREN,WEIGHT,RCUT,DASCRP
+      LOGICAL            LNEW
+      CHARACTER          CTRK*4, COMENT*80, CORIEN(0:3,-6:0)*4
+      PARAMETER        ( PI=3.14159265358979323846D0, IOUT=6,
+     >                   ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
+     >                   HUND=1.D2, HALF=0.5D0, QUART=0.25D0 )
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: NRSEG,KANGL
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DENSTY
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PATH
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: ANGLES
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: VOLTRK
+      DATA         ((CORIEN(JR,IR),IR=-6,0),JR=0,3)
+     >       / ' 6  ',' 5  ',' 4  ',' 3  ',' 2  ',' 1  ','    ',
+     >         ' Z+ ',' Z- ','****','****',' R+ ','****','    ',
+     >         ' Z+ ',' Z- ','****','****','****','HBC ','    ',
+     >         ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ','    '/
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   VOLTRK: volumes & surfaces as computed by tracking.
+*   ANGLES: x,y,z components of angles.
+*   DENSTY: weights by angle.
+*   PATH  : relative path of each segment in a track.
+*   NRSEG : material identification in a track.
+*----
+      ALLOCATE(KANGL(KIN),NRSEG(LIN))
+      ALLOCATE(ANGLES(3,NANGL),DENSTY(NANGL),PATH(LIN))
+      ALLOCATE(VOLTRK(-NS:NV,0:NANGL))
+*
+*     READ FIRST RECORDS OF THE TRACKING FILE
+      READ (IFOLD ) CTRK,NCOMNT,NSCRP,NSCRP
+      DO 5 IC= 1, NCOMNT
+         READ (IFOLD ) COMENT
+    5 CONTINUE
+      READ (IFOLD ) NSCRP,ISPEC,NSCRP,NSCRP,NALBG,NCOR,NSCRP,NSCRP,NSCRP
+      IF( NALBG.LE.0.OR.NALBG.GT.6 )THEN
+         CALL XABORT('XELNTR: NALBG.GT.6.OR.NALBG.LE.0'//
+     >               ' ON TRACKING FILE')
+      ENDIF
+      READ (IFOLD )  (ASCRP,IR=-NS,NV)
+      READ (IFOLD )  (NSCRP,IR=-NS,NV)
+      READ (IFOLD )  (NSCRP,     IR=1,NALBG)
+      READ (IFOLD )  (ALBEDO(IR),IR=1,NALBG)
+      READ (IFOLD ) ((ANGLES(IR,JR),IR=1,NDIM),JR=1,NANGL)
+      READ (IFOLD )  (DENSTY(JR),JR=1,NANGL)
+*
+      FACSUR= 0.0D0
+      FACVOL= TWO
+      IF( ISPEC.EQ.0 )THEN
+         IF( NDIM.EQ.2 )THEN
+            FACSUR= QUART*PI
+         ELSEIF( NDIM.EQ.3 )THEN
+            FACSUR= ONE
+         ENDIF
+      ELSEIF( ISPEC.EQ.1 )THEN
+         IF( NDIM.EQ.2 )THEN
+            FACSUR= HALF*PI
+         ELSEIF( NDIM.EQ.3 )THEN
+            FACSUR= ONE
+         ENDIF
+      ENDIF
+*
+*     INITIALIZE NORMALIZED FACTORS
+*     NORE = -1 -> ANGLE DEPENDENT NORMALIZATION
+*          =  0 -> ANGLE INDEPENDENT NORMALIZATION
+*          =  1 -> NO NORMALIZE BUT FIND TRACK ERROR ON MERGED VOLUME
+*     LMERG = 0 -> NORMALIZATION PRESERVE FINE VOLUMES
+*           = 1 -> NORMALIZATION PRESERVE MERGED VOLUMES FROM KEYMRG
+      NSREN=NSOUT
+      NVREN=NVOUT
+      IF(LMERG.EQ.0) THEN
+        NSREN=NS
+        NVREN=NV
+      ENDIF
+      DO 10 IVS= -NSREN, NVREN
+        DO 11 IANG= 0, NANGL
+           VOLTRK(IVS,IANG)= ZERO
+   11 CONTINUE
+   10 CONTINUE
+*
+*     COMPUTE CUTOFF FOR LINE RELATIVE TO MERGED VOLUME
+      VOLMIN=VOLOUT(1)
+      DO 12 IVS= 2, NVOUT
+        VOLMIN= MIN(VOLMIN,VOLOUT(IVS))
+   12 CONTINUE
+      RCUT= VOLMIN*CUTOFX
+      IF( IPRT.GE.999 )THEN
+         WRITE(IOUT,'(11X,A32,F20.15)')
+     >      'CUTOFF FACTOR FOR LINES    =    ',RCUT
+      ENDIF
+*
+*     LOOP OVER TRACKING (UNNORMALIZED TRACKS)
+*     AND COMPUTE VOLUME OF TRACK
+      NBTRK= 0
+      MXSUB= 0
+      MXSEG= 0
+      IF( IPRT .GE. 999 ) THEN
+        WRITE(IOUT,'(A22)') 'INITIAL line segments ' 
+      ENDIF
+   20 CONTINUE
+      READ(IFOLD,END=40) NSUB,LINE,WEIGHT,
+     >                   (KANGL(II),II=1,NSUB),
+     >                   (NRSEG(IL),IL=1,LINE),
+     >                   (PATH(IL),IL=1,LINE)
+      IF( NSUB.GT.KIN )THEN
+         WRITE(IOUT,'(11X,A32,I20)')
+     >   'NUMBER OF SUBTRACKS IN LINE =    ',NSUB
+         WRITE(IOUT,'(11X,A32,I20)')
+     >   'MAXIMUM NUMBER OF SUBTRACKS =    ',KIN
+         CALL XABORT( 'XELNTR: TRACKING FILE CORRUPTED' )
+      ELSE IF( LINE.GT.LIN )THEN
+         WRITE(IOUT,'(11X,A32,I20)')
+     >   'NUMBER OF ELEMENTS IN LINE =    ',LINE
+         WRITE(IOUT,'(11X,A32,I20)')
+     >   'MAXIMUM NUMBER OF ELEMENTS =    ',LIN
+         CALL XABORT( 'XELNTR: TRACKING FILE CORRUPTED' )
+      ENDIF
+      MXSUB= MAX(MXSUB,NSUB)
+      MXSEG= MAX(MXSEG,LINE)
+      IF(ISPEC.EQ.1) THEN
+*       ANGULAR-DEPENDENT INTEGRATION OF A CYCLIC MULTI-TRACK
+        IND=0
+        LNEW=.TRUE.
+        DO 31 IL=1,LINE
+          IREG=NRSEG(IL)
+          IF(LMERG.EQ.0) THEN
+            IPREN=IREG
+          ELSE
+            IPREN=MRGIN(IREG)
+          ENDIF
+          IF(IREG.GT.0) THEN
+            IF(LNEW) THEN
+              IND=IND+1
+              IF(IND.GT.NSUB) CALL XABORT('XELNTR: NSUB OVERFLOW')
+              LNEW=.FALSE.
+            ENDIF
+            IANG=KANGL(1)
+            VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL)
+          ELSE
+            LNEW=.TRUE.
+            IANG=KANGL(1)
+            VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL)
+          ENDIF
+   31   CONTINUE
+        IF(IND.NE.NSUB) CALL XABORT('XELNTR: ALGORITHM FAILURE')
+      ELSE
+        DO 32 IL  = 1, LINE
+          IF(LMERG.EQ.0) THEN
+            IPREN=NRSEG(IL)
+          ELSE
+            IPREN=MRGIN(NRSEG(IL))
+          ENDIF
+          IANG=KANGL(1)
+          VOLTRK(IPREN,IANG)= VOLTRK(IPREN,IANG) + WEIGHT*PATH(IL)
+   32   CONTINUE
+      ENDIF
+      NBTRK= NBTRK + 1
+      IF( IPRT .GE. 999 ) THEN
+        WRITE(IOUT,6100) NBTRK,IANG,LINE,WEIGHT,WEIGHT/DENSTY(IANG) 
+        WRITE(IOUT,6101)
+     >       (PATH(JL),NRSEG(JL),MRGIN(NRSEG(JL)),JL=1,LINE)
+      ENDIF
+      GO TO 20
+*
+*     COMPUTE TRACK NORMALIZATION FACTOR
+   40 CONTINUE
+      DO 47 IVS=  -NSREN, NVREN
+        IF(LMERG.EQ.0) THEN
+          VOLREF=DBLE(VOLIN(IVS))
+        ELSE
+          VOLREF=DBLE(VOLOUT(IVS))
+        ENDIF
+        DO 46 IANG= 1, NANGL
+           VOLTRK(IVS,0)= VOLTRK(IVS,0) + VOLTRK(IVS,IANG)
+           VOLTRK(IVS,IANG)= VOLTRK(IVS,IANG)*DENSTY(IANG)
+           IF( VOLTRK(IVS,IANG).NE.ZERO )THEN
+              VOLTRK(IVS,IANG)= VOLREF/VOLTRK(IVS,IANG)
+           ELSE
+              VOLTRK(IVS,IANG)= ONE
+           ENDIF
+   46   CONTINUE
+   47 CONTINUE
+      IF(NORE .EQ. 0) THEN
+        DO 48 IVS= 1, NVREN
+          AVGREN=DBLE(VOLOUT(IVS))/(VOLTRK(IVS,0)*FACVOL)
+          DO 44 IANG= 1, NANGL
+            VOLTRK(IVS,IANG)=AVGREN
+   44     CONTINUE
+   48   CONTINUE
+      ENDIF
+*
+*     COMPUTE ERRORS ON VOLUMES
+      TOTSUR=ZERO
+      APRSUR=ZERO
+      TOTVOL=ZERO
+      APRVOL=ZERO
+      ERRSM=0.0
+      ERRVM=0.0
+      IVSMAX(1)=0
+      IVSMAX(2)=0
+      IVSC=0 
+      DO 50 IVS= -NSREN, NVREN
+         IF( LMERG.EQ.0 )THEN
+            VOLREF=DBLE(VOLIN(IVS))
+         ELSE
+            VOLREF=DBLE(VOLOUT(IVS))
+         ENDIF
+         IF( VOLTRK(IVS,0).EQ.ZERO .AND. VOLREF.GT.ZERO )THEN
+            IF( IVS.LT.0 )THEN
+               IF( LMERG.EQ.0 )THEN
+                  WRITE(IOUT,9010) IVS
+               ELSE
+                  WRITE(IOUT,9011) IVS
+               ENDIF
+            ELSEIF( IVS.GT.0 )THEN
+               IF( LMERG.EQ.0 )THEN
+                  WRITE(IOUT,9000) IVS
+               ELSE
+                  WRITE(IOUT,9001) IVS
+               ENDIF
+            ENDIF
+            IVSC=IVS
+         ENDIF
+         IF( IVS.LT.0 )THEN
+            VOLTRK(IVS,0)= FACSUR*VOLTRK(IVS,0)
+            IF( VOLIN(IVS).NE.0.0 )THEN
+               ERRCUR=REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLREF))
+               IF(ERRCUR .GT. ERRSM) THEN
+                 IVSMAX(1)=IVS  
+                 ERRSM=ERRCUR
+               ENDIF
+            ENDIF
+            TOTSUR=TOTSUR+VOLREF
+            APRSUR=APRSUR+VOLTRK(IVS,0)
+         ELSEIF( IVS.GT.0 )THEN
+            VOLTRK(IVS,0)= FACVOL*VOLTRK(IVS,0)
+            TOTVOL=TOTVOL+VOLREF
+            APRVOL=APRVOL+VOLTRK(IVS,0)
+            IF( VOLREF.NE.ZERO )THEN
+               ERRCUR=REAL(100.0*ABS(1.0-VOLTRK(IVS,0)/VOLREF))
+               IF(ERRCUR .GT. ERRVM) THEN
+                 IVSMAX(2)=IVS  
+                 ERRVM=ERRCUR
+               ENDIF
+            ENDIF
+         ENDIF
+   50 CONTINUE
+      ERRSUR=100.*(1.0-REAL(APRSUR/TOTSUR))
+      ERRVOL=100.*(1.0-REAL(APRVOL/TOTVOL))
+*
+*     CONSTRUCT THE NEW TRACKING FILE
+      REWIND IFOLD
+      READ (IFOLD ) CTRK,NSCRP,NSCRP,IFMT
+      WRITE(IFTRAK) CTRK,NCOMNT,NBTRK,IFMT
+      DO 55 IC= 1, NCOMNT
+         READ (IFOLD ) COMENT
+         WRITE(IFTRAK) COMENT
+   55 CONTINUE
+      READ (IFOLD )  (NSCRP,IR=1,9)
+      WRITE(IFTRAK) NDIM,ISPEC,NVOUT,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG
+      READ (IFOLD )  (ASCRP,     IR=-NS,NV)
+      WRITE(IFTRAK)  (VOLOUT(IR),IR=-NSOUT,NVOUT)
+      READ (IFOLD )  (NSCRP,     IR=-NS,NV)
+      WRITE(IFTRAK)  (MATOUT(IR),IR=-NSOUT,NVOUT)
+      READ (IFOLD )  (NSCRP,     IR=1,NALBG)
+      WRITE(IFTRAK)  ( ICODE(IR),IR=1,NALBG)
+      READ (IFOLD )  (ASCRP,     IR=1,NALBG)
+      WRITE(IFTRAK)  (ALBEDO(IR),IR=1,NALBG)
+      READ (IFOLD ) ((DASCRP,     IR=1,NDIM ),JR=1,NANGL)
+      WRITE(IFTRAK) ((ANGLES(IR,JR),IR=1,NDIM),JR=1,NANGL)
+      READ (IFOLD )  (DASCRP,     JR=1,NANGL)
+      WRITE(IFTRAK)  (DENSTY(JR),JR=1,NANGL)
+      IF( IPRT .GE. 999 ) THEN
+        WRITE(IOUT,'(A22)') 'FINAL line segments   ' 
+      ENDIF
+      DO 70 ITRAK=1, NBTRK
+         READ(IFOLD) NSUB,LINE,WEIGHT,
+     >               (KANGL(II),II=1,NSUB),
+     >               (NRSEG(IL),IL=1,LINE),
+     >               (PATH(IL),IL=1,LINE)
+         IF(NSUB.GT.MXSUB) CALL XABORT('XELNTR: MXSUB overflow.')
+         IF(RCUT .GT. 0.0)THEN
+            IL= 0
+   23       CONTINUE
+               IF(IL.EQ.LINE) GO TO 25
+               IL= IL+1
+               IF(PATH(IL).LT.RCUT)THEN
+                  IF(IL.NE.LINE)THEN
+                     DO 24 JL= IL+1, LINE
+                        NRSEG(JL-1)= NRSEG(JL)
+                        PATH(JL-1)=  PATH(JL)
+   24                CONTINUE
+                  ELSE
+                     LINE= LINE-1
+                     GO TO 25
+                  ENDIF
+                  LINE= LINE-1
+                  IL= IL-1
+               ENDIF
+               GO TO 23
+   25       CONTINUE
+         ENDIF
+*
+*        RENORMALIZE TRACK LENGHTS
+         IF((NORE.EQ.-1) .AND. (NSUB.GT.1) ) THEN
+*          ANGULAR-DEPENDENT NORMALIZATION OF A CYCLIC MULTI-TRACK
+           IND=0
+           LNEW=.TRUE.
+           DO 56 IL=1,LINE
+             IREG=NRSEG(IL)
+             IF(LMERG.EQ.0) THEN
+                IPREN=IREG
+             ELSE
+                IPREN=MRGIN(IREG)
+             ENDIF
+             IF(IREG.GT.0) THEN
+               IF(LNEW) THEN
+                 IND=IND+1
+                 IF(IND.GT.NSUB) CALL XABORT('XELNTR: NSUB overflow')
+                 LNEW=.FALSE.
+               ENDIF
+               IANG=KANGL(1)
+               PATH(IL)= VOLTRK(IPREN,IANG) * PATH(IL)
+             ELSE
+               LNEW=.TRUE.
+             ENDIF
+   56      CONTINUE
+           IF(IND.NE.NSUB) CALL XABORT('XELNTR: Algorithm failure')
+         ELSE IF(NORE.LT.1 ) THEN
+            DO 60 IL  = 1, LINE
+               IF( NRSEG(IL).GT.0 )THEN
+                  IF(LMERG.EQ.0) THEN
+                     IPREN=NRSEG(IL)
+                  ELSE
+                     IPREN=MRGIN(NRSEG(IL))
+                  ENDIF
+                  IANG=KANGL(1)
+                  PATH(IL)= VOLTRK(IPREN,IANG) * PATH(IL)
+               ENDIF
+   60       CONTINUE
+         ENDIF
+*
+*        CHANGE #ING ACCORDING TO MERGES
+         DO 65 IL  = 1, LINE
+             NRSEG(IL)= MRGIN(NRSEG(IL))
+   65    CONTINUE
+*
+*        START MODIFICATIONS 98/06/02
+*        COMPRESS TRACKING FILE FOR SUCCESSIVE IDENTICAL REGIONS
+         NOLDS=NRSEG(1)
+         NCSEG=1
+         DO 66 IL = 2, LINE
+            NNEWS=NRSEG(IL)
+            IF( NNEWS.LT.0 .OR. NNEWS.NE.NOLDS )THEN
+               NOLDS=NNEWS
+               NCSEG=NCSEG+1
+               NRSEG(NCSEG)=NRSEG(IL)
+               PATH(NCSEG)=PATH(IL)
+            ELSEIF( NNEWS.EQ.NOLDS )THEN
+               PATH(NCSEG)=PATH(NCSEG)+PATH(IL)
+            ENDIF
+ 66      CONTINUE
+         WRITE(IFTRAK) NSUB,NCSEG,WEIGHT,
+     >                (KANGL(II),II=1,NSUB),
+     >                (NRSEG(IL),IL=1,NCSEG),
+     >                (PATH(IL),IL=1,NCSEG)
+         IF( IPRT.GE.999 ) THEN
+              WRITE(IOUT,'(2H #,I8,12H WRITE IANG=,I8,5H LEN=,I8)')
+     >                       ITRAK,            IANG,      NCSEG
+              WRITE(IOUT,'(1P,(1X,E15.6,1X,I8))' )
+     >                 (PATH(JL),NRSEG(JL),JL=1,NCSEG)
+         ENDIF
+*       END MODIFICATIONS 98/06/02
+*
+   70 CONTINUE
+      IF(IPRT .GE. 5) THEN
+         MNSUR = -NSREN
+         MXVOL =  NVREN
+         NSURC = -1
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,7000) ERRSUR,ERRSM
+         WRITE(IOUT,7005) -IVSMAX(1),4.0*VOLTRK(IVSMAX(1),0)
+         DO 80 IP  = 1, (9 - MNSUR) / 10
+            NSURM= MAX( MNSUR, NSURC-9 )
+            WRITE(IOUT,7100)(' FACE',-IR,IR=NSURC,NSURM,-1)
+            IF(LMERG.EQ.0) THEN
+              WRITE(IOUT,7110)
+     >             (4.*VOLIN(IR),IR=NSURC,NSURM,-1)
+              WRITE(IOUT,7111)
+     >             (CORIEN(ITGEO,MATIN(IR)),IR=NSURC,NSURM,-1)
+            ELSE
+              WRITE(IOUT,7110)
+     >             (4.*VOLOUT(IR),IR=NSURC,NSURM,-1)
+              WRITE(IOUT,7111)
+     >             (CORIEN(ITGEO,MATOUT(IR)),IR=NSURC,NSURM,-1)
+            ENDIF
+            WRITE(IOUT,7101) (FOUR*VOLTRK(IR,0),IR=NSURC,NSURM,-1)
+            NTMP=0
+            DO 81  IR=NSURC,NSURM,-1
+              IF(LMERG.EQ.0) THEN
+                VOLREF=DBLE(VOLIN(IR))
+              ELSE
+                VOLREF=DBLE(VOLOUT(IR))
+              ENDIF
+              NTMP=NTMP+1
+              IF(VOLREF.NE.ZERO) THEN
+                TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLREF)
+              ELSE
+                TMPERR(NTMP)=0.0
+              ENDIF
+  81        CONTINUE
+            WRITE(IOUT,7102) (TMPERR(IR),IR=1,NTMP)
+            IF(LMERG.EQ.0) THEN
+              WRITE(IOUT,7103) (' FACE',-MRGIN(IR),IR=NSURC,NSURM,-1)
+            ENDIF
+            WRITE(IOUT,7104)
+            NSURC = NSURC - 10
+   80    CONTINUE
+         NVOLC= 1
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,7001) ERRVOL,ERRVM
+         WRITE(IOUT,7006) IVSMAX(2),VOLTRK(IVSMAX(2),0)
+         DO 90 IP  = 1, (9 + MXVOL) / 10
+            NVOLM= MIN( MXVOL, NVOLC+9 )
+            WRITE(IOUT,7100) (' ZONE',IR,IR=NVOLC,NVOLM)
+            IF(LMERG.EQ.0) THEN
+              WRITE(IOUT,7120)
+     >             (VOLIN(IR),IR=NVOLC,NVOLM)
+              WRITE(IOUT,7121)
+     >             (' MIX ', MATIN(IR),IR=NVOLC,NVOLM)
+            ELSE
+              WRITE(IOUT,7120)
+     >             (VOLOUT(IR),IR=NVOLC,NVOLM)
+              WRITE(IOUT,7121)
+     >             (' MIX ', MATOUT(IR),IR=NVOLC,NVOLM)
+            ENDIF
+            WRITE(IOUT,7101) (VOLTRK(IR,0),IR=NVOLC,NVOLM)
+            NTMP=0
+            DO 91  IR= NVOLC,NVOLM
+              IF(LMERG.EQ.0) THEN
+                VOLREF=DBLE(VOLIN(IR))
+              ELSE
+                VOLREF=DBLE(VOLOUT(IR))
+              ENDIF
+              NTMP=NTMP+1
+              IF(VOLREF.NE.ZERO) THEN
+                TMPERR(NTMP)=REAL(HUND-HUND*VOLTRK(IR,0)/VOLREF)
+              ELSE
+                TMPERR(NTMP)=0.0
+              ENDIF
+  91        CONTINUE
+            WRITE(IOUT,7102) (TMPERR(IR),IR=1,NTMP)
+            IF(LMERG.EQ.0) THEN
+              WRITE(IOUT,7103) (' ZONE',MRGIN(IR),IR=NVOLC,NVOLM)
+            ENDIF
+            WRITE(IOUT,7104)
+            NVOLC = NVOLC + 10
+   90    CONTINUE
+         IF(IPRT .GT. 5)THEN
+           NVOLC= 1
+           NANG2= NANGL+2
+           WRITE(IOUT,'(1H )')
+           IF( NORE.EQ.0 )THEN
+              WRITE(IOUT,7004)
+           ELSEIF(NORE.EQ.-1) THEN
+              WRITE(IOUT,7002)
+           ELSEIF(NORE.EQ.1) THEN
+              WRITE(IOUT,7003)
+           ENDIF
+           DO 110 IP  = 1, (9 + MXVOL) / 10
+             NVOLM= MIN( MXVOL, NVOLC+9 )
+             WRITE(IOUT,7100) (' VOL ',IR,IR=NVOLC,NVOLM)
+             IF(NORE .EQ. -2 ) THEN
+               IANG=1
+               WRITE(IOUT,7131)  
+     >            (VOLTRK(IR,IANG),IR=NVOLC,NVOLM)
+             ELSE
+               DO 100 IANG= 1, NANGL
+                 WRITE(IOUT,7130) IANG, 
+     >            (VOLTRK(IR,IANG),IR=NVOLC,NVOLM)
+  100          CONTINUE
+             ENDIF
+             WRITE(IOUT,7104)
+             NVOLC = NVOLC + 10
+  110      CONTINUE
+         ENDIF
+      ELSE IF(IPRT .GE. 1) THEN
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,7000) ERRSUR,ERRSM
+         WRITE(IOUT,7005) -IVSMAX(1),4.0*VOLTRK(IVSMAX(1),0)
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,7001) ERRVOL,ERRVM
+         WRITE(IOUT,7006) IVSMAX(2),VOLTRK(IVSMAX(2),0)
+      ENDIF
+      IF( IVSC.NE.0 )THEN
+         WRITE(IOUT,9020)
+         CALL XABORT( 'XELNTR: CHECK NUMBERING OR USE FINER TRACKING')
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(VOLTRK,NRSEG,KANGL,PATH,DENSTY,ANGLES)
+      RETURN
+*----
+*  Formats
+*----
+ 6100 FORMAT(1X,'TRACK # ',I8,3X,'ANGLE ',I8,
+     >       1X,'WITH ',I8,1X,'SEGMENTS',
+     >       3X,'TOTAL WEIGHT =',1P,E15.6,3X,'VOLUME WEIGHT =',E15.6)
+ 6101  FORMAT(1P,(1X,E15.6,1X,2I8))
+ 7000 FORMAT(/' TRACKING ERRORS ON SURFACE   AVERAGE ERROR: ',F10.4,
+     >        ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % ')
+ 7001 FORMAT( ' TRACKING ERRORS ON VOLUME    AVERAGE ERROR: ',F10.4,
+     >        ' % ',5X,'MAXIMUM ERROR: ',F10.4,' % ')
+ 7002 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS: '/)
+ 7003 FORMAT(/' ANGLE-BY-ANGLE RENORMALIZATION FACTORS (NOT USED): '/)
+ 7004 FORMAT(/' GLOBAL RENORMALIZATION FACTORS: '/)
+ 7005 FORMAT(' MAXIMUM ERROR ON SURFACE=',I8,' WITH AREA  =',1P,E11.4)
+ 7006 FORMAT(' MAXIMUM ERROR IN REGION =',I8,' WITH VOLUME=',1P,E11.4)
+ 7100 FORMAT(10X,10(A5,I7))
+ 7101 FORMAT(' APPROX   ',1P,10E12.4)
+ 7102 FORMAT(' ERR(%)   ',10F12.5)
+ 7103 FORMAT(' MERGE TO ',10(A5,I7))
+ 7104 FORMAT(' ')
+ 7110 FORMAT(' SURFACE  ',1P,10E12.4)
+ 7111 FORMAT(' SIDE     ',10(A4,8X))
+ 7120 FORMAT(' VOLUME   ',1P,10E12.4)
+ 7121 FORMAT(' MIXTURE  ',10(A4,1X,I7))
+ 7130 FORMAT(' ANG ',I4,1X,1P,10E12.4)
+ 7131 FORMAT(10X,1P,10E12.4)
+*
+ 9000 FORMAT(' *** WARNING - ORIGINAL VOLUME  # ',I10,' NOT TRACKED ')
+ 9001 FORMAT(' *** WARNING - MERGED VOLUME    # ',I10,' NOT TRACKED ')
+ 9010 FORMAT(' *** WARNING - ORIGINAL SURFACE # ',I10,' NOT TRACKED ')
+ 9011 FORMAT(' *** WARNING - MERGED SURFACE   # ',I10,' NOT TRACKED ')
+ 9020 FORMAT(' *** ERROR - ONE MERGED VOLUME OR SURFACE NOT TRACKED')
+      END