1 subroutine pcsohe ( typint, deraff,
2 > nbpara, carenf, carchf, nrfonc,
7 > tritet, cotrte, aretet,
8 > quahex, coquhe, arehex,
9 > facpyr, cofapy, arepyr,
10 > hethex, anchex, filhex, fhpyte,
11 > nbanhe, anfihe, anhehe, anpthe,
15 > ulsort, langue, codret )
16 c ______________________________________________________________________
20 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
22 c Version originale enregistree le 18 juin 1996 sous le numero 96036
23 c aupres des huissiers de justice Simart et Lavoir a Clamart
24 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
25 c aupres des huissiers de justice
26 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
28 c HOMARD est une marque deposee d'Electricite de France
34 c ______________________________________________________________________
36 c aPres adaptation - Conversion de Solution - HExaedres
38 c ______________________________________________________________________
40 c . nom . e/s . taille . description .
41 c .____________________________________________________________________.
42 c . typint . e . 1 . type d'interpolation .
43 c . . . . 0, si automatique .
44 c . . . . elements : 0 si intensif, sans orientation.
45 c . . . . 1 si extensif, sans orientation.
46 c . . . . 2 si intensif, avec orientation.
47 c . . . . 3 si extensif, avec orientation.
48 c . . . . noeuds : 1 si degre 1 .
49 c . . . . 2 si degre 2 .
50 c . . . . 3 si iso-P2 .
51 c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en .
52 c . . . . passant de l'iteration n a n+1 ; faux sinon.
53 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
54 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
55 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
56 c . . . . 1, pour une ancienne associee a une .
57 c . . . . autre fonction .
58 c . . . . -1, pour une nouvelle fonction .
59 c . . . . 2 : typcha .
60 c . . . . 3 : typgeo .
61 c . . . . 4 : nbtyas .
62 c . . . . 5 : ngauss .
63 c . . . . 6 : nnenmx .
64 c . . . . 7 : n1vapr .
65 c . . . . 8 : carsup .
66 c . . . . 9 : nbtafo .
67 c . . . . 10 : anvale .
68 c . . . . 11 : anvalr .
69 c . . . . 12 : anobch .
70 c . . . . 13 : anprpg .
71 c . . . . 14 : anlipr .
72 c . . . . 15 : npenm1 .
73 c . . . . 16 : npvap1 .
74 c . . . . 17 : apvale .
75 c . . . . 18 : apvalr .
76 c . . . . 19 : apobch .
77 c . . . . 20 : apprpg .
78 c . . . . 21 : apvatt .
79 c . . . . 22 : apvane .
80 c . . . . 23 : antyas .
81 c . . . . 24 : aptyas .
82 c . . . . 25 : numero de la 1ere fonction associee .
83 c . . . . 26 : numero de la 2nde fonction associee .
84 c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
85 c . . . nnfopa. 1 : nom de la fonction .
86 c . . . . 2 : nom de la fonction n associee .
87 c . . . . 3 : nom de la fonction p associee .
88 c . . . . 4 : obpc1n .
89 c . . . . 5 : obpc1p .
90 c . . . . 6 : obpro1 .
91 c . . . . 7 : oblo1g .
92 c . . . . 8 : si aux points de Gauss, nom de la .
93 c . . . . fonction n ELNO correspondante .
94 c . . . . 9 : si aux points de Gauss, nom de la .
95 c . . . . fonction p ELNO correspondante .
96 c . nrfonc . e . 1 . numero de la fonction principale .
97 c . coonoe . e . nbnoto . coordonnees des noeuds .
99 c . somare . e .2*nbarto. numeros des extremites d'arete .
100 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
101 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
102 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
103 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
104 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
105 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
106 c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres .
107 c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres .
108 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
109 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
110 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
111 c . hethex . e . nbheto . historique de l'etat des hexaedres .
112 c . filhex . e . nbheto . premier fils des hexaedres .
113 c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide .
114 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
115 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
116 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
117 c . nbanhe . e . 1 . nombre de hexaedres decoupes par .
118 c . . . . conformite sur le maillage avant adaptation.
119 c . anfihe . e . nbanhe . tableau filhex du maillage de l'iteration n.
120 c . anhehe . e . nbanhe . tableau hethex du maillage de l'iteration n.
121 c . anpthe . e . 2** . tableau fhpyte du maillage de l'iteration n.
122 c . nheeca . e . * . numero des hexaedres dans le calcul entree .
123 c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie .
124 c . nteeca . e . * . numero des tetraedres dans le calcul entree.
125 c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie.
126 c . npyeca . e . * . numero des pyramides dans le calcul entree .
127 c . npysca . e . rspyto . numero des pyramides dans le calcul sortie .
128 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
129 c . langue . e . 1 . langue des messages .
130 c . . . . 1 : francais, 2 : anglais .
131 c . codret . es . 1 . code de retour des modules .
132 c . . . . 0 : pas de probleme .
133 c . . . . 1 : probleme .
134 c ______________________________________________________________________
137 c 0. declarations et dimensionnement
140 c 0.1. ==> generalites
146 parameter ( nompro = 'PCSOHE' )
175 integer carenf(nbpara,*)
178 integer somare(2,nbarto)
179 integer aretri(nbtrto,3)
180 integer arequa(nbquto,4)
181 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
182 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
183 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
185 integer hethex(nbheto), anchex(*)
186 integer filhex(nbheto), fhpyte(2,nbheco)
187 integer nbanhe, anfihe(nbanhe), anhehe(nbanhe), anpthe(2,*)
189 integer nheeca(reheto), nhesca(rsheto)
190 integer nteeca(reteto), ntesca(rsteto)
191 integer npyeca(repyto), npysca(rspyto)
193 double precision coonoe(nbnoto,sdim)
195 character*8 carchf(nbpara,*)
199 integer ulsort, langue, codret
201 c 0.4. ==> variables locales
205 integer typfon, typcha, typgeo, nbtyas
206 integer ngauss, nnenmx, n1vapr, carsup, nbtafo
207 integer n1vale, n1valr, n1obpr, n1obch, n1lipr
208 integer npenm1, npvap1
209 integer p1vale, p1valr, p1obpr, p1obch, p1vatt
210 integer p1vane, p1tyas
213 integer typfo2, typch2, typge2, typas2
214 integer ngaus2, nnenm2, nnvap2, carsu2, nbtaf2
215 integer n2vale, n2valr, n2obpr, n2obch, n2lipr
216 integer npenm2, npvap2
217 integer p2vale, p2valr, p2obpr, p2obch, p2vatt
218 integer p2vane, p2tyas
221 integer typfo3, typch3, typge3, typas3
222 integer ngaus3, nnenm3, nnvap3, carsu3, nbtaf3
223 integer n3vale, n3valr, n3obpr, n3obch, n3lipr
224 integer npenm3, npvap3
225 integer p3vale, p3valr, p3obpr, p3obch, p3vatt
226 integer p3vane, p3tyas
228 integer adpc1n, adpc1p
229 integer adpc2n, adpc2p
230 integer adpc3n, adpc3p
232 character*8 nofon1, obpc1n, obpc1p, obpro1, oblo1g
233 character*8 nofon2, obpc2n, obpc2p, obpro2, oblo2g
234 character*8 nofon3, obpc3n, obpc3p, obpro3, oblo3g
237 parameter ( nbmess = 10 )
238 character*80 texte(nblang,nbmess)
240 c 0.5. ==> initialisations
241 c ______________________________________________________________________
249 #ifdef _DEBUG_HOMARD_
250 write (ulsort,texte(langue,1)) 'Entree', nompro
257 #ifdef _DEBUG_HOMARD_
258 write (ulsort,texte(langue,4)) nrfonc
262 c 2. grandeurs utiles
265 c 2.1. ==> la fonction de base
267 if ( codret.eq.0 ) then
268 #ifdef _DEBUG_HOMARD_
269 write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux= 1,10)
270 write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=11,20)
271 write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=21,nbpara)
272 write(ulsort,90003) 'carchf',(carchf(iaux,nrfonc),iaux= 1,9)
275 #ifdef _DEBUG_HOMARD_
276 write (ulsort,texte(langue,3)) 'PCFOR2', nompro
279 call pcfor2 ( nbpara, carenf, carchf,
281 > typfon, typcha, typgeo, nbtyas,
282 > ngauss, nnenmx, n1vapr, carsup, nbtafo,
283 > n1vale, n1valr, n1obpr, n1obch, n1lipr,
285 > p1vale, p1valr, p1obpr, p1obch, p1vatt,
289 > obpc1n, obpc1p, obpro1, adpc1n, adpc1p,
291 > ulsort, langue, codret )
295 #ifdef _DEBUG_HOMARD_
296 if ( codret.eq.0 ) then
297 write (ulsort,90003) 'nofon1', nofon1
298 write (ulsort,90002) 'typfon', typfon
299 write (ulsort,90002) 'typcha', typcha
300 write (ulsort,90002) 'typgeo', typgeo
301 write (ulsort,90002) 'nbtyas', nbtyas
302 write (ulsort,90002) 'carsup', carsup
303 write (ulsort,90002) 'nbtafo', nbtafo
304 write (ulsort,90002) 'ngauss', ngauss
305 write (ulsort,90002) 'nrfon2', nrfon2
306 write (ulsort,90002) 'nrfon3', nrfon3
307 write (ulsort,90003) 'oblo1g', oblo1g
311 c 2.2. ==> les fonctions annexes
312 c 2.2.1. ==> tetraedres
314 if ( nrfon2.gt.0 ) then
316 if ( codret.eq.0 ) then
318 #ifdef _DEBUG_HOMARD_
319 write (ulsort,texte(langue,4)) nrfon2
320 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux= 1,10)
321 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=11,20)
322 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=21,nbpara)
323 write(ulsort,90003) 'carchf',(carchf(iaux,nrfon2),iaux= 1,9)
325 #ifdef _DEBUG_HOMARD_
326 write (ulsort,texte(langue,3)) 'PCFOR2_te', nompro
328 call pcfor2 ( nbpara, carenf, carchf,
330 > typfo2, typch2, typge2, typas2,
331 > ngaus2, nnenm2, nnvap2, carsu2, nbtaf2,
332 > n2vale, n2valr, n2obpr, n2obch, n2lipr,
334 > p2vale, p2valr, p2obpr, p2obch, p2vatt,
338 > obpc2n, obpc2p, obpro2, adpc2n, adpc2p,
340 > ulsort, langue, codret )
342 #ifdef _DEBUG_HOMARD_
343 if ( codret.eq.0 ) then
344 write (ulsort,90003) 'nofon2', nofon2
345 write (ulsort,90002) 'typfo2', typfo2
346 write (ulsort,90002) 'typch2', typch2
347 write (ulsort,90002) 'typge2', typge2
348 write (ulsort,90002) 'typas2', typas2
349 write (ulsort,90002) 'carsu2', carsu2
350 write (ulsort,90002) 'ngaus2', ngaus2
351 c write (ulsort,90003) 'oblo2g', oblo2g
359 c 2.2.2. ==> pyramides
361 if ( nrfon3.gt.0 ) then
363 if ( codret.eq.0 ) then
365 #ifdef _DEBUG_HOMARD_
366 write (ulsort,texte(langue,4)) nrfon3
367 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux= 1,10)
368 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=11,20)
369 write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=21,nbpara)
370 write(ulsort,90003) 'carchf',(carchf(iaux,nrfon3),iaux= 1,9)
372 #ifdef _DEBUG_HOMARD_
373 write (ulsort,texte(langue,3)) 'PCFOR2_py', nompro
375 call pcfor2 ( nbpara, carenf, carchf,
377 > typfo3, typch3, typge3, typas3,
378 > ngaus3, nnenm3, nnvap3, carsu3, nbtaf3,
379 > n3vale, n3valr, n3obpr, n3obch, n3lipr,
381 > p3vale, p3valr, p3obpr, p3obch, p3vatt,
385 > obpc3n, obpc3p, obpro3, adpc3n, adpc3p,
387 > ulsort, langue, codret )
389 #ifdef _DEBUG_HOMARD_
390 if ( codret.eq.0 ) then
391 write (ulsort,90003) 'nofon3', nofon3
392 write (ulsort,90002) 'typfo3', typfo3
393 write (ulsort,90002) 'typch3', typch3
394 write (ulsort,90002) 'typge3', typge3
395 write (ulsort,90002) 'typas3', typas3
396 write (ulsort,90002) 'carsu3', carsu3
397 write (ulsort,90002) 'ngaus3', ngaus3
398 c write (ulsort,90003) 'oblo3g', oblo3g
407 c 3. interpolation des variables
410 c 3.1. ==> sans point de Gauss
412 if ( ngauss.eq.ednopg ) then
414 if ( codret.eq.0 ) then
416 #ifdef _DEBUG_HOMARD_
417 write (ulsort,texte(langue,3)) 'PCSHE0', nompro
419 call pcshe0 ( nbtafo, typint, deraff,
420 > imem(adpc1n), imem(adpc1p),
425 > tritet, cotrte, aretet,
426 > quahex, coquhe, arehex,
427 > facpyr, cofapy, arepyr,
428 > hethex, anchex, filhex, fhpyte,
429 > nbanhe, anfihe, anpthe,
433 > rmem(n1valr), rmem(p1vatt),
434 > rmem(n2valr), rmem(p2vatt),
435 > imem(adpc2n), imem(adpc2p),
436 > rmem(n3valr), rmem(p3vatt),
437 > imem(adpc3n), imem(adpc3p),
438 > ulsort, langue, codret )
441 cgn write(ulsort,*) 'hexa'
442 cgn if ( nbhexa.eq.8 ) then
447 cgn write(ulsort,3000) (rmem(p1vatt+codret+iaux),iaux=0,nbheto-1)
448 cgn write(ulsort,*) 'hexr'
449 cgn write(ulsort,3000) (rmem(p2vatt+iaux),iaux=0,nbhexa-1)
450 cgn write(ulsort,*) 'pyra'
451 cgn if ( nbhexa.eq.8 ) then
456 cgn write(ulsort,3000) (rmem(p3vatt+codret+iaux),iaux=0,nbpyto-1)
457 cgn 3000 format(10g13.5)
462 c 3.2. ==> avec plusieurs points de Gauss
464 c 3.2.1. ==> champ aux noeuds par element
466 if ( carsup.eq.1 ) then
468 if ( codret.eq.0 ) then
470 write (ulsort,texte(langue,8)) mess14(langue,1,6)
471 write (ulsort,texte(langue,10))
477 if ( codret.eq.0 ) then
479 #ifdef _DEBUG_HOMARD_
480 write (ulsort,texte(langue,3)) 'PCEHE1', nompro
482 call pcehe1 ( nbtafo, ngauss, deraff,
483 > imem(adpc1n), imem(adpc1p),
484 > hethex, anchex, filhex, fhpyte,
485 > nbanhe, anfihe, anhehe, anpthe,
489 > rmem(n1valr), rmem(p1vatt),
490 > ulsort, langue, codret )
494 c 3.2.2. ==> vrai champ aux points de Gauss
498 if ( codret.eq.0 ) then
500 write (ulsort,texte(langue,9)) mess14(langue,1,6)
501 write (ulsort,texte(langue,10))
509 cgn print *, 'codret = ', codret
515 if ( codret.ne.0 ) then
519 write (ulsort,texte(langue,1)) 'Sortie', nompro
520 write (ulsort,texte(langue,2)) codret
524 #ifdef _DEBUG_HOMARD_
525 write (ulsort,texte(langue,1)) 'Sortie', nompro