Initial commit from Polytechnique Montreal

1 files changed, 199 insertions, 0 deletions

diff --git a/Dragon/src/MRGVOL.f b/Dragon/src/MRGVOL.f
new file mode 100644
index 0000000..1ff1152
--- /dev/null
+++ b/Dragon/src/MRGVOL.f
@@ -0,0 +1,199 @@
+*DECK MRGVOL
+      SUBROUTINE MRGVOL(IUPD  ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,NUNN  ,
+     >                  IMERGE,MIXN  ,MATO  ,VOLO  ,MATN  ,VOLN  ,
+     >                  KEYN  ,MATRTO,MATRTN,MAXMN ,NETVOL,NETSUR,
+     >                  MATRO ,KEYRO ,MATRN ,KEYRN )
+*
+*----------
+*
+*Purpose:
+* Merge information on data structure.
+*
+*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
+* 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.
+* NSOUTO  old number of surfaces.
+* NVOUTO  old number of regions.
+* NSOUTN  new number of surfaces.
+* NVOUTN  new number of regions.
+* NUNN    new number of unknowns.
+* IMERGE  merged position.
+* MIXN    new material for old regions.
+* MATO    old material per region.
+* VOLO    old volumes.
+* MATRTO  old B.C. conditions.
+* NETVOL  number of original regions.
+* NETSUR  number of original surfaces.
+* MATRO   old regional MATALB.
+* KEYRO   old regional KEYMRG.
+*
+*Parameters: output
+* MATN    new material per region.
+* VOLN    new volumes.
+* KEYN    new keyflux.
+* MATRTN  new B.C. conditions.
+* MAXMN   new maximum number of mixture.
+* MATRN   new regional MATALB.
+* KEYRN   new regional KEYMRG.
+*
+*----------
+*
+      IMPLICIT         NONE
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='MRGVOL')
+*----
+*  ROUTINE PARAMETERS
+*----
+      INTEGER          IUPD(4),NSOUTO,NVOUTO,NSOUTN,NVOUTN,NUNN,
+     >                 MAXMN,NETVOL,NETSUR
+      INTEGER          IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO),
+     >                 MATO(NVOUTO),MATN(NVOUTN),KEYN(NUNN),
+     >                 MATRTO(NSOUTO),MATRTN(NSOUTN),
+     >                 MATRO(-NETSUR:NETVOL),KEYRO(-NETSUR:NETVOL),
+     >                 MATRN(-NSOUTN:NVOUTN),KEYRN(-NSOUTN:NVOUTN)
+      REAL             VOLO(NVOUTO),VOLN(NVOUTN)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER          IVSN,IVSO
+      DOUBLE PRECISION DVOL
+*----
+*  TRANSFER OLD KEYMRG AND MATALB TO NEW VECTOR
+*----
+      DO 90 IVSN=-NETSUR,NETVOL
+        KEYRN(IVSN)=KEYRO(IVSN)
+        MATRN(IVSN)=MATRO(IVSN)
+ 90   CONTINUE
+*----
+*  CHANGE ORIGINAL MATERIAL IF REQUESTED
+*----
+      IF(IUPD(3) .GT. 0) THEN
+        DO 100 IVSN=1,IUPD(3)
+          MATO(IVSN)=MIXN(IVSN)
+          DO 101 IVSO=1,NETVOL
+            IF(KEYRO(IVSO) .EQ. IVSN) THEN
+              MATRN(IVSO)=MATO(IVSN)
+            ENDIF
+ 101      CONTINUE
+ 100    CONTINUE
+      ENDIF
+      IF(IUPD(1) .GT. 0) THEN
+*----
+*  MERGE MATERIAL VOLUME AND KEY
+*----
+        DO 110 IVSN=1,NVOUTN
+          MATN(IVSN)=0
+          DVOL=0.0D0
+          DO 111 IVSO=1,NVOUTO
+           IF(IMERGE(IVSO) .EQ. IVSN) THEN
+             IF(MATN(IVSN) .EQ. 0) THEN
+               MATN(IVSN)=MATO(IVSO)
+             ELSE IF(MATN(IVSN) .NE. MATO(IVSO))THEN
+               WRITE(IOUT,6000) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO)
+               CALL XABORT(NAMSBR//
+     >           ': MATERIAL INCOMPATIBLE FOR MERGE')
+             ENDIF
+             DVOL=DVOL+DBLE(VOLO(IVSO))
+           ENDIF
+ 111      CONTINUE
+          VOLN(IVSN)=REAL(DVOL)
+          KEYN(IVSN)=IVSN
+ 110    CONTINUE
+        DO 112 IVSN=NVOUTN+1,NUNN
+          KEYN(IVSN)=0
+ 112    CONTINUE
+        DO 113 IVSO=1,NVOUTO
+          DO 114 IVSN=1,NETVOL
+            IF(KEYRO(IVSN) .EQ. IVSO) THEN
+              KEYRN(IVSN)=IMERGE(IVSO)
+            ENDIF
+ 114      CONTINUE
+ 113    CONTINUE
+      ELSE
+*----
+*  NO MERGE TRANSFER INFORMATION TO NEW VECTORS
+*----
+        DO 120 IVSO=1,NVOUTO
+          MATN(IVSO)=MATO(IVSO)
+          VOLN(IVSO)=VOLO(IVSO)
+ 120    CONTINUE
+      ENDIF
+*----
+*  CHANGE FINAL MATERIAL IF REQUESTED
+*----
+      IF(IUPD(3) .LT. 0) THEN
+        DO 130 IVSN=1,-IUPD(3)
+          MATN(IVSN)=MIXN(IVSN)
+          DO 131 IVSO=1,NETVOL
+            IF(KEYRO(IVSO) .EQ. IVSN) THEN
+              MATRN(IVSO)=MIXN(IVSN)
+            ENDIF
+ 131      CONTINUE
+ 130    CONTINUE
+      ENDIF
+*----
+*  FIND NEW MAXIMUM NUMBER OF MIXTURE
+*----
+      MAXMN=0
+      DO 140 IVSN=1,NVOUTN
+        MAXMN=MAX(MAXMN,MATN(IVSN))
+ 140  CONTINUE
+*----
+*  MERGE REFLECTION/TRANSMISSION MATRIX
+*----
+      IF(IUPD(2).EQ.0) THEN
+        DO 150 IVSN=1,NSOUTO
+          MATRTN(IVSN)=MATRTO(IVSN)
+ 150    CONTINUE
+      ELSE
+        DO 160 IVSN=-NSOUTN,-1,1
+          DO 161 IVSO=-NSOUTO,-1,1
+            IF(IMERGE(IVSO).EQ.IVSN) THEN
+              MATRTN(-IVSN)=-IMERGE(-MATRTO(-IVSO))
+              GO TO 165
+            ENDIF
+ 161      CONTINUE
+ 165      CONTINUE
+ 160    CONTINUE
+*----
+*  TEST IF MATRTN IS COHERENT
+*----
+        DO 162 IVSN=1,NSOUTN
+          IVSO=MATRTN(IVSN)
+          IF(MATRTN(IVSO).NE.IVSN) THEN
+            CALL XABORT(NAMSBR//
+     >           ': SURFACES BC INCOMPATIBLE FOR MERGE')
+          ENDIF
+ 162    CONTINUE
+        DO 163 IVSO=-1,-NSOUTO,-1
+          DO 164 IVSN=-1,-NETSUR,-1
+            IF(KEYRO(IVSN) .EQ. IVSO) THEN
+              KEYRN(IVSN)=IMERGE(IVSO)
+            ENDIF
+ 164      CONTINUE
+ 163    CONTINUE
+      ENDIF
+      RETURN
+*----
+*  ABORT FORMATS
+*----
+ 6000 FORMAT(' ------ ABORT IN ROUTINE ',A6,'  ------'/
+     >       ' MATERIAL INCOMPATIBLE FOR MERGE '/
+     >       ' NEW REGION = ',I10,5X,'MATERIAL =',I10/
+     >       ' OLD REGION = ',I10,5X,'MATERIAL =',I10/
+     >       ' ----------------------------------------')
+      END