1 subroutine pccafo ( nrfonc, nofonc, obprof, oblopg,
2 > nbpara, carenf, carach,
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 des FOnctions
27 c ______________________________________________________________________
29 c . nom . e/s . taille . description .
30 c .____________________________________________________________________.
31 c . nrfonc . e . 1 . numero de la fonction a examiner .
32 c . nofonc . s . char8 . nom de la fonction iteration n+1 .
33 c . obprof . s . char8 . nom de l'objet profil eventuel .
34 c . oblopg . s . char8 . nom de l'objet localisation points de Gauss.
35 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
36 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
37 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
38 c . . . . 1, pour une ancienne associee a une .
39 c . . . . autre fonction .
40 c . . . . -1, pour une nouvelle fonction .
41 c . . . . 2 : typcha .
42 c . . . . 3 : typgeo .
43 c . . . . 4 : typass .
44 c . . . . 5 : ngauss .
45 c . . . . 6 : nnenmx .
46 c . . . . 7 : nnvapr .
47 c . . . . 8 : carsup .
48 c . . . . 9 : nbtafo .
49 c . . . . 10 : anvale .
50 c . . . . 11 : anvalr .
51 c . . . . 12 : anobch .
52 c . . . . 13 : anprpg .
53 c . . . . 14 : anlipr .
54 c . . . . 15 : npenmx .
55 c . . . . 16 : npvapr .
56 c . . . . 17 : apvale .
57 c . . . . 18 : apvalr .
58 c . . . . 19 : apobch .
59 c . . . . 20 : apprpg .
60 c . . . . 21 : apvatt .
61 c . . . . 22 : apvane .
62 c . . . . 23 : antyas .
63 c . . . . 24 : aptyas .
64 c . . . . 25 : numero de la 1ere fonction associee .
65 c . . . . 26 : numero de la 2nde fonction associee .
66 c . carach . es .nbpara* . caracteristiques caracteres des fonctions :.
67 c . . . nnfopa. 1 : nom de la fonction .
68 c . . . . 2 : nom de la fonction n associee .
69 c . . . . 3 : nom de la fonction p associee .
70 c . . . . 4 : obpcan .
71 c . . . . 5 : obpcap .
72 c . . . . 6 : obprof .
73 c . . . . 7 : oblopg .
74 c . . . . 8 : si aux points de Gauss, nom de la .
75 c . . . . fonction n ELNO correspondante .
76 c . . . . 9 : si aux points de Gauss, nom de la .
77 c . . . . fonction p ELNO correspondante .
78 c . option . e . 1 . option du traitement .
79 c . . . . -1 : Pas de changement dans le maillage .
80 c . . . . 0 : Adaptation complete .
81 c . . . . 1 : Modification de degre .
82 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
83 c . langue . e . 1 . langue des messages .
84 c . . . . 1 : francais, 2 : anglais .
85 c . codret . es . 1 . code de retour des modules .
86 c . . . . 0 : pas de probleme .
87 c . . . . 1 : probleme .
88 c ______________________________________________________________________
91 c 0. declarations et dimensionnement
94 c 0.1. ==> generalites
100 parameter ( nompro = 'PCCAFO' )
120 integer carenf(nbpara,*)
123 character*8 nofonc, obprof, oblopg
124 character*8 carach(nbpara,*)
126 integer ulsort, langue, codret
128 c 0.4. ==> variables locales
131 integer typfon, typcha, typgeo, typass
132 integer ngauss, nnenmx, nnvapr, carsup, nbtafo
133 integer n1vale, n1valr, n1prpg, n1obch, n1lipr
134 integer npenmx, npvapr
135 integer p1vale, p1valr, p1prpg, p1obch, p1vatt
136 integer p1vane, p1tyas
137 integer adpcan, adpcap
138 integer nrfon2, nrfon3
141 character*8 obpcan, obpcap
145 parameter ( nbmess = 10 )
146 character*80 texte(nblang,nbmess)
148 c 0.5. ==> initialisations
149 c ______________________________________________________________________
160 #ifdef _DEBUG_HOMARD_
161 write (ulsort,texte(langue,1)) 'Entree', nompro
165 texte(1,4) = '(''.. Fonction numero '',i6)'
166 texte(1,5) = '(''Nom de la fonction = '',a8)'
168 texte(2,4) = '(''.. Function #'',i6)'
169 texte(2,5) = '(''Name of the function ='',a8)'
171 #ifdef _DEBUG_HOMARD_
172 write (ulsort,texte(langue,4)) nrfonc
173 write (ulsort,90002) 'option', option
176 cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
178 cgn print 1789,(carach(iaux,nrfonc),iaux=1,nbpara)
179 cgn 1789 format(5(a8,1x))
182 c 2. caracteristiques de la fonction
185 #ifdef _DEBUG_HOMARD_
186 write (ulsort,texte(langue,3)) 'PCFOR2', nompro
189 call pcfor2 ( nbpara, carenf, carach,
191 > typfon, typcha, typgeo, typass,
192 > ngauss, nnenmx, nnvapr, carsup, nbtafo,
193 > n1vale, n1valr, n1prpg, n1obch, n1lipr,
195 > p1vale, p1valr, p1prpg, p1obch, p1vatt,
199 > obpcan, obpcap, obprof, adpcan, adpcap,
201 > ulsort, langue, codret )
203 #ifdef _DEBUG_HOMARD_
204 write (ulsort,texte(langue,5)) nofonc
208 c 3. mise a jour des informations
211 c 3.1. ==> nombre de valeurs du profil
213 if ( codret.eq.0 ) then
215 call gmecat ( nofonc, 4, npvapr, codret )
221 if ( codret.eq.0 ) then
223 smem(p1prpg ) = obprof
224 smem(p1prpg+1) = oblopg
228 c 3.3. ==> changement de degre
230 if ( option.eq.1 ) then
232 c 3.3.1. ==> le champ associe a la fonction
233 c remarque : on aurait pu modifier utmoch
235 do 332 , iaux = 1 , nbtafo
237 if ( codret.eq.0 ) then
239 obinch = smem(n1obch-1+iaux)
240 call gmadoj ( obinch//'.Cham_Ent', adinch, jaux, codret )
244 if ( codret.eq.0 ) then
246 imem(adinch ) = carenf(3,nrfonc)
247 imem(adinch+3) = carenf(5,nrfonc)
256 c 4. compactage des valeurs pour les fonctions sur les elements
257 c remarque : le traitement sur les fonctions aux noeuds est
258 c different. Il est fait directement dans pcsono.
261 if ( codret.eq.0 ) then
263 cgn print *,'p1vatt = ',p1vatt
264 cgn print *,'rmem(p1vatt+13) = ',rmem(p1vatt+13)
266 if ( typgeo.ne.0 ) then
268 if ( ngauss.eq.ednopg ) then
270 #ifdef _DEBUG_HOMARD_
271 write (ulsort,texte(langue,3)) 'UTSRC1', nompro
273 call utsrc1 ( nbtafo, rseutc,
274 > imem(adpcap), rmem(p1vatt), rmem(p1valr) )
278 #ifdef _DEBUG_HOMARD_
279 write (ulsort,texte(langue,3)) 'UTSRC2', nompro
281 call utsrc2 ( nbtafo, ngauss, rseutc,
282 > imem(adpcap), rmem(p1vatt), rmem(p1valr) )
286 cgn print *,nompro,' ==> codret = ',codret
287 cgn print 1790,(rmem(p1valr+iaux-1),iaux=1,nbtafo*rsevca)
288 cgn 1790 format(10g13.5)
294 #ifdef _DEBUG_HOMARD_
295 call gmprsx (nompro,nofonc)
296 call gmprsx (nompro,nofonc//'.ValeursR')
297 call gmprsx (nompro,nofonc//'.InfoPrPG')
298 if ( npvapr.gt.0 ) then
299 call gmprsx (nompro,obprof)
301 if ( oblopg.ne.blan08 ) then
302 call gmprsx (nompro,oblopg)
310 if ( codret.ne.0 ) then
314 write (ulsort,texte(langue,1)) 'Sortie', nompro
315 write (ulsort,texte(langue,2)) codret
319 #ifdef _DEBUG_HOMARD_
320 write (ulsort,texte(langue,1)) 'Sortie', nompro