1 subroutine pcfor1 ( option,
3 > nbpara, carenf, carchf,
6 > typfon, typcha, typgeo, nbtyas,
7 > ngauss, nbenmx, nbvapr,
8 > carsup, nbtafo, typint,
10 > advale, advalr, adobch, adprpg, adtyas,
12 > ulsort, langue, codret )
13 c ______________________________________________________________________
17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
20 c aupres des huissiers de justice Simart et Lavoir a Clamart
21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
22 c aupres des huissiers de justice
23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
25 c HOMARD est une marque deposee d'Electricite de France
31 c ______________________________________________________________________
33 c aPres adaptation - Fonctions - Recuperation - phase 1
35 c ______________________________________________________________________
37 c . nom . e/s . taille . description .
38 c .____________________________________________________________________.
39 c . option . e . 1 . option du traitement .
40 c . . . . -1 : Pas de changement dans le maillage .
41 c . . . . 0 : Adaptation complete .
42 c . . . . 1 : Modification de degre .
43 c . nofonc . e . char8 . nom de l'objet fonction similaire .
44 c . nrfonc . e . 1 . numero de la fonction dans le tableau .
45 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
46 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
47 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
48 c . . . . 1, pour une ancienne associee a une .
49 c . . . . autre fonction .
50 c . . . . -1, pour une nouvelle fonction .
51 c . . . . 2 : typcha .
52 c . . . . 3 : typgeo .
53 c . . . . 4 : nbtyas .
54 c . . . . 5 : ngauss .
55 c . . . . 6 : nnenmx .
56 c . . . . 7 : nnvapr .
57 c . . . . 8 : nbtafo .
59 c . . . . 10 : anvale .
60 c . . . . 11 : anvalr .
61 c . . . . 12 : anobch .
62 c . . . . 13 : anprpg .
63 c . . . . 14 : anlipr .
64 c . . . . 15 : npenmx .
65 c . . . . 16 : npvapr .
66 c . . . . 17 : apvale .
67 c . . . . 18 : apvalr .
68 c . . . . 19 : apobch .
69 c . . . . 20 : apprpg .
70 c . . . . 21 : apvatt .
71 c . . . . 22 : apvane .
72 c . . . . 23 : antyas .
73 c . . . . 24 : aptyas .
74 c . . . . 25 : numero de la 1ere fonction associee .
75 c . . . . 26 : numero de la 2nde fonction associee .
76 c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
77 c . . . nnfopa. 1 : nom de la fonction .
78 c . . . . 2 : nom de la fonction n associee .
79 c . . . . 3 : nom de la fonction p associee .
80 c . . . . 4 : obpcan .
81 c . . . . 5 : obpcap .
82 c . . . . 6 : obprof .
83 c . . . . 7 : oblopg .
84 c . . . . 8 : si aux points de Gauss, nom de la .
85 c . . . . fonction n ELNO correspondante .
86 c . . . . 9 : si aux points de Gauss, nom de la .
87 c . . . . fonction p ELNO correspondante .
88 c . nopafo . es . 1 . nom du paquet de fonctions a enrichir .
89 c . nbfopa . s . 1 . nombre de fonctions du paquet a enrichir .
90 c . nbtrav . es . 1 . nombre de tableaux de travail crees .
91 c . litrav . es . * . liste des noms de tableaux de travail crees.
92 c . typcha . e . 1 . edin64/edfl64 selon entier/reel .
93 c . typgeo . e . 1 . type geometrique au sens MED .
94 c . ngauss . e . 1 . nombre de points de Gauss .
95 c . nbenmx . e . 1 . nombre d'entites maximum .
96 c . nbvapr . e . 1 . nombre de valeurs du profil .
97 c . . . . -1, si pas de profil .
98 c . nbtyas . e . 1 . nombre de types de support associes .
99 c . carsup . e . 1 . caracteristiques du support .
100 c . . . . 1, si aux noeuds par element .
101 c . . . . 2, si aux points de Gauss, associe avec .
102 c . . . . n champ aux noeuds par elements .
103 c . . . . 3 si aux points de Gauss autonome .
105 c . nbtafo . e . 1 . nombre de tableaux de la fonction .
106 c . typint . e . . type interpolation .
107 c . . . . 0, si automatique .
108 c . . . . 1 si degre 1, 2 si degre 2, .
109 c . . . . 3 si iso-P2 .
110 c . lgtbix . e . 1 . nouveau nombre de types de support associes.
111 c . tbiaux . e . lgtbix . nouveaux types de support associes .
112 c . advale . s . 1 . adresse du tableau de valeurs entieres .
113 c . advalr . s . 1 . adresse du tableau de valeurs reelles .
114 c . adobch . s . 1 . adresse des noms des objets 'Champ' .
115 c . adprpg . s . 1 . adresse des noms des objets 'Profil' et .
116 c . . . . 'LocaPG' eventuellement associes .
117 c . adtyas . s . 1 . adresse des types associes .
118 c . advatt . s . 1 . adresse du tableau de travail .
119 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
120 c . langue . e . 1 . langue des messages .
121 c . . . . 1 : francais, 2 : anglais .
122 c . codret . es . 1 . code de retour des modules .
123 c . . . . 0 : pas de probleme .
124 c . . . . 1 : probleme .
125 c ______________________________________________________________________
128 c 0. declarations et dimensionnement
131 c 0.1. ==> generalites
137 parameter ( nompro = 'PCFOR1' )
155 integer carenf(nbpara,*)
158 integer typfon, typcha, typgeo, nbtyas
159 integer ngauss, nbenmx, nbvapr
160 integer carsup, nbtafo, typint
161 integer nbfopa, nbtrav
162 integer advale, advalr, adprpg, adtyas
163 integer adobch, advatt
164 integer lgtbix, tbiaux(lgtbix)
167 character*8 carchf(nbpara,*)
168 character*8 litrav(*)
171 integer ulsort, langue, codret
173 c 0.4. ==> variables locales
175 integer iaux, jaux, kaux, laux, maux
178 integer ngausa, nnenma, nnvapa, nbtyaa
179 integer carsua, nbtafa, typina
180 integer apvane, anvala, anobca, anprpa, antyaa
181 integer codre1, codre2
186 character*8 tbsaux(1)
189 parameter ( nbmess = 10 )
190 character*80 texte(nblang,nbmess)
192 c 0.5. ==> initialisations
193 c ______________________________________________________________________
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,texte(langue,1)) 'Entree', nompro
209 texte(1,4) = '(''Fonction de depart : '',a)'
210 texte(1,5) = '(''Fonction creee : '',a)'
211 texte(1,6) = '(''En retour de '',a,'', codret ='',i13)'
213 texte(2,4) = '(''Initial function : '',a)'
214 texte(2,5) = '(''Created function : '',a)'
215 texte(2,6) = '(''Back from '',a,'', codret ='',i13)'
219 #ifdef _DEBUG_HOMARD_
220 write (ulsort,texte(langue,4)) nofonc
221 write (ulsort,90002) 'option', option
223 cgn print *, 'DEBUT DE ',nompro, ' pour la fonction numero ',nrfonc
224 cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
225 cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9)
228 c 2. modification eventuelle des caracteristiques
231 if ( codret.eq.0 ) then
233 if ( option.eq.1 ) then
235 cgn write (ulsort,90002) 'typgeo initial', typgeo
236 typgeo = medt12(typgeo)
237 cgn write (ulsort,90002) 'ngauss typgeo', typgeo
239 if ( carsup.eq.1 ) then
240 cgn write (ulsort,90002) 'ngauss initial', ngauss
241 ngauss = mednnm(typgeo)
242 cgn write (ulsort,90002) 'nouveau ngauss', ngauss
247 #ifdef _DEBUG_HOMARD_
248 write (ulsort,90002) 'typgeo', typgeo
249 write (ulsort,90002) 'ngauss', ngauss
250 write (ulsort,90002) 'nbenmx', nbenmx
251 write (ulsort,90002) 'nbvapr', nbvapr
252 write (ulsort,90002) 'nbtyas', nbtyas
253 write (ulsort,90002) 'carsup', carsup
254 write (ulsort,90002) 'nbtafo', nbtafo
255 write (ulsort,90002) 'typint', typint
256 write (ulsort,90002) 'lgtbix', lgtbix
257 if ( lgtbix.gt.0 ) then
258 write (ulsort,90002) '==> ', (tbiaux(iaux),iaux=1,lgtbix)
265 c 3. allocation de la fonction
268 if ( codret.eq.0 ) then
270 #ifdef _DEBUG_HOMARD_
271 write (ulsort,texte(langue,3)) 'UTALFO', nompro
273 call utalfo ( nofon2, typcha,
274 > typgeo, ngauss, nbenmx, nbvapr, nbtyas,
275 > carsup, nbtafo, typint,
276 > advale, advalr, adobch, adprpg, adtyas,
277 > ulsort, langue, codret )
279 #ifdef _DEBUG_HOMARD_
280 if ( codret.ne.0 ) then
281 write (ulsort,texte(langue,6)) 'utalfo', codret
283 write (ulsort,texte(langue,5)) nofon2
284 call gmprsx (nompro, nofon2 )
289 if ( codret.eq.0 ) then
291 carenf( 1,nrfonc) = typfon
292 carenf( 2,nrfonc) = typcha
293 carenf( 3,nrfonc) = typgeo
294 carenf( 4,nrfonc) = nbtyas
295 carenf( 5,nrfonc) = ngauss
296 carenf( 6,nrfonc) = 0
297 carenf( 7,nrfonc) = nbvapr
298 carenf( 8,nrfonc) = carsup
299 carenf( 9,nrfonc) = nbtafo
300 carenf(15,nrfonc) = nbenmx
301 carenf(16,nrfonc) = nbvapr
302 carenf(17,nrfonc) = advale
303 carenf(18,nrfonc) = advalr
304 carenf(19,nrfonc) = adobch
305 carenf(20,nrfonc) = adprpg
306 carenf(23,nrfonc) = adtyas
308 carchf( 1,nrfonc) = nofon2
313 c 4. caracteristiques des supports associes
315 #ifdef _DEBUG_HOMARD_
316 write (ulsort,*) '4. supports associes ; codret = ', codret
319 c 4.1. ==> S'il n'y a pas d'ajout de fonction pour la conformite,
320 c lgtbix vaut nbtyas.
321 c Donc si on avait deja des supports (nbtyas>0), il faut
322 c recopier le tableau.
324 if ( lgtbix.eq.nbtyas ) then
326 if ( nbtyas.gt.0 ) then
328 if ( codret.eq.0 ) then
330 #ifdef _DEBUG_HOMARD_
331 write (ulsort,*) 'Copie de', nofonc//'.TypeSuAs',
332 > ' vers', nofon2//'.TypeSuAs'
334 call gmcpgp ( nofonc//'.TypeSuAs',
335 > nofon2//'.TypeSuAs', codret )
341 c 4.2. ==> S'il y a de nouveau support, lgtbix est different de nbtyas.
342 c Il faut creer la liste des supports.
346 if ( lgtbix.gt.0 ) then
348 c 4.2.1. ==> On commence par detruire le tableau s'il existait
350 if ( codret.eq.0 ) then
351 if ( nbtyas.gt.0 ) then
352 #ifdef _DEBUG_HOMARD_
353 write (ulsort,*) 'Destruction de', nofon2//'.TypeSuAs'
355 call gmlboj( nofon2//'.TypeSuAs', codret )
359 c 4.2.2. ==> Allocation du tableau et mise a jour de l'attribut
361 if ( codret.eq.0 ) then
362 #ifdef _DEBUG_HOMARD_
363 write (ulsort,*) 'Allocation de', nofon2//'.TypeSuAs'
366 call gmaloj ( nofon2//'.TypeSuAs', ' ',
367 > iaux, adtyas, codre1 )
368 call gmecat ( nofon2, 5, iaux, codre2 )
370 codre0 = min ( codre1, codre2 )
371 codret = max ( abs(codre0), codret,
377 if ( codret.eq.0 ) then
379 carenf( 4,nrfonc) = lgtbix - 1
380 carenf(23,nrfonc) = adtyas
383 do 423 , iaux = 1 , lgtbix
384 if ( tbiaux(iaux).ne.typgeo ) then
386 imem(jaux) = tbiaux(iaux)
396 #ifdef _DEBUG_HOMARD_
397 call gmprsx ( nompro, nofon2 )
398 call gmprsx ( nompro, nofon2//'.TypeSuAs' )
402 c 5. copie des caracteristiques du champ
405 #ifdef _DEBUG_HOMARD_
406 write (ulsort,*) '5. champ ; codret = ', codret
409 if ( codret.eq.0 ) then
411 call gmcpgp ( nofonc//'.InfoCham',
412 > nofon2//'.InfoCham', codret )
417 c 6. dans le cas de support element, creation d'un tableau de
418 c travail pour gerer la renumerotation
421 #ifdef _DEBUG_HOMARD_
422 write (ulsort,*) '6. support element ; codret = ', codret
425 if ( typgeo.ne.0 ) then
429 if ( codret.eq.0 ) then
431 iaux = nbtafo * rseutc
433 if ( ngauss.ne.ednopg ) then
439 c 6.2. ==> Allocation
441 if ( codret.eq.0 ) then
442 cgn write (ulsort,90002) 'allocation a la taille', iaux
444 call gmalot ( saux08, 'reel ', iaux, advatt, codret )
445 cgn write (ulsort,90003) 'allocation de', saux08
451 if ( codret.eq.0 ) then
454 litrav(nbtrav) = saux08
455 cgn print *,nompro,' 2.3 nbtrav = ', nbtrav
456 cgn print *,'litrav(',nbtrav,') = ',saux08
457 cgn carenf( 5,nrfonc) = ngauss
458 carenf(21,nrfonc) = advatt
465 c 7. dans le cas d'un champ aux points de Gauss avec un champ aux
466 c noeuds par elements associe, reperage de la fonction associee
469 #ifdef _DEBUG_HOMARD_
470 write (ulsort,*) '7. support Gauss ; codret = ', codret
473 if ( carsup.eq.2 ) then
475 if ( codret.eq.0 ) then
477 saux08 = carchf(9,nrfonc)
478 cgn call gmprsx (nompro,saux08)
479 cgn call gmprsx (nompro,saux08//'.ValeursR')
481 #ifdef _DEBUG_HOMARD_
482 write (ulsort,texte(langue,3)) 'UTCAFO', nompro
484 call utcafo ( saux08,
486 > typgeo, ngausa, nnenma, nnvapa, nbtyaa,
487 > carsua, nbtafa, typina,
488 > anvala, apvane, anobca, anprpa, antyaa,
489 > ulsort, langue, codret )
491 carenf(22,nrfonc) = apvane
492 cgn print *,'apvane = ',apvane
499 c 8. ajout de la fonction au paquet de sortie
502 #ifdef _DEBUG_HOMARD_
503 write (ulsort,*) '8. ajout ; codret = ', codret
506 if ( codret.eq.0 ) then
508 #ifdef _DEBUG_HOMARD_
509 write (ulsort,texte(langue,3)) 'UTMOPF', nompro
512 call utmopf ( nopafo, iaux,
513 > iaux, tbsaux, tbiaux,
515 > nbfopa, jaux, kaux, laux, maux,
517 > ulsort, langue, codret )
521 #ifdef _DEBUG_HOMARD_
522 call gmprsx (nompro, nopafo )
523 call gmprsx (nompro, nopafo//'.Fonction' )
524 call gmprsx (nompro, nofon2//'.ValeursR' )
525 call gmprsx (nompro, nofon2//'.InfoPrPG' )
532 cgn print *, 'FIN DE ',nompro, ' pour la fonction numero ',nrfonc
533 cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
534 cgn 1788 format(10I8)
535 cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9)
536 cgn 1789 format(10(a8,1x))
539 if ( codret.ne.0 ) then
543 write (ulsort,texte(langue,1)) 'Sortie', nompro
544 write (ulsort,texte(langue,2)) codret
548 #ifdef _DEBUG_HOMARD_
549 write (ulsort,texte(langue,1)) 'Sortie', nompro