1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
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
|
