1 subroutine utmoch ( nocham, option,
3 > nbcomp, nbtvch, typcha,
4 > adnocp, adcaen, adcare, adcaca,
5 > ulsort, langue, codret )
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c UTilitaire - MOdification d'un CHamp
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . nocham . e . char8 . nom de l'objet champ .
33 c . option . e . 1 . option de la modification : .
34 c . . . . 1 : ajout de la fonction nomobj .
35 c . nomobj . e . char8 . nom de la fonction a ajouter .
36 c . npfonc . e . char8 . nom de la fonction associee .
37 c . nbcomp . s . 1 . nombre de composantes .
38 c . nbtvch . s . 1 . nombre de tableaux du champ .
39 c . typcha . s . 1 . edin64/edfl64 selon entier/reel .
40 c . adnocp . s . 1 . adresse des noms des champ et composantes .
41 c . adcaen . s . 1 . adresse des caracteristiques entieres .
42 c . adcare . s . 1 . adresse des caracteristiques reelles .
43 c . adcaca . s . 1 . adresse des caracteristiques caracteres .
44 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
45 c . langue . e . 1 . langue des messages .
46 c . . . . 1 : francais, 2 : anglais .
47 c . codret . es . 1 . code de retour des modules .
48 c . . . . 0 : pas de probleme .
49 c . . . . 1 : probleme .
50 c ______________________________________________________________________
53 c 0. declarations et dimensionnement
56 c 0.1. ==> generalites
62 parameter ( nompro = 'UTMOCH' )
78 integer nbcomp, nbtvch, typcha
79 integer adnocp, adcaen, adcare, adcaca
81 character*8 nocham, nomobj, npfonc
83 integer ulsort, langue, codret
85 c 0.4. ==> variables locales
87 integer iaux, jaux, kaux
88 integer codre1, codre2, codre3, codre4
92 integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
93 integer carsup, nbtafo, typint
94 integer advale, advalr, adobch, adprpg, adtyas
99 parameter ( nbmess = 10 )
100 character*80 texte(nblang,nbmess)
102 c 0.5. ==> initialisations
103 c ______________________________________________________________________
113 #ifdef _DEBUG_HOMARD_
114 write (ulsort,texte(langue,1)) 'Entree', nompro
118 texte(1,4) = '(''Champ avant modification :'')'
119 texte(1,5) = '(''Champ apres modification :'')'
121 > '(''Nombre initial de tableaux du champ :'',i5)'
123 > '(''Nombre de tableaux de la fonction a ajouter :'',i5)'
125 > '(''Nombre final de tableaux du champ :'',i5)'
127 texte(2,4) = '(''Field before modification :'')'
128 texte(2,5) = '(''Field after modification :'')'
130 > '(''Initial number of arrays in the field :'',i5)'
132 > '(''Number of arrays in the function to be added :'',i5)'
134 > '(''Final number of arrays in the field :'',i5)'
136 #ifdef _DEBUG_HOMARD_
137 write (ulsort,texte(langue,4))
138 call gmprsx (nompro, nocham )
139 call gmprsx (nompro, nocham//'.Nom_Comp' )
140 call gmprsx (nompro, nocham//'.Cham_Ent' )
141 cgn call gmprsx (nompro, nocham//'.Cham_Ree' )
142 cgn call gmprsx (nompro, nocham//'.Cham_Car' )
146 c 2. caracteristiques de l'objet contenant le champ
149 c 2.1. ==> nombre de tableaux de valeurs pour ce champ
151 if ( codret.eq.0 ) then
153 #ifdef _DEBUG_HOMARD_
154 write (ulsort,texte(langue,3)) 'UTCACH', nompro
156 call utcach ( nocham,
158 > nbcomp, nbtvch, typcha,
159 > adnocp, adcaen, adcare, adcaca,
160 > ulsort, langue, codret )
163 #ifdef _DEBUG_HOMARD_
164 write (ulsort,texte(langue,6)) nbtvch
167 c 2.2. ==> nombre de tableaux de valeurs pour ce champ et cette fonction
169 if ( codret.eq.0 ) then
171 cgn write(ulsort,*) 'au depart'
174 do 21 , iaux = 1 , nbtvch
176 jaux = adcaca + nbincc*(iaux-1)
178 if ( smem(jaux).eq.npfonc ) then
183 cgn call gmprot (nompro, nocham//'.Cham_Ent',
184 cgn > nbinec*(iaux-1)+1, nbinec*iaux )
188 #ifdef _DEBUG_HOMARD_
189 write (ulsort,texte(langue,7)) nbtach
194 c 3. ajout d'une fonction
197 if ( option.eq.1 ) then
199 c 3.1. ==> caracteristiques de la fonction
201 if ( codret.eq.0 ) then
203 cgn call gmprsx (nompro, nomobj )
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,texte(langue,3)) 'UTCAFO', nompro
207 call utcafo ( nomobj,
209 > typgeo, ngauss, nbenmx, nbvapr, nbtyas,
210 > carsup, nbtafo, typint,
211 > advale, advalr, adobch, adprpg, adtyas,
212 > ulsort, langue, codret )
216 c 3.2. ==> allongement de la structure pour accueillir les nbtafo
217 c tableaux de la fonction
219 if ( codret.eq.0 ) then
221 call gmecat ( nocham, 2, nbtvch+nbtach, codre1 )
222 iaux = nbinec*(nbtvch+nbtach)
223 call gmmod ( nocham//'.Cham_Ent',
224 > adcaen, nbinec*nbtvch, iaux, 1, 1, codre2 )
226 call gmmod ( nocham//'.Cham_Ree',
227 > adcare, nbtvch, iaux, 1, 1, codre3 )
228 iaux = nbincc*(nbtvch+nbtach)
229 call gmmod ( nocham//'.Cham_Car',
230 > adcaca, nbincc*nbtvch, iaux, 1, 1, codre4 )
232 codre0 = min ( codre1, codre2, codre3, codre4 )
233 codret = max ( abs(codre0), codret,
234 > codre1, codre2, codre3, codre4 )
237 cgn write(ulsort,*) 'apres 32'
238 cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec )
239 cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec )
240 cgn call gmprsx (nompro, nocham//'.Cham_Ent' )
241 cgn call gmprsx (nompro, nocham//'.Cham_Car' )
243 c 3.3. ==> transfert des caracteristiques de la fonction
245 c 1. type de support au sens MED
246 c 2. numero du pas de temps
248 c 4. nombre de points de Gauss
249 c 5. nombre d'entites support
250 c 6. nombre de valeurs du profil eventuel
251 c 7. supports associes
252 c 8. noeuds par elements/points de Gauss/autre
253 c 9. numero du 1er tableau dans la fonction
254 c 10. -1 ou champ elga/champ elno
255 c 11. type interpolation
256 c 21-nbinec. type des supports associes
258 if ( codret.eq.0 ) then
260 do 33 , iaux = 1 , nbtach
262 jaux = adcaen + nbinec*(nbtvch+iaux-1)
264 imem(jaux+3) = ngauss
265 imem(jaux+4) = nbenmx
266 imem(jaux+5) = nbvapr
267 imem(jaux+6) = nbtyas
268 imem(jaux+7) = carsup
269 if ( carsup.ne.2 ) then
272 imem(jaux+10) = typint
273 if ( nbtyas.gt.0 ) then
274 do 331 , kaux = 1 , nbtyas
275 imem(jaux+19+kaux) = imem(adtyas+kaux-1)
279 jaux = adcaca + nbincc*(nbtvch+iaux-1)
281 smem(jaux+1) = smem(adprpg)
282 smem(jaux+2) = smem(adprpg+1)
287 cgn write(ulsort,*) 'apres 33'
288 cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec )
289 cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec )
290 cgn call gmprsx (nompro, nocham//'.Cham_Ent' )
291 cgn call gmprsx (nompro, nocham//'.Cham_Car' )
293 c 3.4. ==> transfert des caracteristiques temporelles du champ
294 c on doit recopier celles de la fonction associee
296 if ( codret.eq.0 ) then
298 cgn write(ulsort,*) 'apres 34'
301 do 34 , iaux = 1 , nbtvch
303 jaux = adcaca + nbincc*(iaux-1)
305 if ( smem(jaux).eq.npfonc ) then
307 c 2. numero du pas de temps
308 imem(adcaen+nbinec*(nbtvch+kaux)+1) =
309 > imem(adcaen+nbinec*(iaux-1)+1)
311 imem(adcaen+nbinec*(nbtvch+kaux)+2) =
312 > imem(adcaen+nbinec*(iaux-1)+2)
313 c 9. numero du 1er tableau dans la fonction
314 imem(adcaen+nbinec*(nbtvch+kaux)+8) =
315 > imem(adcaen+nbinec*(iaux-1)+8)
317 rmem(adcare+(nbtvch+kaux)) = rmem(adcare+iaux-1)
320 cgn call gmprot (nompro, nocham//'.Cham_Ent',
321 cgn > nbinec*(nbtvch+kaux-1)+1, nbinec*(nbtvch+kaux) )
328 cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec )
329 cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec )
330 cgn call gmprsx (nompro, nocham//'.Cham_Ent' )
331 cgn call gmprsx (nompro, nocham//'.Cham_Car' )
333 c 3.5. ==> cumul du nombre total de tableaux pour le champ
335 nbtvch = nbtvch + kaux
337 #ifdef _DEBUG_HOMARD_
338 write (ulsort,texte(langue,8)) nbtvch
347 #ifdef _DEBUG_HOMARD_
348 write (ulsort,texte(langue,5))
349 call gmprsx (nompro, nocham )
350 call gmprsx (nompro, nocham//'.Nom_Comp' )
351 call gmprsx (nompro, nocham//'.Cham_Ent' )
352 call gmprsx (nompro, nocham//'.Cham_Ree' )
353 call gmprsx (nompro, nocham//'.Cham_Car' )
356 if ( codret.ne.0 ) then
360 write (ulsort,texte(langue,1)) 'Sortie', nompro
361 write (ulsort,texte(langue,2)) codret
365 #ifdef _DEBUG_HOMARD_
366 write (ulsort,texte(langue,1)) 'Sortie', nompro