From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/MRGVST.f | 227 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 227 insertions(+) create mode 100644 Dragon/src/MRGVST.f (limited to 'Dragon/src/MRGVST.f') 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 -- cgit v1.2.3