summaryrefslogtreecommitdiff
path: root/Dragon/src/MRGVST.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/MRGVST.f')
-rw-r--r--Dragon/src/MRGVST.f227
1 files changed, 227 insertions, 0 deletions
diff --git a/Dragon/src/MRGVST.f b/Dragon/src/MRGVST.f
new file mode 100644
index 0000000..42cda0a
--- /dev/null
+++ b/Dragon/src/MRGVST.f
@@ -0,0 +1,227 @@
+*DECK MRGVST
+ SUBROUTINE MRGVST(IFTRKO,IFTRKN,IPRINT,IUPD ,NDIM ,NALBG,NANGL,
+ > NSOUTO,NVOUTO,NSOUTN,NVOUTN,IMERGE,MIXN)
+*
+*----------
+*
+*Purpose:
+* Merge volume and surface on track file and save.
+*
+*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. Marleau
+*
+*Parameters: input
+* IFTRKO old tracking file.
+* IFTRKN new 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.
+* NSOUTN new number of surfaces.
+* NVOUTN new number of regions.
+* IMERGE merging index.
+* MIXN new albedos and material for old regions.
+*
+*----------
+*
+ IMPLICIT NONE
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NAMSBR='MRGVST')
+*----
+* ROUTINE PARAMETERS
+*----
+ INTEGER IFTRKO,IFTRKN
+ INTEGER IPRINT,IUPD(4),NDIM,NALBG,NANGL,
+ > NSOUTO,NVOUTO,NSOUTN,NVOUTN
+ INTEGER IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO)
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER IVSN,IVSO,IVST,ITC
+ DOUBLE PRECISION DVOL
+*----
+* Allocatable arrays
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: MATO,MATN,ICODE
+ REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,VOLN
+ REAL, ALLOCATABLE, DIMENSION(:) :: ALBD
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLES,DENSTY
+*----
+* Processing starts:
+* print routine openning output header if required
+*----
+ IF(IPRINT.GE.10) THEN
+ WRITE(IOUT,6000) NAMSBR
+ ENDIF
+*----
+* Read old Volume/surface and albedo/material information
+* and print if required
+*----
+ ALLOCATE(MATO(-NSOUTO:NVOUTO),VOLO(-NSOUTO:NVOUTO))
+ ALLOCATE(MATN(-NSOUTN:NVOUTN),VOLN(-NSOUTN:NVOUTN))
+ READ(IFTRKO) (VOLO(ITC),ITC=-NSOUTO,NVOUTO)
+ READ(IFTRKO) (MATO(ITC),ITC=-NSOUTO,NVOUTO)
+ IF(IPRINT.GE.10) THEN
+ WRITE(IOUT,6010)
+ WRITE(IOUT,6020) (MATO(IVSO),VOLO(IVSO),IVSO=-1,-NSOUTO,-1)
+ ENDIF
+*----
+* VERIFY IF BOUNDARY CONDITIONS ARE ADEQUATE FOR MERGE VECTOR
+*----
+ IF(IUPD(2). LT. 0) THEN
+ DO 100 IVSN=-NSOUTN,-1
+ MATN(IVSN)=0
+ DVOL=0.0D0
+ DO 101 IVSO=-NSOUTO,-1
+ 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,6100) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO)
+ WRITE(IOUT,6101)
+ WRITE(IOUT,6102) (IVST,MATO(IVST),IVST=-NSOUTO,-1)
+ CALL XABORT(NAMSBR//
+ > ': BOUNDARY CONDITIONS INCOMPATIBLE FOR MERGE')
+ ENDIF
+ DVOL=DVOL+DBLE(VOLO(IVSO))
+ ENDIF
+ 101 CONTINUE
+ VOLN(IVSN)=REAL(DVOL)
+ 100 CONTINUE
+ ELSE
+ DO 110 IVSO=-NSOUTO,-1
+ MATN(IVSO)=MATO(IVSO)
+ VOLN(IVSO)=VOLO(IVSO)
+ 110 CONTINUE
+ ENDIF
+ IF(IPRINT.GE.10) THEN
+ WRITE(IOUT,6011)
+ WRITE(IOUT,6020) (MATN(IVSN),VOLN(IVSN),IVSN=-1,-NSOUTN,-1)
+ WRITE(IOUT,6012)
+ WRITE(IOUT,6020) (MATO(IVSO),VOLO(IVSO),IVSO=1,NVOUTO)
+ ENDIF
+*----
+* CHANGE ORIGINAL MATERIAL IF REQUESTED
+*----
+ IF(IUPD(3) .GT. 0) THEN
+ DO 120 IVSO=1,IUPD(3)
+ MATO(IVSO)=MIXN(IVSO)
+ 120 CONTINUE
+ ENDIF
+*----
+* VERIFY IF MATERIALS ARE ADEQUATE FOR MERGE VECTOR
+*----
+ IF(IUPD(1) .GT. 0) THEN
+ MATN(0)=0
+ VOLN(0)=0.0
+ DO 130 IVSN=1,NVOUTN
+ MATN(IVSN)=0
+ DVOL=0.0D0
+ DO 131 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,6200) NAMSBR,IVSN,MATN(IVSN),IVSO,MATO(IVSO)
+ WRITE(IOUT,6201)
+ WRITE(IOUT,6202) (IVST,MATO(IVST),IVST=1,NVOUTO)
+ CALL XABORT(NAMSBR//
+ > ': MATERIALS INCOMPATIBLE FOR MERGE')
+ ENDIF
+ DVOL=DVOL+DBLE(VOLO(IVSO))
+ ENDIF
+ 131 CONTINUE
+ VOLN(IVSN)=REAL(DVOL)
+ 130 CONTINUE
+ ELSE
+ DO 140 IVSO=1,NVOUTO
+ MATN(IVSO)=MATO(IVSO)
+ VOLN(IVSO)=VOLO(IVSO)
+ 140 CONTINUE
+ ENDIF
+*----
+* CHANGE FINAL MATERIAL IF REQUESTED
+*----
+ IF(IUPD(3) .LT. 0) THEN
+ DO 150 IVSN=1,-IUPD(3)
+ MATN(IVSN)=MIXN(IVSN)
+ 150 CONTINUE
+ ENDIF
+ IF(IPRINT.GE.10) THEN
+ WRITE(IOUT,6013)
+ WRITE(IOUT,6020) (MATN(IVSN),VOLN(IVSN),IVSN=1,NVOUTN)
+ ENDIF
+*----
+* Save new Volume/surface and albedo/material information
+*----
+ WRITE(IFTRKN) (VOLN(ITC),ITC=-NSOUTN,NVOUTN)
+ WRITE(IFTRKN) (MATN(ITC),ITC=-NSOUTN,NVOUTN)
+*----
+* Read and save BC and tracking directions and density
+*----
+ ALLOCATE(ICODE(NALBG),ALBD(NALBG),ANGLES(NDIM*NANGL),
+ > DENSTY(NANGL))
+ READ(IFTRKO) (ICODE(ITC),ITC=1,NALBG)
+ READ(IFTRKO) (ALBD(ITC),ITC=1,NALBG)
+ READ(IFTRKO) (ANGLES(ITC),ITC=1,NDIM*NANGL)
+ READ(IFTRKO) (DENSTY(ITC),ITC=1,NANGL)
+ WRITE(IFTRKN) (ICODE(ITC),ITC=1,NALBG)
+ WRITE(IFTRKN) (ALBD(ITC),ITC=1,NALBG)
+ WRITE(IFTRKN) (ANGLES(ITC),ITC=1,NDIM*NANGL)
+ WRITE(IFTRKN) (DENSTY(ITC),ITC=1,NANGL)
+ DEALLOCATE(DENSTY,ANGLES,ALBD,ICODE)
+ DEALLOCATE(MATN,VOLN)
+ 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(' Initial surfaces and albedos')
+ 6011 FORMAT(' Final surfaces and albedos')
+ 6012 FORMAT(' Initial volumes and materials')
+ 6013 FORMAT(' Final volumes and materials')
+ 6020 FORMAT(1P,5(I10,D15.7))
+*----
+* ABORT FORMATS
+*----
+ 6100 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/
+ > ' BOUNDARY CONDITIONS INCOMPATIBLE FOR MERGE '/
+ > ' NEW REGION = ',I10,5X,'SURFACE =',I10/
+ > ' OLD REGION = ',I10,5X,'SURFACE =',I10/
+ > ' ----------------------------------------')
+ 6101 FORMAT(' SURFACE DESCRIPTION '/
+ > 4(' SURFACE -> ALBEDO'))
+ 6102 FORMAT(4(1X,I7,6X,I6))
+ 6200 FORMAT(' ------ ABORT IN ROUTINE ',A6,' ------'/
+ > ' MATERIAL INCOMPATIBLE FOR MERGE '/
+ > ' NEW REGION = ',I10,5X,'MATERIAL =',I10/
+ > ' OLD REGION = ',I10,5X,'MATERIAL =',I10/
+ > ' ----------------------------------------')
+ 6201 FORMAT(' REGION DESCRIPTION '/
+ > 4(' REGION -> MATERIAL'))
+ 6202 FORMAT(4(1X,I6,5X,I8))
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:22:57 +0000