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 COMCAT
SUBROUTINE COMCAT(IPCPO,IPRHS,NORIG,NPARN,MUPCPO,LGNCPO,LWARN)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Catenate a RHS compo into the output multicompo.
*
*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 output multicompo.
* IPRHS pointer to the rhs multicompo (contains the new calculations).
* NORIG index of the elementary calculation associated to the
* father node in the parameter tree.
* NPARN number of global parameters in the output multicompo.
* MUPCPO tuple of the new global parameters in the output multicompo.
* LGNCPO LGNEW value of the new global parameters in the output
* multicompo.
* LWARN logical used in case if an elementary calculation in the RHS
* is already present in CPO. If LWARN=.true. a warning is send
* and the CPO values are kept, otherwise XABORT is called
* (default).
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPCPO,IPRHS
INTEGER NORIG,NPARN,MUPCPO(NPARN)
LOGICAL LGNCPO(NPARN),LWARN
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) JPCPO,KPCPO,JPRHS,KPRHS,LPCPO,LPRHS,MPCPO,MPRHS
PARAMETER (NSTATE=40,MAXPAR=50,MAXVAL=1000)
INTEGER ISTATE(NSTATE),NVPO(2),NVALUE(2*MAXPAR),MUPLET(2*MAXPAR),
1 MUPRHS(2*MAXPAR)
CHARACTER HSMG*131,RECNAM*12,TEXT4*4,TEXT12*12,PARFMT(MAXPAR)*8,
1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*12,PARCPO(MAXPAR)*12
LOGICAL COMTRE,LGERR,LGNEW(MAXPAR)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: ILCALR,MUOLD,IORRHS,IDEBAR,
1 IARBVA,JDEBAR,JARBVA,IORIGI,VINTE
REAL, ALLOCATABLE, DIMENSION(:) :: VREAL
LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGOLD
*
NIDEM=0
CALL LCMGET(IPRHS,'STATE-VECTOR',ISTATE)
NMIL=ISTATE(1)
NG=ISTATE(2)
NCALR=ISTATE(3)
NPAR=ISTATE(5)
NLOC=ISTATE(6)
IF(NCALR.EQ.0) CALL XABORT('COMCAT: NO CALCULATION IN RHS COMPO.')
ALLOCATE(ILCALR(NCALR))
*
CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
NCAL=ISTATE(3)
IF(NPARN+NLOC.GT.2*MAXPAR) CALL XABORT('COMCAT: MAXPAR OVERFLOW.')
IF(NCAL.EQ.0) THEN
* COMPLETE STATE-VECTOR.
IF(ISTATE(1).EQ.0) THEN
ISTATE(1)=NMIL
ELSE IF(NMIL.NE.ISTATE(1)) THEN
WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1)
CALL XABORT(HSMG)
ENDIF
ISTATE(2)=NG
ELSE
IF(NMIL.NE.ISTATE(1)) THEN
WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1)
CALL XABORT(HSMG)
ELSE IF(NG.NE.ISTATE(2)) THEN
WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,ISTATE(2)
CALL XABORT(HSMG)
ENDIF
ENDIF
IF(NPAR.GT.NPARN) THEN
WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR,
2 NPARN
CALL XABORT(HSMG)
ELSE IF(NLOC.NE.ISTATE(6)) THEN
WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
1 30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOC,
2 ISTATE(6)
CALL XABORT(HSMG)
ENDIF
*----
* ADJUST THE SIZE OF THE OUTPUT COMPO
*----
ISTATE(3)=ISTATE(3)+NCALR
IF(ISTATE(3).GT.ISTATE(4)) THEN
ISTATE(4)=ISTATE(4)+NCALR+9
JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
DO 10 IBM=1,NMIL
KPCPO=LCMDIL(JPCPO,IBM)
LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4))
10 CONTINUE
ENDIF
MAXCAL=ISTATE(4)
*----
* UPDATE THE STATE-VECTOR
*----
CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE)
*----
* MAIN LOOP OVER THE HOMOGENEOUS MIXTURES *********************
*----
JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
JPRHS=LCMGID(IPRHS,'MIXTURES')
ALLOCATE(MUOLD(NCALR*NPARN),LGOLD(NCALR*NPARN))
DO 190 IBM=1,NMIL
KPCPO=LCMDIL(JPCPO,IBM)
KPRHS=LCMGIL(JPRHS,IBM)
*----
* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS COMPO
*----
ILCALR(:NCALR)=1
NIDEM=0
DO 170 ICAL=1,NCALR
*----
* COMPUTE THE MUPLET VECTOR FROM THE RHS COMPO
*----
CALL LCMSIX(KPRHS,'TREE',1)
CALL LCMLEN(KPRHS,'ARBVAL',MAXNVP,ITYLCM)
CALL LCMLEN(KPRHS,'ORIGIN',MAXNCA,ITYLCM)
ALLOCATE(IORRHS(MAXNCA))
CALL LCMGET(KPRHS,'ORIGIN',IORRHS)
ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP))
CALL LCMGET(KPRHS,'NCALS',NCALS)
CALL LCMGET(KPRHS,'DEBARB',JDEBAR)
CALL LCMGET(KPRHS,'ARBVAL',JARBVA)
CALL LCMGET(KPRHS,'NVP',NVPO)
DO 30 I=NVPO(1)-NCALS+1,NVPO(1)
IF(JDEBAR(I+1).EQ.ICAL) THEN
I0=I
GO TO 40
ENDIF
30 CONTINUE
CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 1.')
40 MUPRHS(NPAR+NLOC)=JARBVA(I0)
DO 65 IPAR=NPAR+NLOC-1,1,-1
DO 50 I=1,NVPO(1)-NCALS
IF(JDEBAR(I+1).GT.I0) THEN
I0=I
GO TO 60
ENDIF
50 CONTINUE
CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 2.')
60 MUPRHS(IPAR)=JARBVA(I0)
65 CONTINUE
DEALLOCATE(JARBVA,JDEBAR)
*----
* RECOVER THE GLOBAL PARAMETERS
*----
IF(IBM.EQ.1) THEN
DO 70 I=1,NPARN
MUPLET(I)=MUPCPO(I)
LGNEW(I)=LGNCPO(I)
70 CONTINUE
CALL LCMSIX(IPCPO,'GLOBAL',1)
CALL LCMSIX(IPRHS,'GLOBAL',1)
CALL LCMGTC(IPCPO,'PARKEY',12,NPARN,PARCPO)
CALL LCMGTC(IPRHS,'PARKEY',12,NPAR,PARKEY)
CALL LCMGTC(IPRHS,'PARFMT',8,NPAR,PARFMT)
CALL LCMGET(IPRHS,'NVALUE',NVALUE)
DO 100 IPAR=1,NPAR
DO 80 I0=1,NPARN
IF(PARKEY(IPAR).EQ.PARCPO(I0)) THEN
IPARN=I0
GO TO 90
ENDIF
80 CONTINUE
CALL XABORT('COMCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.')
90 WRITE(RECNAM,'(''pval'',I8.8)') IPAR
IVAL=MUPRHS(IPAR)
IF(PARFMT(IPAR).EQ.'REAL') THEN
ALLOCATE(VREAL(NVALUE(IPAR)))
CALL LCMGET(IPRHS,RECNAM,VREAL)
FLOTT=VREAL(IVAL)
DEALLOCATE(VREAL)
ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN
ALLOCATE(VINTE(NVALUE(IPAR)))
CALL LCMGET(IPRHS,RECNAM,VINTE)
NITMA=VINTE(IVAL)
DEALLOCATE(VINTE)
ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN
IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMCAT: MAXVAL '
1 //'OVERFLOW.')
CALL LCMGTC(IPRHS,RECNAM,12,NVALUE(IPAR),VCHAR)
TEXT12=VCHAR(IVAL)
ENDIF
CALL COMPAV(IPCPO,IPARN,NPARN,PARFMT(IPAR),FLOTT,NITMA,
1 TEXT12,MUPLET(IPARN),LGNEW(IPARN))
100 CONTINUE
DO 110 IPARN=1,NPARN
MUOLD((ICAL-1)*NPARN+IPARN)=MUPLET(IPARN)
LGOLD((ICAL-1)*NPARN+IPARN)=LGNEW(IPARN)
110 CONTINUE
CALL LCMSIX(IPRHS,' ',2)
CALL LCMSIX(IPCPO,' ',2)
ELSE
DO 120 IPARN=1,NPARN
MUPLET(IPARN)=MUOLD((ICAL-1)*NPARN+IPARN)
LGNEW(IPARN)=LGOLD((ICAL-1)*NPARN+IPARN)
120 CONTINUE
ENDIF
*----
* RECOVER THE LOCAL PARAMETERS
*----
CALL LCMSIX(KPCPO,'TREE',1)
DO 130 ILOC=1,NLOC
WRITE(RECNAM,'(''pval'',I8.8)') ILOC
IVAL=MUPRHS(NPAR+ILOC)
CALL LCMLEN(KPRHS,RECNAM,ILONG,ITYLCM)
ALLOCATE(VREAL(ILONG))
CALL LCMGET(KPRHS,RECNAM,VREAL)
FLOTT=VREAL(IVAL)
DEALLOCATE(VREAL)
CALL COMPAV(KPCPO,ILOC,NLOC,PARFMT(ILOC),FLOTT,NITMA,TEXT12,
1 MUPLET(NPARN+ILOC),LGNEW(NPARN+ILOC))
130 CONTINUE
CALL LCMSIX(KPRHS,' ',2)
*----
* UPDATE THE PARAMETER TREE IN THE OUTPUT COMPO
*----
CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM)
IF(ILONG.EQ.0) THEN
MAXNVP=20*(NPARN+NLOC+1)
ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
IDEBAR(:MAXNVP+1)=0
IARBVA(:MAXNVP)=0
IARBVA=0
DO 140 I=1,NPARN+NLOC
IDEBAR(I)=I+1
IARBVA(I+1)=1
140 CONTINUE
IDEBAR(NPARN+NLOC+1)=NPARN+NLOC+2
IDEBAR(NPARN+NLOC+2)=1
NCALS=1
NVPNEW=NPARN+NLOC+1
ELSE
CALL LCMLEN(KPCPO,'ARBVAL',JLONG,ITYLCM)
ALLOCATE(JDEBAR(JLONG+1),JARBVA(JLONG))
CALL LCMGET(KPCPO,'NCALS',NCALS)
CALL LCMGET(KPCPO,'DEBARB',JDEBAR)
CALL LCMGET(KPCPO,'ARBVAL',JARBVA)
CALL LCMGET(KPCPO,'NVP',NVPO)
DO 150 IPAR=1,NPARN+NLOC
IF(LGNEW(IPAR)) THEN
II=IPAR
GO TO 160
ENDIF
150 CONTINUE
II=NPARN+NLOC+1
160 LGERR=COMTRE(NPARN+NLOC,NVPO(1),JARBVA,JDEBAR,MUPLET,KK,I0,
1 IORD,JJ,LAST)
IF((II.GT.NPARN+NLOC).AND.LGERR) THEN
WRITE(TEXT4,'(I4)') IORD
IF(LWARN) THEN
WRITE(6,*)'COMCAT: ELEMENTARY CALCULATION HAS THE ',
1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4
DEALLOCATE(JARBVA,JDEBAR,IORRHS)
CALL LCMSIX(KPCPO,' ',2)
ILCALR(ICAL)=0
NIDEM=NIDEM+1
GOTO 170
ELSE
CALL XABORT('COMCAT: ELEMENTARY CALCULATION HAS THE '//
1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4)
ENDIF
ENDIF
*
* Size of the new tree.
*
NVPNEW=NVPO(1)+NPARN+NLOC+1-MIN(II,KK)
IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP
ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
IDEBAR(NVPNEW+2:MAXNVP+1)=0
IARBVA(NVPNEW+1:MAXNVP)=0
*
* Update values and suppress old PARBRE.
*
CALL COMARB(NPARN+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA,LGNEW,
1 MUPLET,NCALS,IDEBAR,IARBVA)
DEALLOCATE(JARBVA,JDEBAR)
ENDIF
IF(NCALS.NE.NCAL+ICAL-NIDEM) CALL XABORT('COMCAT: INVALID NCALS.')
NVPO(1)=NVPNEW
NVPO(2)=MAXNVP
CALL LCMPUT(KPCPO,'NVP',2,1,NVPO)
CALL LCMPUT(KPCPO,'NCALS',1,1,NCALS)
CALL LCMPUT(KPCPO,'DEBARB',NVPO(1)+1,1,IDEBAR)
CALL LCMPUT(KPCPO,'ARBVAL',NVPO(1),1,IARBVA)
DEALLOCATE(IARBVA,IDEBAR)
IF(NCALS.EQ.1) THEN
ALLOCATE(IORIGI(MAXCAL))
IORIGI(:MAXCAL)=0
ELSE
CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM)
IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(1).')
ALLOCATE(IORIGI(MAXCAL))
IORIGI(:MAXCAL)=0
CALL LCMGET(KPCPO,'ORIGIN',IORIGI)
ENDIF
IF(NCALS.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(2).')
IF(IORRHS(ICAL).EQ.0) THEN
IORIGI(NCALS)=NORIG
ELSE
IORIGI(NCALS)=NCAL+IORRHS(ICAL)
ENDIF
CALL LCMPUT(KPCPO,'ORIGIN',NCALS,1,IORIGI)
DEALLOCATE(IORIGI)
CALL LCMSIX(KPCPO,' ',2)
DEALLOCATE(IORRHS)
170 CONTINUE
* END OF LOOP ON MIXTURES. ***********************************
*----
* RECOVER THE MICROLIBS
*----
LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4))
LPRHS=LCMGID(KPRHS,'CALCULATIONS')
NIDEM=0
DO 180 ICAL=1,NCALR
IF(ILCALR(ICAL).EQ.1)THEN
MPCPO=LCMDIL(LPCPO,NCAL+ICAL-NIDEM)
MPRHS=LCMGIL(LPRHS,ICAL)
CALL LCMEQU(MPRHS,MPCPO)
ELSE
NIDEM=NIDEM+1
ENDIF
180 CONTINUE
190 CONTINUE
DEALLOCATE(LGOLD,MUOLD)
*----
* RECOVER THE DEPLETION CHAIN
*----
CALL LCMLEN(IPRHS,'DEPL-CHAIN',ILONG,ITYLCM)
IF(ILONG.EQ.-1) THEN
CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
CALL LCMSIX(IPRHS,'DEPL-CHAIN',1)
CALL LCMEQU(IPRHS,IPCPO)
CALL LCMSIX(IPRHS,' ',2)
CALL LCMSIX(IPCPO,' ',2)
ENDIF
*----
* RECOVER THE MACRO-GEOMETRIES
*----
CALL LCMLEN(IPRHS,'GEOMETRIES',ILONG,ITYLCM)
IF(ILONG.GT.0) THEN
JPCPO=LCMLID(IPCPO,'GEOMETRIES',MAXCAL)
JPRHS=LCMGID(IPRHS,'GEOMETRIES')
DO 200 ICAL=1,NCALR
IF(ILCALR(ICAL).EQ.1)THEN
KPCPO=LCMDIL(JPCPO,NCAL+ICAL)
KPRHS=LCMGIL(JPRHS,ICAL)
CALL LCMEQU(KPRHS,KPCPO)
ENDIF
200 CONTINUE
ISTATE(11)=1
ENDIF
DEALLOCATE(ILCALR)
ISTATE(3)=ISTATE(3)-NIDEM
IF(ISTATE(15).EQ.-1) ISTATE(15)=0
CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE)
* END OF LOOP ON ELEMENTARY CALCULATIONS. ********************
RETURN
END
|
