1 subroutine pccapr ( npfopa, npprof, liprof,
2 > nbpara, carenf, carach,
3 > ulsort, langue, codret )
4 c ______________________________________________________________________
8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
11 c aupres des huissiers de justice Simart et Lavoir a Clamart
12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
13 c aupres des huissiers de justice
14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
16 c HOMARD est une marque deposee d'Electricite de France
22 c ______________________________________________________________________
24 c aPres adaptation - mise a jour des CAracteristiques
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . npfopa . e . 1 . nombre de fonctions a traiter .
33 c . npprof . es . 1 . nombre de profils en sortie enregistres .
34 c . liprof . es . char*8 . nom des objets de type 'Profil' enregistres.
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 : adprpg .
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 . ulsort . e . 1 . numero d'unite logique de la liste standard.
79 c . langue . e . 1 . langue des messages .
80 c . . . . 1 : francais, 2 : anglais .
81 c . codret . es . 1 . code de retour des modules .
82 c . . . . 0 : pas de probleme .
83 c . . . . 1 : probleme .
84 c ______________________________________________________________________
87 c 0. declarations et dimensionnement
90 c 0.1. ==> generalites
96 parameter ( nompro = 'PCCAPR' )
113 integer npfopa, npprof
115 integer carenf(nbpara,*)
117 character*8 liprof(*)
118 character*8 carach(nbpara,*)
120 integer ulsort, langue, codret
122 c 0.4. ==> variables locales
127 integer rsenac, adpcap
129 integer nnvapr, npvapr
131 character*8 obpcap, opprof
134 parameter ( nbmess = 10 )
135 character*80 texte(nblang,nbmess)
137 c 0.5. ==> initialisations
138 c ______________________________________________________________________
148 #ifdef _DEBUG_HOMARD_
149 write (ulsort,texte(langue,1)) 'Entree', nompro
153 texte(1,4) = '(''Nom de l''''objet profil etape n = '',a8)'
155 texte(2,4) = '(''Name of the profile object #n: '',a8)'
160 c 2. mise a jour des caracteristiques des profils
163 do 20 , nrfonc = 1 , npfopa
165 if ( codret.eq.0 ) then
167 nnvapr = carenf(7,nrfonc)
169 #ifdef _DEBUG_HOMARD_
170 write (ulsort,*) '============================'
171 write (ulsort,90002) 'nnvapr', nnvapr
176 c 2.1. ==> creation du profil eventuel
178 c 2.1.1. ==> recuperation des informations
180 if ( nnvapr.gt.0 ) then
182 if ( codret.eq.0 ) then
184 obpcap = carach( 5,nrfonc)
186 #ifdef _DEBUG_HOMARD_
187 write (ulsort,texte(langue,4)) obpcap
188 cgn call gmprsx (nompro, obpcap )
190 call gmadoj ( obpcap, adpcap, iaux, codret )
194 if ( codret.eq.0 ) then
196 typgeo = carenf( 3,nrfonc)
198 #ifdef _DEBUG_HOMARD_
199 write (ulsort,90002) 'typgeo', typgeo
202 c Par convention HOMARD, les mailles sont rangees ainsi :
206 c . les mailles-points
212 if ( typgeo.eq.0 ) then
216 elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
220 elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
224 elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
227 jaux = nbtetr + nbtria
228 elseif ( typgeo.eq.edpoi1 ) then
231 jaux = nbtetr + nbtria + nbsegm
232 elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
235 jaux = nbtetr + nbtria + nbsegm + nbmapo
236 elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then
239 jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad
240 elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then
243 jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
244 elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then
247 jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
255 #ifdef _DEBUG_HOMARD_
256 write (ulsort,90002) 'rsenac', rsenac
257 write (ulsort,90002) 'iaux ', iaux
258 write (ulsort,90002) 'jaux ', jaux
261 c 2.1.2. ==> creation du profil
263 if ( codret.eq.0 ) then
265 #ifdef _DEBUG_HOMARD_
266 write (ulsort,texte(langue,3)) 'UTPR01', nompro
268 call utpr01 ( iaux, jaux,
269 > rsenac, imem(adpcap), imem(iaux),
272 > ulsort, langue, codret )
275 #ifdef _DEBUG_HOMARD_
276 call gmprsx (nompro,opprof)
277 call gmprsx (nompro,opprof//'.ListEnti')
282 c 2.2. ==> sans profil
292 c 2.3. ==> archivages
294 if ( codret.eq.0 ) then
296 #ifdef _DEBUG_HOMARD_
297 write (ulsort,90002) 'npvapr', npvapr
299 carenf(16,nrfonc) = npvapr
300 carach( 6,nrfonc) = opprof
311 if ( codret.ne.0 ) then
315 write (ulsort,texte(langue,1)) 'Sortie', nompro
316 write (ulsort,texte(langue,2)) codret
320 #ifdef _DEBUG_HOMARD_
321 write (ulsort,texte(langue,1)) 'Sortie', nompro