Initial commit from Polytechnique Montreal

1 files changed, 208 insertions, 0 deletions

diff --git a/Dragon/src/MRGVON.f b/Dragon/src/MRGVON.f
new file mode 100644
index 0000000..587c1fa
--- /dev/null
+++ b/Dragon/src/MRGVON.f
@@ -0,0 +1,208 @@
+*DECK MRGVON
+      SUBROUTINE MRGVON(IUPD  ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,
+     >                  NETSUR,NETVOL,NUNN  ,MAXMN ,
+     >                  IMERGE,MATO  ,VOLO  ,MATRTO,
+     >                  MATN  ,VOLN  ,KEYN  ,MATRTN,
+     >                  NEXMAT,NEXKEY)
+*
+*----------
+*
+*Purpose:
+* Merge volume and surface for NXT geometry.
+*
+*Copyright:
+* Copyright (C) 2011 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. Harrisson
+*
+*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.
+* NETVOL  number of original regions.
+* NETSUR  number of original surfaces.
+* NUNN    new number of unknowns.
+* IMERGE  merged position.
+* MATO    old material per region.
+* VOLO    old volumes.
+* MATRTO  old B.C. conditions.
+*
+*Parameters: input/output
+* NEXMAT  old/new NXTRecord MATALB for albedo number modification.
+* NEXKEY  old/new KEYMRG index for NXT.
+*
+*Parameters: output
+* MAXMN   new maximum number of mixture.
+* MATN    new material per region.
+* VOLN    new volumes.
+* KEYN    new keyflux.
+* MATRTN  new B.C. conditions.
+*
+*----------
+*
+      IMPLICIT         NONE
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='MRGVON')
+*----
+*  ROUTINE PARAMETERS
+*----
+      INTEGER          IUPD(4),NSOUTO,NVOUTO,NSOUTN,NVOUTN,
+     >                 NETSUR,NETVOL,NUNN,MAXMN
+      INTEGER          IMERGE(-NSOUTO:NVOUTO),
+     >                 MATO(NVOUTO),MATRTO(NSOUTO),
+     >                 MATN(NVOUTN),KEYN(NUNN),MATRTN(NSOUTN),
+     >                 NEXMAT(-NETSUR:NETVOL),
+     >                 NEXKEY(-NETSUR:NETVOL)
+      REAL             VOLO(NVOUTO),VOLN(NVOUTN)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER          IVSN,IVSO
+      DOUBLE PRECISION DVOL
+*----
+*  Allocatable arrays
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IDABL
+*----
+*  CHANGE ORIGINAL AND/OR FINAL MATERIAL AND ORIGINAL ALBEDO IF REQUESTED
+*----
+      IF(IUPD(3) .GT. 0) THEN
+        WRITE(IOUT,6300)
+      ELSE IF(IUPD(3) .LT. 0) THEN
+        WRITE(IOUT,6400)
+      ELSE IF(IUPD(4) .GT. 0) THEN
+        WRITE(IOUT,6500)
+      ENDIF
+*----
+*  MERGE MATERIAL VOLUME AND KEY
+*----
+      IF(IUPD(1) .GT. 0) THEN
+        DO IVSN=1,NVOUTN
+          MATN(IVSN)=0
+          DVOL=0.0D0
+          DO 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
+          ENDDO
+          VOLN(IVSN)=REAL(DVOL)
+          KEYN(IVSN)=IVSN
+        ENDDO
+        DO IVSN=NVOUTN+1,NUNN
+          KEYN(IVSN)=0
+        ENDDO
+        DO  IVSN=1,NETVOL
+          DO  IVSO=1,NVOUTO
+            IF(NEXKEY(IVSN) .EQ. IVSO) THEN
+              NEXKEY(IVSN)=IMERGE(IVSO)
+              GO TO 100
+            ENDIF
+          ENDDO
+ 100      CONTINUE
+        ENDDO
+      ELSE
+*----
+*  NO MERGE TRANSFER INFORMATION TO NEW VECTORS
+*----
+        DO IVSO=1,NVOUTO
+          MATN(IVSO)=MATO(IVSO)
+          VOLN(IVSO)=VOLO(IVSO)
+        ENDDO
+      ENDIF
+*----
+*  FIND NEW MAXIMUM NUMBER OF MIXTURE
+*----
+      MAXMN=0
+      DO IVSN=1,NVOUTN
+        MAXMN=MAX(MAXMN,MATN(IVSN))
+      ENDDO
+*----
+*  MERGE REFLECTION/TRANSMISSION MATRIX
+*----
+      IF(IUPD(2).EQ.0) THEN
+        DO IVSN=1,NSOUTO
+          MATRTN(IVSN)=MATRTO(IVSN)
+        ENDDO
+      ELSE
+        DO IVSN=-NSOUTN,-1,1
+          DO IVSO=-NSOUTO,-1,1
+            IF(IMERGE(IVSO).EQ.IVSN) THEN
+              MATRTN(-IVSN)=-IMERGE(-MATRTO(-IVSO))
+              GO TO 110
+            ENDIF
+          ENDDO
+ 110      CONTINUE
+        ENDDO
+*----
+*  TEST IF MATRTN IS COHERENT
+*----
+        DO IVSN=1,NSOUTN
+          IVSO=MATRTN(IVSN)
+          IF(MATRTN(IVSO).NE.IVSN) THEN
+            CALL XABORT(NAMSBR//
+     >           ': SURFACES BC INCOMPATIBLE FOR MERGE')
+          ENDIF
+        ENDDO
+        DO  IVSN=-1,-NETSUR,-1
+          DO  IVSO=-1,-NSOUTO,-1
+            IF(NEXKEY(IVSN) .EQ. IVSO) THEN
+              NEXKEY(IVSN)=IMERGE(IVSO)
+              GO TO 120
+            ENDIF
+          ENDDO
+ 120      CONTINUE
+        ENDDO
+*----
+*  MERGING SURFACES WITH DIFFERENT ALBEDO NUMBER
+*  USEFUL TO ACHIEVE SYME SYMMETRY
+*----
+         ALLOCATE(IDABL(NSOUTN))
+         IDABL(:NSOUTN)=0
+         DO IVSN=1,NSOUTN
+           DO IVSO=1,NETSUR
+             IF (IMERGE(-IVSO) .EQ. -IVSN) THEN
+               IF (IDABL(IVSN) .EQ. 0) THEN
+                 IDABL(IVSN)=NEXMAT(-IVSO)
+               ELSE
+                 NEXMAT(-IVSO)=IDABL(IVSN)
+               ENDIF
+             ENDIF
+           ENDDO
+         ENDDO
+         DEALLOCATE(IDABL)
+      ENDIF
+      RETURN
+*----
+*  FORMATS
+*----
+ 6000 FORMAT(' ------ ABORT IN ROUTINE ',A6,'  ------'/
+     >       ' MATERIAL INCOMPATIBLE FOR MERGE '/
+     >       ' NEW REGION = ',I10,5X,'MATERIAL =',I10/
+     >       ' OLD REGION = ',I10,5X,'MATERIAL =',I10/
+     >       ' ----------------------------------------')
+ 6300 FORMAT(' ***** WARNING:  OPTION OLDM IS INVALID FOR GEOMETRIES'/
+     >       '       TRACKED WITH NXT:. ORIGINAL MIXTURES ARE USED')
+ 6400 FORMAT(' ***** WARNING:  OPTION NEWM IS INVALID FOR GEOMETRIES'/
+     >       '       TRACKED WITH NXT:. ORIGINAL MIXTURES ARE USED')
+ 6500 FORMAT(' ***** WARNING:  OPTION ALBE IS INVALID FOR GEOMETRIES'/
+     >       '       TRACKED WITH NXT:. ORIGINAL ALBEDO ARE USED')
+      END