diff options
Diffstat (limited to 'Dragon/src/MRGVON.f')
| -rw-r--r-- | Dragon/src/MRGVON.f | 208 |
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 |