Initial commit from Polytechnique Montreal

1 files changed, 170 insertions, 0 deletions

diff --git a/Dragon/src/MRGXTC.f b/Dragon/src/MRGXTC.f
new file mode 100644
index 0000000..a3161f3
--- /dev/null
+++ b/Dragon/src/MRGXTC.f
@@ -0,0 +1,170 @@
+*DECK MRGXTC
+      SUBROUTINE MRGXTC(IFTRKO,IFTRKN,IFTRKE,IPRINT,IUPD,NDIM,
+     >                  NALBG ,NANGL ,NSOUTO,NVOUTO,MXSEG,IMERGE)
+*
+*----------
+*
+*Purpose:
+* Subdivide tracking file into 2 sets.
+*
+*Copyright:
+* Copyright (C) 1997 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):
+* G. Marleau
+*
+*Parameters: input
+* IFTRKO  old tracking file.
+* IFTRKN  new part r (residual) tracking file.
+* IFTRKE  new part e (extracted) tracking file.
+* IPRINT  print level.
+* IUPD    type of merge required:
+*         IUPD(1) for region merge;
+*         IUPD(2) for surface merge;
+*         IUPD(3) for material merge;
+*         IUPD(4) for albedo merge.
+* NDIM    number of dimensions.
+* NALBG   number of albedos.
+* NANGL   number of track directions.
+* NSOUTO  old number of surfaces.
+* NVOUTO  old number of regions.
+* MXSEG   maximum number of segments.
+* IMERGE  merged position.
+*
+*----------
+*
+      IMPLICIT         NONE
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='MRGXTC')
+*----
+*  ROUTINE PARAMETERS
+*----
+      INTEGER          IFTRKO,IFTRKN,IFTRKE
+      INTEGER          IPRINT,IUPD(4),NDIM,
+     >                 NALBG,NANGL,NSOUTO,NVOUTO,MXSEG
+      INTEGER          IMERGE(-NSOUTO:NVOUTO)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER          IVSO,ITRAK,IANG,ILINE,NLINE,IEXT
+      REAL             WEIGHT
+*----
+*  Allocatable arrays
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MATO,ICODE,NRSEG
+      REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,ALBD
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY
+      REAL, ALLOCATABLE, DIMENSION(:) :: PATH
+*----
+*  Processing starts:
+*  print routine openning output header if required
+*----
+      ALLOCATE(MATO(-NSOUTO:NVOUTO),VOLO(-NSOUTO:NVOUTO))
+      IF(IPRINT.GE.10) THEN
+        WRITE(IOUT,6000)
+      ENDIF
+*----
+*  Read old Volume/surface and albedo/material information
+*  and print if required
+*----
+      READ(IFTRKO) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      READ(IFTRKO) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      IF(IPRINT.GE.10) THEN
+        WRITE(IOUT,6010)
+        WRITE(IOUT,6011) (MATO(IVSO),VOLO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      ENDIF
+*----
+*  Save new Volume/surface and albedo/material information
+*----
+      WRITE(IFTRKN) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      WRITE(IFTRKE) (VOLO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      WRITE(IFTRKN) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO)
+      WRITE(IFTRKE) (MATO(IVSO),IVSO=-NSOUTO,NVOUTO)
+*----
+*  Read and save BC and tracking directions and density
+*----
+      ALLOCATE(ICODE(NALBG),ALBD(NALBG),ANGLES(NDIM*NANGL),
+     >         DENSTY(NANGL))
+      READ(IFTRKO) (ICODE(IVSO),IVSO=1,NALBG)
+      READ(IFTRKO) (ALBD(IVSO),IVSO=1,NALBG)
+      READ(IFTRKO) (ANGLES(IVSO),IVSO=1,NDIM*NANGL)
+      READ(IFTRKO) (DENSTY(IVSO),IVSO=1,NANGL)
+      WRITE(IFTRKN) (ICODE(IVSO),IVSO=1,NALBG)
+      WRITE(IFTRKN) (ALBD(IVSO),IVSO=1,NALBG)
+      WRITE(IFTRKN) (ANGLES(IVSO),IVSO=1,NDIM*NANGL)
+      WRITE(IFTRKN) (DENSTY(IVSO),IVSO=1,NANGL)
+      WRITE(IFTRKE) (ICODE(IVSO),IVSO=1,NALBG)
+      WRITE(IFTRKE) (ALBD(IVSO),IVSO=1,NALBG)
+      WRITE(IFTRKE) (ANGLES(IVSO),IVSO=1,NDIM*NANGL)
+      WRITE(IFTRKE) (DENSTY(IVSO),IVSO=1,NANGL)
+      DEALLOCATE(DENSTY,ANGLES,ALBD,ICODE)
+*----
+*  select track for tracking files
+      ALLOCATE(NRSEG(MXSEG),PATH(MXSEG))
+      ITRAK=0
+ 1000 CONTINUE
+        READ (IFTRKO,END=1010) IANG,NLINE,WEIGHT,
+     >                         (NRSEG(ILINE),ILINE=1,NLINE),
+     >                         (PATH(ILINE),ILINE=1,NLINE)
+C----
+C  SCAN NRSEG AND RESET TO NEW VOLUME AND SURFACE NUMBER
+C----
+        ITRAK=ITRAK+1
+        IEXT=1
+        DO ILINE=1,NLINE
+          DO IVSO=1,-IUPD(1)
+            IF(NRSEG(ILINE) .EQ. IMERGE(IVSO)) GO TO 1005
+          ENDDO
+        ENDDO
+        IEXT=0
+ 1005   CONTINUE
+        IF(IEXT .EQ. 1) THEN
+          WRITE(IFTRKE) IANG,NLINE,WEIGHT,
+     >                 (NRSEG(ILINE),ILINE=1,NLINE),
+     >                 (PATH(ILINE),ILINE=1,NLINE)
+          IF(IPRINT.GE.1000) THEN
+            WRITE(IOUT,6020) ITRAK,IANG,NLINE,WEIGHT
+            WRITE(IOUT,6025)
+     >       (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINE)
+          ENDIF
+        ELSE
+          WRITE(IFTRKN) IANG,NLINE,WEIGHT,
+     >                 (NRSEG(ILINE),ILINE=1,NLINE),
+     >                 (PATH(ILINE),ILINE=1,NLINE)
+          IF(IPRINT.GE.1000) THEN
+            WRITE(IOUT,6021) ITRAK,IANG,NLINE,WEIGHT
+            WRITE(IOUT,6025)
+     >       (NRSEG(ILINE),PATH(ILINE),ILINE=1,NLINE)
+          ENDIF
+        ENDIF
+        GO TO 1000
+ 1010 CONTINUE
+      DEALLOCATE(PATH,NRSEG)
+      DEALLOCATE(VOLO,MATO)
+*----
+*  Print output header if required
+*  and return
+*----
+      IF(IPRINT .GE. 100) THEN
+        WRITE(IOUT,6001) NAMSBR
+      ENDIF
+      RETURN
+*----
+*  PRINT FORMATS
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT('   Output from --',A6,'-- completed *)')
+ 6010 FORMAT(' Region description '/
+     >       4(' Region  ->               Volume'))
+ 6011 FORMAT(4(1X,I6,5X,F20.8))
+ 6020 FORMAT(' Line = ',I10,' is extracted '/
+     >       ' Parameter = ',2I10,1P,E15.7)
+ 6021 FORMAT(' Line = ',I10,' is kept '/
+     >       ' Parameter = ',2I10,1P,E15.7)
+ 6025 FORMAT(1P,5(I10,E15.7))
+      END