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
|
*DECK APXCAT
SUBROUTINE APXCAT(IPAPX,IPRHS,NORIG,NPAR,NCAL,MUPCPO,LGNCPO,LWARN)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To catenate a RHS Apex file into the output Apex file.
*
*Copyright:
* Copyright (C) 2025 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
* IPAPX pointer to the output Apex file.
* IPRHS pointer to the rhs Apex file (contains the new calculations).
* NORIG index of the elementary calculation associated to the
* father node in the parameter tree.
* NPAR number of global parameters in the output Apex file.
* NCAL initial number of calculations in LHS Apex file.
* MUPCPO tuple of the new global parameters in the output Apex file.
* LGNCPO LGNEW value of the new global parameters in the output
* Apex file.
* LWARN logical used in case if an elementary calculation in the RHS
* is already present in Apex file. If LWARN=.true. a warning is
* send and the Apex file values are kept otherwise XABORT is
* called (default).
*
*-----------------------------------------------------------------------
*
USE GANLIB
USE hdf5_wrap
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPAPX,IPRHS
INTEGER NORIG,NPAR,NCAL,MUPCPO(NPAR)
LOGICAL LGNCPO(NPAR),LWARN
*----
* LOCAL VARIABLES
*----
PARAMETER (MAXPAR=50)
INTEGER RANK,TYPE,NBYTE,DIMSR(5)
INTEGER MUPLET(2*MAXPAR),MUPRHS(2*MAXPAR)
CHARACTER HSMG*131,RECNAM*80,RECNA2*80,TEXT4*4,TEXT12*12
LOGICAL COMTRE,LGERR,LGNEW(MAXPAR)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IORRHS,JDEBAR,JARBVA,VINTE,
1 IDEBAR,IARBVA,IORIGI
REAL, ALLOCATABLE, DIMENSION(:) :: VREAL
CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT_RHS
CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: VCHAR
CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: PARNAM_RHS,
1 PARNAM_LHS
*
IF(NPAR.GT.MAXPAR) CALL XABORT('APXCAT: MAXPAR OVERFLOW.')
NGR=0
CALL APXTOC(IPRHS,IMPX,NLAM,NREA,NBISO,NBMAC,NMILR,NPARR,NVPR,
1 NISOF,NISOP,NISOS,NCALR,NGR,NISOTS,NSURFD,NPRC)
IF(NCALR.EQ.0) THEN
CALL XABORT('APXCAT: NO CALCULATION IN RHS APEX FILE.')
ELSE IF(NPARR.GT.NPAR) THEN
WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV,
1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H GT,I7,1H.)') NPARR,
2 NPAR
CALL XABORT(HSMG)
ENDIF
NVPO=0 ! initial number of nodes in LHS Apex file
CALL hdf5_read_data(IPAPX,"NCALS",NCAL)
IF(NCAL.GT.0) THEN
NG=0
CALL APXTOC(IPAPX,0,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR1,NVPO,
1 NISOF,NISOP,NISOS,NCAL,NG,NISOTS,NSURFD,NPRC)
IF(NGR.NE.NG) THEN
WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV,
1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NGR,NG
CALL XABORT(HSMG)
ELSE IF(NMILR.NE.NMIL) THEN
WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV,
1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMILR,NMIL
CALL XABORT(HSMG)
ELSE IF(NPAR1.NE.NPAR) THEN
WRITE(HSMG,'(42HAPXCAT: ELEMENTARY CALCULATION WITH AN INV,
1 31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR1,
2 NPAR
CALL XABORT(HSMG)
ENDIF
ENDIF
*----
* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS APEX FILE
*----
IDEM=0
NCALS=NCAL
DO 170 ICAL=1,NCALR
*----
* COMPUTE THE MUPLET VECTOR FROM THE RHS APEX FILE
*----
CALL hdf5_read_data(IPRHS,"/paramtree/DEBTREE",JDEBAR)
CALL hdf5_read_data(IPRHS,"/paramtree/TREEVAL",JARBVA)
CALL hdf5_read_data(IPRHS,"/paramtree/ORIGIN",IORRHS)
DO 30 I=NVPR-NCALR+1,NVPR
IF(JDEBAR(I+1).EQ.ICAL) THEN
I0=I
GO TO 40
ENDIF
30 CONTINUE
CALL XABORT('APXCAT: MUPLET ALGORITHM FAILURE 1.')
40 MUPRHS(NPAR)=JARBVA(I0)
DO 65 IPAR=NPAR-1,1,-1
DO 50 I=1,NVPR-NCALR
IF(JDEBAR(I+1).GT.I0) THEN
I0=I
GO TO 60
ENDIF
50 ENDDO
CALL XABORT('APXCAT: MUPLET ALGORITHM FAILURE 2.')
60 MUPRHS(IPAR)=JARBVA(I0)
65 CONTINUE
DEALLOCATE(JARBVA,JDEBAR)
*----
* RECOVER THE GLOBAL PARAMETERS
*----
DO 70 I=1,NPAR
MUPLET(I)=MUPCPO(I)
LGNEW(I)=LGNCPO(I)
70 CONTINUE
CALL hdf5_read_data(IPAPX,"/paramdescrip/PARNAM",PARNAM_LHS)
CALL hdf5_read_data(IPRHS,"/paramdescrip/PARFMT",PARFMT_RHS)
CALL hdf5_read_data(IPRHS,"/paramdescrip/PARNAM",PARNAM_RHS)
DO 100 IPAR=1,NPARR
DO 80 I0=1,NPAR
IF(PARNAM_RHS(IPAR).EQ.PARNAM_LHS(I0)) THEN
IPARN=I0
GO TO 90
ENDIF
80 CONTINUE
CALL XABORT('APXCAT: UNABLE TO FIND '//PARNAM_RHS(IPAR)//'.')
90 WRITE(RECNAM,'(17H/paramvalues/PVAL,I8)') IPAR
IVAL=MUPRHS(IPAR)
IF(PARFMT_RHS(IPAR).EQ.'FLOTTANT') THEN
CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VREAL)
FLOTT=VREAL(IVAL)
DEALLOCATE(VREAL)
ELSE IF(PARFMT_RHS(IPAR).EQ.'ENTIER') THEN
CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VINTE)
NITMA=VINTE(IVAL)
DEALLOCATE(VINTE)
ELSE IF(PARFMT_RHS(IPAR).EQ.'CHAINE') THEN
CALL hdf5_read_data(IPRHS,TRIM(RECNAM),VCHAR)
TEXT12=VCHAR(IVAL)
DEALLOCATE(VCHAR)
ENDIF
CALL APXPAV(IPAPX,IPARN,NPAR,PARFMT_RHS(IPAR),FLOTT,NITMA,
1 TEXT12,MUPLET(IPARN),LGNEW(IPARN))
100 CONTINUE
DEALLOCATE(PARNAM_RHS,PARFMT_RHS,PARNAM_LHS)
*----
* UPDATE THE PARAMETER TREE IN THE OUTPUT APEX FILE
*----
IF(NVPO.EQ.0) THEN
MAXNVP=20*(NPAR+1)
ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
IDEBAR(:MAXNVP+1)=0
IARBVA(:MAXNVP)=0
IARBVA=0
DO 140 I=1,NPAR
IDEBAR(I)=I+1
IARBVA(I+1)=1
140 CONTINUE
IDEBAR(NPAR+1)=NPAR+2
IDEBAR(NPAR+2)=1
NCALS=1
NVPNEW=NPAR+1
ELSE
CALL hdf5_read_data(IPAPX,"/paramtree/DEBTREE",JDEBAR)
CALL hdf5_read_data(IPAPX,"/paramtree/TREEVAL",JARBVA)
DO 150 IPAR=1,NPAR
IF(LGNEW(IPAR)) THEN
II=IPAR
GO TO 160
ENDIF
150 CONTINUE
II=NPAR+1
160 LGERR=COMTRE(NPAR,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ,
1 LAST)
IF((II.GT.NPAR).AND.LGERR) THEN
WRITE(TEXT4,'(I4)') IORD
IF(LWARN) THEN
WRITE(6,*)'APXCAT: ELEMENTARY CALCULATION HAS THE ',
1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4
DEALLOCATE(JARBVA,JDEBAR,IORRHS)
IDEM=IDEM+1
GOTO 170
ELSE
CALL XABORT('APXCAT: ELEMENTARY CALCULATION HAS THE '//
1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4)
ENDIF
ENDIF
*
* Size of the new tree.
*
NVPNEW=NVPO+NPAR+1-MIN(II,KK)
MAXNVP=NVPR
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(NPAR,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,NCALS,
1 IDEBAR,IARBVA)
DEALLOCATE(JARBVA,JDEBAR)
ENDIF
IF(NCALS.NE.NCAL+ICAL-IDEM) CALL XABORT('APXCAT: INVALID NCALS.')
NVPO=NVPNEW
CALL hdf5_write_data(IPAPX,"/NCALS",NCALS)
CALL hdf5_write_data(IPAPX,"/paramtree/DEBTREE",IDEBAR(:NVPNEW+1))
CALL hdf5_write_data(IPAPX,"/paramtree/TREEVAL",IARBVA(:NVPNEW))
DEALLOCATE(IARBVA,IDEBAR)
IF(NCALS.EQ.1) THEN
MAXNCA=1000
ALLOCATE(IORIGI(MAXNCA))
IORIGI(:MAXNCA)=0
ELSE
CALL hdf5_info(IPAPX,"/paramtree/ORIGIN",RANK,TYPE,NBYTE,DIMSR)
MAXNCA=DIMSR(1)
IF(NCALS.GT.MAXNCA) MAXNCA=NCALS+MAXNCA
ALLOCATE(IORIGI(MAXNCA))
IORIGI(:MAXNCA)=0
CALL hdf5_read_data(IPAPX,"/paramtree/ORIGIN",VINTE)
IORIGI(:DIMSR(1))=VINTE(:DIMSR(1))
DEALLOCATE(VINTE)
ENDIF
IF(IORRHS(ICAL).EQ.0) THEN
IORIGI(NCALS)=NORIG
ELSE
IORIGI(NCALS)=NCAL+IORRHS(ICAL)
ENDIF
CALL hdf5_write_data(IPAPX,"/paramtree/ORIGIN",IORIGI(:NCALS))
DEALLOCATE(IORIGI,IORRHS)
IF(NCALS.NE.NCAL+ICAL-IDEM) CALL XABORT('APXCAT: INVALID NCALS.')
*----
* RECOVER THE ELEMENTARY CALCULATION
*----
WRITE(RECNAM,'(4Hcalc,I8)') NCALS
WRITE(RECNA2,'(4Hcalc,I8)') ICAL
call hdf5_copy(IPRHS,RECNA2,IPAPX,RECNAM) ! IPRHS -> IPAPX
170 CONTINUE
* END OF LOOP ON ELEMENTARY CALCULATIONS. ********************
RETURN
END
|
