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
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
|
*DECK COMGEP
SUBROUTINE COMGEP(IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG,
1 NPAR,NLOC,NMIL,MUPLET,LGNEW)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover remaining global and local parameters. Update the parameter
* tree (in each mixture) for a new elementary calculation.
*
*Copyright:
* Copyright (C) 2002 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): A. Hebert
*
*Parameters: input
* IPCPO pointer to the multicompo.
* IPDEPL pointer to the burnup object.
* IPLB1 pointer to the first microlib object.
* IPLB2 pointer to the second (optional) microlib object.
* IPEDIT pointer to the edition object.
* IMPX print parameter.
* ITIM index of the current burnup step.
* NORIG index of the elementary calculation associated to the
* father node in the parameter tree.
* NPAR number of global parameters.
* NLOC number of local parameters.
* NMIL number of homogenized mixtures.
* MUPLET tuple of indices associated to each global parameter of the
* elementary calculation.
* LGNEW parameter modification flag (=.true. if the I-th global
* parameter has changed in the new elementary calculation).
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT
INTEGER IMPX,ITIM,NORIG,NPAR,NLOC,NMIL,MUPLET(NPAR)
LOGICAL LGNEW(NPAR)
*----
* LOCAL VARIABLES
*----
PARAMETER (NSTATE=40,MAXPAR=50)
TYPE(C_PTR) JPCPO,KPCPO,IPLB3
INTEGER ISTATE(NSTATE),PARMIL(MAXPAR),PARCAD(MAXPAR+1),
1 PARPAD(MAXPAR+1),NVPO(2)
CHARACTER PARKEY(MAXPAR)*12,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4,
1 PARBIB(MAXPAR)*12,TEXT4*4,TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12
LOGICAL LGERR,EMPTY,LCM,COMTRE,LAST
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,JDEBAR,JARBVA,
1 IORIGI
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MUPL2
REAL, ALLOCATABLE, DIMENSION(:,:) :: RVALO
LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LGNE2
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(MUPL2(NPAR+NLOC,NMIL),LGNE2(NPAR+NLOC,NMIL))
*----
* RECOVER INFORMATION FROM THE 'STATE-VECTOR' PARAMETER LIST
*----
CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
IF(NPAR.NE.ISTATE(5)) CALL XABORT('COMGEP: WRONG VALUE OF NPAR.')
IF(NLOC.NE.ISTATE(6)) CALL XABORT('COMGEP: WRONG VALUE OF NLOC.')
NMIL=ISTATE(1)
NG=ISTATE(2)
NCAL=ISTATE(3)
MAXCAL=ISTATE(4)
NPCHR=ISTATE(7)
NPPNT=ISTATE(8)
NPCHRL=ISTATE(9)
*----
* RECOVER INFORMATION FROM THE 'GLOBAL' DIRECTORY
*----
CALL LCMSIX(IPCPO,'GLOBAL',1)
IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY)
IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARTYP',4,NPAR,PARTYP)
CALL LCMGET(IPCPO,'PARCAD',PARCAD)
CALL LCMGET(IPCPO,'PARPAD',PARPAD)
IF(NPCHR.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHR,PARCHR)
IF(NPPNT.GT.0) CALL LCMGET(IPCPO,'PARMIL',PARMIL)
IF(NPPNT.GT.0) CALL LCMGTC(IPCPO,'PARBIB',12,NPPNT,PARBIB)
CALL LCMSIX(IPCPO,' ',2)
*----
* RECOVER REMAINING GLOBAL PARAMETERS
*----
DO 10 IPAR=1,NPAR
IF(PARTYP(IPAR).EQ.'VALU') THEN
GO TO 10
ELSE IF(LGNEW(IPAR)) THEN
CALL XABORT('COMGEP: PARAMETER '//PARTYP(IPAR)//' IS ALREADY D'
1 //'EFINED (REMOVE THE '//PARKEY(IPAR)//' KEYWORD).')
ELSE IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR.
1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUB').OR.
2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN
*
* RECOVER GLOBAL PARAMETER VALUES FROM THE BURNUP OBJECT.
IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN
CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T'
1 //'HE RHS LCM OBJECTS.')
ENDIF
CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE)
NBURN=ISTATE(3)
NBISO=ISTATE(4)
NREAC=ISTATE(6)
NVAR=ISTATE(7)
NBMIX=ISTATE(8)
CALL COMGEM(IPDEPL,ITIM,PARTYP(IPAR),0,NBURN,NBMIX,NBISO,
1 NREAC,NVAR,VALPAR)
ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC'))
1 THEN
*
* RECOVER GLOBAL PARAMETER VALUES FROM A MICROLIB OBJECT.
IF(.NOT.C_ASSOCIATED(IPLB1)) THEN
CALL XABORT('COMGEP: MICROLIB EXPECTED AT RHS.')
ENDIF
IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR)
IPPAD=PARPAD(IPAR+1)-PARPAD(IPAR)
IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1)
IF(IPPAD.EQ.1) IPPAD=PARPAD(IPAR+1)-PARPAD(1)
TEXT8=' '
TEXT12=' '
IMILI=0
IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD)
IF(IPPAD.GT.0) TEXT12=PARBIB(IPPAD)
IF(IPPAD.GT.0) IMILI=PARMIL(IPPAD)
CALL LCMGET(IPLB1,'STATE-VECTOR',ISTATE)
MAXNBI=ISTATE(2)
IF(C_ASSOCIATED(IPLB2)) THEN
CALL LCMGET(IPLB2,'STATE-VECTOR',ISTATE)
MAXNBI=MAX(MAXNBI,ISTATE(2))
ENDIF
CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI,
1 VALPAR)
ELSE
CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'//
1 'ETER TYPE.')
ENDIF
IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR
*
CALL LCMSIX(IPCPO,'GLOBAL',1)
TEXT8='REAL'
CALL COMPAV(IPCPO,IPAR,NPAR,TEXT8,VALPAR,NITMA,TEXT12,
1 MUPLET(IPAR),LGNEW(IPAR))
CALL LCMSIX(IPCPO,' ',2)
10 CONTINUE
DO 25 IBM=1,NMIL
DO 20 IPAR=1,NPAR
MUPL2(IPAR,IBM)=MUPLET(IPAR)
LGNE2(IPAR,IBM)=LGNEW(IPAR)
20 CONTINUE
25 CONTINUE
IF(NLOC.EQ.0) GO TO 50
*----
* RECOVER INFORMATION FROM THE 'LOCAL' DIRECTORY
*----
CALL LCMSIX(IPCPO,'LOCAL',1)
CALL LCMGTC(IPCPO,'PARKEY',12,NLOC,PARKEY)
CALL LCMGTC(IPCPO,'PARTYP',4,NLOC,PARTYP)
CALL LCMGET(IPCPO,'PARCAD',PARCAD)
IF(NPCHRL.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHRL,PARCHR)
CALL LCMSIX(IPCPO,' ',2)
*----
* RECOVER LOCAL PARAMETERS
*----
CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12)
ALLOCATE(RVALO(NLOC,NMIL))
DO 45 IPAR=1,NLOC
IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR.
1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUG').OR.
2 (PARTYP(IPAR).EQ.'FLUB').OR.(PARTYP(IPAR).EQ.'FLUX').OR.
3 (PARTYP(IPAR).EQ.'MASL')) THEN
*
* RECOVER LOCAL PARAMETERS FROM THE BURNUP OBJECT.
CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE)
NBURN=ISTATE(3)
NBISO=ISTATE(4)
NREAC=ISTATE(6)
NVAR=ISTATE(7)
NBMIX=ISTATE(8)
IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN
CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T'
1 //'HE RHS LCM OBJECTS.')
ENDIF
CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE)
NREG=ISTATE(17)
CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYP(IPAR),NBURN,
1 NBMIX,NBISO,NREAC,NVAR,IPAR,NLOC,RVALO)
ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC'))
1 THEN
*
* RECOVER LOCAL PARAMETERS FROM THE MICROLIB IN EDIT OBJECT.
IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR)
IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1)
TEXT8=' '
IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD)
CALL LCMSIX(IPEDIT,TEXT12,1)
CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE)
MAXNBI=ISTATE(2)
CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM)
IPLB3=C_NULL_PTR
DO 30 IBM=1,NMIL
CALL COMBIB(IPEDIT,IPLB3,PARTYP(IPAR),IBM,NAMLCM,TEXT8,MAXNBI,
1 VALPAR)
RVALO(IPAR,IBM)=VALPAR
30 CONTINUE
CALL LCMSIX(IPEDIT,' ',2)
ELSE
CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN LOCAL'//
1 ' PARAMETER TYPE.')
ENDIF
IF(IMPX.GT.1) THEN
WRITE(6,120) PARKEY(IPAR),(RVALO(IPAR,IBM),IBM=1,NMIL)
ENDIF
JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
DO 40 IBM=1,NMIL
KPCPO=LCMDIL(JPCPO,IBM)
CALL LCMSIX(KPCPO,'TREE',1)
FLOTT=RVALO(IPAR,IBM)
TEXT8='REAL'
CALL COMPAV(KPCPO,IPAR,NLOC,TEXT8,FLOTT,NITMA,TEXT12,
1 MUPL2(NPAR+IPAR,IBM),LGNE2(NPAR+IPAR,IBM))
CALL LCMSIX(KPCPO,' ',2)
40 CONTINUE
45 CONTINUE
DEALLOCATE(RVALO)
*----
* UPDATE THE PARAMETER TREE IN EACH MIXTURE COMPONENT
*----
50 JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
DO 90 IBM=1,NMIL
IF(IMPX.GT.4) THEN
WRITE(6,'(/17H COMGEP: MIXTURE=,I6)') IBM
WRITE(6,110) (MUPL2(I,IBM),I=1,NPAR+NLOC)
WRITE(6,'(/)')
ENDIF
DO 55 I=1,NPAR+NLOC
IF(MUPL2(I,IBM).EQ.0) THEN
WRITE(6,'(/17H COMGEP: MIXTURE=,I6,23H, UNDEFINED MUPLET ELEM,
1 4HENT=,I6)') IBM,I
CALL XABORT('COMGEP: A MUPLET ELEMENT IS NOT ASSIGNED.')
ENDIF
55 CONTINUE
KPCPO=LCMDIL(JPCPO,IBM)
**
** Parameter tree: this tree has a number of stages equal to the
** number of parameters. For each value of the i-th parameter, we
** find the position in the tree corresponding to the value of the
** (i+1)-th parameter.
** NCALAR Number of elementary calculations stored in the tree.
** NVPO(1) Number of nodes in the parameter tree, including the root.
** The value corresponding to the root is not used.
** DEBARB - If the node does not correspond to the last parameter:
** index in DEBARB of the first daughter of the node.
** - If the node correspond to the last parameter: index in
** DEBARB where we recover the index of an elementary
** calculation.
** ARBVAL Index of the corresponding parameter in the 'pval'//n
** record.
*
** EXEMPLE: dn = value in DEBARB, (m) = value in ARBVAL
**
** Root *(0)
** !
** Param. Nb 1 d2(1)
** -------------------
** ! !
** Param. Nb 2 d3(1) 4(2)
** --------- ---------
** ! ! ! ! !
** Param. Nb 3 d5(1) 6(3) d7(1) 8(2) 9(3) d10
**
** Calculation Nb: 4 5 1 2 3
**
** DEBARB: 2 3 5 7 10 4 5 1 2 3
** ARBVAL: 0 1 1 2 1 3 1 2 3
*
CALL LCMSIX(KPCPO,'TREE',1)
CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM)
IF(ILONG.EQ.0) THEN
MAXNVP=20*(NPAR+NLOC+1)
ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
IDEBAR(:MAXNVP+1)=0
IARBVA(:MAXNVP)=0
IARBVA=0
DO 60 I=1,NPAR+NLOC
IDEBAR(I)=I+1
IARBVA(I+1)=1
60 CONTINUE
IDEBAR(NPAR+NLOC+1)=NPAR+NLOC+2
IDEBAR(NPAR+NLOC+2)=1
NCALAR=1
NVPNEW=NPAR+NLOC+1
ELSE
*
* Find position of the new point and create new PARBRE.
*
* "II" is the order number of first parameter which recives a
* "brand new" value.
* COMTRE returns .TRUE. if the sweep throught the tree reaches
* its bottom, otherwise it returns "KK" value: level of the
* first new node to be introduced.
*
CALL LCMGET(KPCPO,'NVP',NVPO)
MAXNVP=NVPO(2)
ALLOCATE(JDEBAR(NVPO(1)+1),JARBVA(NVPO(1)))
CALL LCMGET(KPCPO,'NCALS',NCALAR)
CALL LCMGET(KPCPO,'DEBARB',JDEBAR)
CALL LCMGET(KPCPO,'ARBVAL',JARBVA)
DO 70 IPAR=1,NPAR+NLOC
IF(LGNE2(IPAR,IBM)) THEN
II=IPAR
GO TO 80
ENDIF
70 CONTINUE
II=NPAR+NLOC+1
80 LGERR=COMTRE(NPAR+NLOC,NVPO(1),JARBVA,JDEBAR,
1 MUPL2(1,IBM),KK,I0,IORD,JJ,LAST)
IF((II.GT.NPAR+NLOC).AND.LGERR) THEN
WRITE(TEXT4,'(I4)') IORD
CALL XABORT('COMGEP: ELEMENTARY CALCULATION HAS THE SAME'//
1 ' PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4)
ENDIF
*
* Size of the new tree.
*
NVPNEW=NVPO(1)+NPAR+NLOC+1-MIN(II,KK)
IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP
ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
IDEBAR(:MAXNVP+1)=0
IARBVA(:MAXNVP)=0
*
* Update values and suppress old PARBRE.
*
CALL COMARB(NPAR+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA,
1 LGNE2(1,IBM),MUPL2(1,IBM),NCALAR,IDEBAR,IARBVA)
DEALLOCATE(JARBVA,JDEBAR)
ENDIF
IF(NCALAR.NE.NCAL) CALL XABORT('COMGEP: INVALID NCALAR.')
NVPO(1)=NVPNEW
NVPO(2)=MAXNVP
CALL LCMPUT(KPCPO,'NVP',2,1,NVPO)
CALL LCMPUT(KPCPO,'NCALS',1,1,NCALAR)
CALL LCMPUT(KPCPO,'DEBARB',NVPNEW+1,1,IDEBAR)
CALL LCMPUT(KPCPO,'ARBVAL',NVPNEW,1,IARBVA)
DEALLOCATE(IARBVA,IDEBAR)
IF(NCALAR.EQ.1) THEN
ALLOCATE(IORIGI(MAXCAL))
IORIGI(:MAXCAL)=0
ELSE
CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM)
IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(1).')
ALLOCATE(IORIGI(MAXCAL))
IORIGI(:MAXCAL)=0
CALL LCMGET(KPCPO,'ORIGIN',IORIGI)
ENDIF
IF(NCALAR.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(2).')
IORIGI(NCALAR)=NORIG
CALL LCMPUT(KPCPO,'ORIGIN',NCALAR,1,IORIGI)
DEALLOCATE(IORIGI)
CALL LCMSIX(KPCPO,' ',2)
90 CONTINUE
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(LGNE2,MUPL2)
RETURN
*
100 FORMAT(31H COMGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4)
110 FORMAT(17H COMGEP: MUPLET =,10I6:/(17X,10I6))
120 FORMAT(30H COMGEP: SET LOCAL PARAMETER ',A,3H' =,1P,5E12.4/(37X,
1 5E12.4))
END
|
