1 subroutine pccapf ( nppafo, npfopa, nbcham, nocham,
2 > nbpara, carenf, carchf,
4 > ulsort, langue, codret )
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c aPres adaptation - mise a jour des CAracteristiques
27 c des Paquets de Fonctions
29 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . nppafo . e . 1 . nom du paquet de fonctions iteration p .
34 c . npfopa . e . 1 . nombre de fonctions a traiter .
35 c . nbcham . e . 1 . nombre de champs .
36 c . nocham . es . nbcham . nom des objets qui contiennent la .
37 c . . . . description de chaque champ .
38 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
39 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
40 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
41 c . . . . 1, pour une ancienne associee a une .
42 c . . . . autre fonction .
43 c . . . . -1, pour une nouvelle fonction .
44 c . . . . 2 : typcha .
45 c . . . . 3 : typgeo .
46 c . . . . 4 : typass .
47 c . . . . 5 : ngauss .
48 c . . . . 6 : nnenmx .
49 c . . . . 7 : nnvapr .
50 c . . . . 8 : carsup .
51 c . . . . 9 : nbtafo .
52 c . . . . 10 : anvale .
53 c . . . . 11 : anvalr .
54 c . . . . 12 : anobch .
55 c . . . . 13 : adprpg .
56 c . . . . 14 : anlipr .
57 c . . . . 15 : npenmx .
58 c . . . . 16 : npvapr .
59 c . . . . 17 : apvale .
60 c . . . . 18 : apvalr .
61 c . . . . 19 : apobch .
62 c . . . . 20 : apprpg .
63 c . . . . 21 : apvatt .
64 c . . . . 22 : apvane .
65 c . . . . 23 : antyas .
66 c . . . . 24 : aptyas .
67 c . . . . 25 : numero de la 1ere fonction associee .
68 c . . . . 26 : numero de la 2nde fonction associee .
69 c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
70 c . . . nnfopa. 1 : nom de la fonction .
71 c . . . . 2 : nom de la fonction n associee .
72 c . . . . 3 : nom de la fonction p associee .
73 c . . . . 4 : obpcan .
74 c . . . . 5 : obpcap .
75 c . . . . 6 : obprof .
76 c . . . . 7 : oblopg .
77 c . . . . 8 : si aux points de Gauss, nom de la .
78 c . . . . fonction n ELNO correspondante .
79 c . . . . 9 : si aux points de Gauss, nom de la .
80 c . . . . fonction p ELNO correspondante .
81 c . option . e . 1 . option du traitement .
82 c . . . . -1 : Pas de changement dans le maillage .
83 c . . . . 0 : Adaptation complete .
84 c . . . . 1 : Modification de degre .
85 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
86 c . langue . e . 1 . langue des messages .
87 c . . . . 1 : francais, 2 : anglais .
88 c . codret . es . 1 . code de retour des modules .
89 c . . . . 0 : pas de probleme .
90 c . . . . 1 : probleme .
91 c ______________________________________________________________________
94 c 0. declarations et dimensionnement
97 c 0.1. ==> generalites
103 parameter ( nompro = 'PCCAPF' )
114 integer npfopa, nbcham
115 integer carenf(nbpara,*)
119 character*8 nocham(nbcham)
120 character*8 carchf(nbpara,*)
122 integer ulsort, langue, codret
124 c 0.4. ==> variables locales
130 integer typgpf, ngauss, carsup, typint
134 character*8 npfonc, opprof, oplopg
136 character*8 tbsaux(1)
139 parameter ( nbmess = 20 )
140 character*80 texte(nblang,nbmess)
142 c 0.5. ==> initialisations
143 c ______________________________________________________________________
151 #ifdef _DEBUG_HOMARD_
152 write (ulsort,texte(langue,1)) 'Entree', nompro
157 > '(''Nom de la fonction '',a,'' numero'',i3,'' : '',a8)'
158 texte(1,5) = '(''... Nom du profil = '',a8)'
159 texte(1,6) = '(''... fonction nouvelle'')'
160 texte(1,7) = '(''... fonction ancienne isolee'')'
161 texte(1,8) = '(''... fonction ancienne associee a une autre'')'
162 texte(1,9) = '(''Suppression de la fonction '',a)'
163 texte(1,10) = '(''... '',a,'' : '',i6)'
165 > '(''Remplacement du nom de la fonction dans le paquet :'')'
166 texte(1,12) = '(3x,a,'' devient '',a)'
168 > '(''Ajout du nom de la fonction '',a,'' dans le paquet'')'
169 texte(1,20) = '(''Nombre de fonctions dans le paquet :'',i4)'
171 texte(2,4) = '(''Name of the function '',a,'' #'',i3,'' : '',a8)'
172 texte(2,5) = '(''... Name of the profile = '',a8)'
173 texte(2,6) = '(''... new function'')'
174 texte(2,7) = '(''... old lonesome function'')'
175 texte(2,8) = '(''... old function connected to another one'')'
176 texte(2,9) = '(''Deleting of the function '',a)'
177 texte(2,10) = '(''... '',a,'' : '',i6)'
178 texte(2,11) = '(''Change of function name in the pack'')'
179 texte(2,12) = '(3x,a,'' becomes '',a)'
181 > '(''Addition of function name '',a,'' to the pack'')'
182 texte(2,20) = '(''Number of functions in the pack :'',i4)'
186 #ifdef _DEBUG_HOMARD_
187 write (ulsort,texte(langue,20)) npfopa
188 write (ulsort,90002) 'option', option
192 c 2. mise a jour des caracteristiques des fonctions
195 do 20 , nrfonc = 1 , npfopa
197 c 2.1. ==> mise a jour des caracteristiques des fonctions
199 if ( codret.eq.0 ) then
201 cgn write (ulsort,texte(langue,10)), 'nrfonc', nrfonc
202 cgn write (ulsort,91010) (carenf(iaux,nrfonc),iaux=1,nbpara)
203 cgn write (ulsort,93010) (carchf(iaux,nrfonc),iaux=1,nbpara)
206 #ifdef _DEBUG_HOMARD_
207 write (ulsort,texte(langue,3)) 'PCCAFO', nompro
209 call pccafo ( iaux, npfonc, opprof, oplopg,
210 > nbpara, carenf, carchf,
212 > ulsort, langue, codret )
216 #ifdef _DEBUG_HOMARD_
218 write (ulsort,texte(langue,4)) 'p', nrfonc, npfonc
219 write (ulsort,texte(langue,5)) opprof
220 call gmprsx (nompro,npfonc)
221 call gmprot (nompro,npfonc//'.ValeursR',1,20)
222 cgn call gmprsx (nompro,npfonc//'.InfoPrPG')
225 c 2.2. ==> mise a jour des caracteristiques des champs
226 #ifdef _DEBUG_HOMARD_
227 write (ulsort,*) '2.2. mise a jour ; codret =', codret
230 iaux = carenf(1,nrfonc)
232 #ifdef _DEBUG_HOMARD_
233 write (ulsort,texte(langue,7+iaux))
236 c 2.2.1. ==> remplacement quand la fonction existait deja
238 if ( iaux.ge.0 ) then
240 if ( codret.eq.0 ) then
242 nnfonc = carchf( 2,nrfonc)
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,texte(langue,4)) 'n', nrfonc, nnfonc
245 write (ulsort,texte(langue,11))
246 write (ulsort,texte(langue,12)) nnfonc, npfonc
247 cgn call gmprsx (nompro,nnfonc)
248 cgn call gmprsx (nompro,nnfonc//'.InfoPrPG')
249 write (ulsort,texte(langue,3)) 'PCCAC1', nompro
251 call pccac1 ( nbcham, nocham,
252 > nnfonc, npfonc, opprof, oplopg,
253 > ulsort, langue, codret )
257 c 2.2.2. ==> ajout sinon
261 if ( codret.eq.0 ) then
263 nnfonc = carchf( 3,nrfonc)
265 #ifdef _DEBUG_HOMARD_
266 write (ulsort,texte(langue,4)) 'n', nrfonc, nnfonc
267 write (ulsort,texte(langue,13)) npfonc
268 write (ulsort,texte(langue,3)) 'PCCAC2', nompro
270 call pccac2 ( npfonc, nnfonc,
271 > ulsort, langue, codret )
280 c 3. suppression des anciennes fonctions
281 c attention a ne le faire qu'a ce moment, car le nom connu peut
282 c etre le meme pour plusieurs fonctions p dans le cas de conformite.
283 c Si on le faisait dans la boucle 20, on perdrait tout !
285 #ifdef _DEBUG_HOMARD_
286 write (ulsort,*) '3. suppression ; codret =', codret
289 do 30 , nrfonc = 1 , npfopa
291 if ( codret.eq.0 ) then
293 iaux = carenf(1,nrfonc)
295 if ( iaux.eq.0 ) then
297 nnfonc = carchf( 2,nrfonc)
299 #ifdef _DEBUG_HOMARD_
300 write (ulsort,texte(langue,9)) nnfonc
303 call gmobal ( nnfonc, jaux )
305 if ( jaux.eq.1 ) then
306 call gmsgoj ( nnfonc , codret )
307 elseif ( jaux.ne.0 ) then
318 c 4. degre du type geometrique
321 if ( option.eq.1 ) then
323 if ( codret.eq.0 ) then
325 #ifdef _DEBUG_HOMARD_
326 write (ulsort,texte(langue,3)) 'UTMOPF', nompro
329 call utmopf ( nppafo, iaux,
330 > jaux, tbsaux, tbiaux,
332 > npfopa, typgpf, ngauss, carsup, typint,
334 > ulsort, langue, codret )
344 if ( codret.ne.0 ) then
348 write (ulsort,texte(langue,1)) 'Sortie', nompro
349 write (ulsort,texte(langue,2)) codret
353 #ifdef _DEBUG_HOMARD_
354 write (ulsort,texte(langue,1)) 'Sortie', nompro