1 subroutine infopy ( choix, lapyra,
2 > facpyr, cofapy, arepyr,
3 > hetpyr, filpyr, perpyr, pphepe,
5 > npyrho, npyrca, npyrcs,
6 > hetare, somare, np2are, coonoe,
7 > hettri, aretri, nivtri,
10 > hethex, quahex, filhex, fhpyte,
11 > hetpen, facpen, filpen, fppyte,
16 > ulsort, langue, codret )
17 c ______________________________________________________________________
21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
24 c aupres des huissiers de justice Simart et Lavoir a Clamart
25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
26 c aupres des huissiers de justice
27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
29 c HOMARD est une marque deposee d'Electricite de France
35 c ______________________________________________________________________
37 c INFOrmation : PYramide
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . choix . e . ch2 . choix .
44 c . lapyra . e . 1 . numero du pyramide a analyser .
45 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
46 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
47 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
48 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
49 c . filpyr . e . nbpyto . premier fils des pyramides .
50 c . perpyr . e . nbpyto . pere des pyramides .
51 c . . . . si perpyr(i) > 0 : numero de la pyramide .
52 c . . . . si perpyr(i) < 0 : -numero dans pphepe .
53 c . pphepe . e . * . si i <= nbheco : numero de l'hexaedre .
54 c . . . . si non : numero du pentaedre .
55 c . fampyr . e . nbpyto . famille des pyramides .
56 c . npyrho . e . repyac . numero des pyramides dans HOMARD .
57 c . npyrca . e . * . numero des pyramides dans le calcul .
58 c . npyrcs . e . * . nro des pyra. du calcul pour la solution .
59 c . hetare . e . nbarto . historique de l'etat des aretes .
60 c . somare . e .2*nbarto. numeros des extremites d'arete .
61 c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete .
62 c . coonoe . e . nbnoto . coordonnees des noeuds .
64 c . hettri . e . nbtrto . historique de l'etat des triangles .
65 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
66 c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement .
67 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
68 c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement .
69 c . hettet . e . nbteto . historique de l'etat des tetraedres .
70 c . ntetca . e . * . numero des tetraedres dans le calcul .
71 c . hethex . e . nbheto . historique de l'etat des hexaedres .
72 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
73 c . filhex . e . nbheto . premier fils des hexaedres .
74 c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide .
75 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
76 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
77 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
78 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
79 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
80 c . filpen . e . nbpeto . premier fils des hexaedres .
81 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
82 c . . . . fille du pentaedre k tel que filpen(k) = -j.
83 c . . . . fppyte(2,j) = numero du 1er tetraedre .
84 c . . . . fils du pentaedre k tel que filpen(k) = -j .
85 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
86 c . . . . voltri(i,k) definit le i-eme voisin de k .
87 c . . . . 0 : pas de voisin .
88 c . . . . j>0 : tetraedre j .
89 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
90 c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
91 c . . . . du triangle k tel que voltri(1/2,k) = -j .
92 c . . . . pypetr(2,j) = numero du pentaedre voisin .
93 c . . . . du triangle k tel que voltri(1/2,k) = -j .
94 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
95 c . . . . volqua(i,k) definit le i-eme voisin de k .
96 c . . . . 0 : pas de voisin .
97 c . . . . j>0 : hexaedre j .
98 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
99 c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
100 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
101 c . . . . pypequ(2,j) = numero du pentaedre voisin .
102 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
103 c . nbpafo . e . 1 . nombre de paquets de fonctions .
104 c . nopafo . e . nbpafo . nom des objets qui contiennent la .
105 c . . . . description de chaque paquet de fonctions .
106 c . ulsost . e . 1 . unite logique de la sortie standard .
107 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
108 c . langue . e . 1 . langue des messages .
109 c . . . . 1 : francais, 2 : anglais .
110 c . codret . es . 1 . code de retour des modules .
111 c . . . . 0 : pas de probleme .
112 c . . . . non nul : probleme .
113 c ______________________________________________________________________
116 c 0. declarations et dimensionnement
119 c 0.1. ==> generalites
125 parameter ( nompro = 'INFOPY' )
128 parameter ( langst = 1 )
161 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
162 integer hetpyr(nbpyto)
163 integer filpyr(nbpyto), perpyr(nbpyto), pphepe(*)
164 integer fampyr(nbpyto)
165 integer npyrho(repyac), npyrca(*), npyrcs(*)
166 integer hetare(nbarto), somare(2,nbarto), np2are(nbarto)
167 integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
168 integer hetqua(nbquto), nivqua(nbquto)
169 integer hettet(nbteto), ntetca(*)
170 integer hethex(nbheto), quahex(nbhecf,6)
171 integer filhex(nbheto), fhpyte(2,nbheco)
172 integer hetpen(nbpeto), facpen(nbpecf,5)
173 integer filpen(nbheto), fppyte(2,nbpeco)
174 integer volqua(2,nbquto), pypequ(2,*)
175 integer voltri(2,nbtrto), pypetr(2,*)
178 double precision coonoe(nbnoto,sdim)
180 character*8 nopafo(*)
183 integer ulsort, langue, codret
185 c 0.4. ==> variables locales
187 integer nbfa, nbar, nbso
188 parameter ( nbfa = 5, nbar = 8, nbso = 5 )
190 integer iaux, jaux, kaux
192 integer etat00, etat01, etatpe
193 integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5, lafac6
194 integer laface, lecode
196 integer larete, lepere
197 integer nbfipy, filspy
198 integer nbfite, filste
200 integer listar(nbar), listso(nbso), volint(4,0:5)
201 integer uldeb, ulfin, ulpas, ulecr
203 integer trav1a(tbdim), trav2a(tbdim)
207 double precision qualit, qualij, volume, diamet, torsio
208 double precision vn(4)
211 parameter ( nbmess = 10 )
212 character*80 texte(nblang,nbmess)
216 c ______________________________________________________________________
228 #ifdef _DEBUG_HOMARD_
229 write (ulsort,texte(langue,1)) 'Entree', nompro
235 uldeb = min(ulsost,ulsort)
236 ulfin = max(ulsost,ulsort)
237 ulpas = max ( 1 , ulfin-uldeb )
240 c 2. numero de la pyramide dans HOMARD
243 if ( choix.eq.'PY' ) then
245 if ( lapyra.gt.0 .and. lapyra.le.repyac ) then
246 lapyra = npyrho(iaux)
256 do 30 , ulecr = uldeb , ulfin, ulpas
260 c 3.1. ==> numero de pyramide impossible
262 if ( lapyra.le.0 .or. lapyra.gt.nbpyto ) then
264 if ( choix.eq.'PY' ) then
265 write (ulecr,40010) iaux
267 write (ulecr,40020) lapyra
271 c 3.2. ==> numero de pyramide correct
275 numcal = npyrca(lapyra)
276 if ( numcal.ne.0 ) then
277 write (ulecr,40020) lapyra
278 write (ulecr,40010) numcal
280 write (ulecr,40020) lapyra
286 if ( lapyra.le.nbpyma ) then
290 if ( lapyra.le.nbpycf ) then
291 lafac1 = facpyr(lapyra,1)
292 lafac2 = facpyr(lapyra,2)
293 lafac3 = facpyr(lapyra,3)
294 lafac4 = facpyr(lapyra,4)
295 lafac5 = facpyr(lapyra,5)
296 niveau = max(nivtri(lafac1),nivtri(lafac2),
297 > nivtri(lafac3),nivtri(lafac4),
300 iaux = perpyr(lapyra)
301 lepere = pphepe(-iaux)
302 if ( -iaux.le.nbheco ) then
303 lafac1 = quahex(lepere,1)
304 lafac2 = quahex(lepere,2)
305 lafac3 = quahex(lepere,3)
306 lafac4 = quahex(lepere,4)
307 lafac5 = quahex(lepere,5)
308 lafac6 = quahex(lepere,6)
309 niveau = max(nivqua(lafac1),nivqua(lafac2),
310 > nivqua(lafac3),nivqua(lafac4),
311 > nivqua(lafac5),nivqua(lafac6)) + 1
313 lafac1 = facpen(lepere,1)
314 lafac2 = facpen(lepere,2)
315 lafac3 = facpen(lepere,3)
316 lafac4 = facpen(lepere,4)
317 lafac5 = facpen(lepere,5)
318 niveau = max(nivtri(lafac1),nivtri(lafac2),
319 > nivqua(lafac3),nivqua(lafac4),
320 > nivqua(lafac5)) + 1
323 if ( lapyra.le.nbpype ) then
324 write (ulecr,41010) niveau
326 write (ulecr,41011) niveau-1
330 c 3.2.2. ==> caracteristiques
332 write (ulecr,42000) fampyr(lapyra)
334 c 3.2.3. ==> les faces, les aretes et les noeuds
335 c 3.2.3.1. ==> les faces
337 if ( lapyra.le.nbpycf ) then
340 do 3231 , iaux = 1 , nbfa
341 laface = facpyr(lapyra,iaux)
342 lecode = cofapy(lapyra,iaux)
343 if ( iaux.le.4 ) then
344 taux40 = texttr(mod(hettri(laface),10))
346 taux40 = textqu(mod(hetqua(laface),100))
348 write (ulecr,43320) laface, lecode, taux40
353 c 3.2.3.2. ==> les aretes et les sommets
355 call utaspy ( lapyra,
356 > nbtrto, nbpycf, nbpyca,
358 > facpyr, cofapy, arepyr,
362 do 3232 , iaux = 1 , nbar
363 larete = listar(iaux)
364 taux40 = textar(mod(hetare(larete),10))
365 write (ulecr,43031) larete, taux40
369 write (ulecr,50005) (listso(iaux),iaux=1,nbso)
371 c 3.2.3.3. ==> les noeuds au milieu des aretes
373 if ( degre.eq.2 ) then
376 write (ulecr,50008) (np2are(listar(iaux)),iaux=1,nbar)
382 etat01 = mod(hetpyr(lapyra),100)
383 etat00 = (hetpyr(lapyra)-etat01) / 100
385 taux40 = textpy(etat01)
387 write (ulecr,40001) taux40
388 if ( nbiter.ge.1 ) then
389 taux40 = textpy(etat00)
391 write (ulecr,40001) taux40
394 c 3.2.5. ==> la parente
395 c 3.2.5.1. ==> les fils
397 if ( etat01.ne.0 ) then
403 iaux = perpyr(lapyra)
404 cgn write (ulsort,90002) 'iaux', iaux
405 if ( iaux.ne.0 ) then
407 c 3.2.5.2.1. ==> issu d'un decoupage standard d'une pyramide : non !
409 if ( iaux.gt.0 ) then
412 c 3.2.5.2.2. ==> issu d'un decoupage de conformite d'un hexaedre
414 elseif ( -iaux.le.nbheco ) then
416 lepere = pphepe(-iaux)
417 write (ulecr,45043) mess14(langst,1,6), lepere
418 etatpe = mod(hethex(lepere),1000)
419 jaux = chbiet(etatpe)
420 nbfihe = chnhe(jaux)-1
421 nbfipy = chnpy(jaux)-1
422 nbfite = chnte(jaux)-1
423 #ifdef _DEBUG_HOMARD_
424 write (ulsort,90015) 'etat', etatpe, ' ==> code binaire', jaux
425 write (ulsort,90002) 'nbfihe', nbfihe+1
426 write (ulsort,90002) 'nbfipy', nbfipy+1
427 write (ulsort,90002) 'nbfite', nbfite+1
429 kaux = filhex(lepere)
430 filspy = fhpyte(1,-kaux)
431 filste = fhpyte(2,-kaux)
432 cgn print *,'etatpe = ', etatpe
433 cgn print *,'nbfipy, nbfite = ',nbfipy, nbfite
434 if ( nbfipy.gt.0 ) then
435 write (ulecr,45054) mess14(langst,3,5)
436 do 3253 , jaux = 0 , nbfipy
438 if ( kaux.ne.lapyra ) then
439 write (ulecr,45080) kaux, npyrca(kaux)
443 if ( nbfite.gt.0 ) then
444 write (ulecr,45054) mess14(langst,3,3)
445 do 3254 , jaux = 0 , nbfite
447 write (ulecr,45080) kaux, ntetca(kaux)
451 c 3.2.5.2.3. ==> issu d'un decoupage de conformite d'un pentaedre
455 lepere = pphepe(-iaux)
456 write (ulecr,45044) mess14(langst,1,7), lepere
457 etatpe = mod(hetpen(lepere),100)
458 kaux = filpen(lepere)
459 filspy = fppyte(1,-kaux)
460 filste = fppyte(2,-kaux)
461 if ( etatpe.ge.1 .and. etatpe.le.6 ) then
464 elseif ( etatpe.ge.17 .and. etatpe.le.19 ) then
467 elseif ( etatpe.ge.21 .and. etatpe.le.26 ) then
470 elseif ( etatpe.ge.31 .and. etatpe.le.36 ) then
473 elseif ( etatpe.ge.43 .and. etatpe.le.45 ) then
476 elseif ( etatpe.ge.51 .and. etatpe.le.52 ) then
483 if ( nbfipy.gt.0 ) then
484 write (ulecr,45054) mess14(langst,3,5)
485 do 3255 , jaux = 0 , nbfipy
487 if ( kaux.ne.lapyra ) then
488 write (ulecr,45080) kaux, npyrca(kaux)
492 if ( nbfite.gt.0 ) then
493 write (ulecr,45054) mess14(langst,3,3)
494 do 3256 , jaux = 0 , nbfite
496 write (ulecr,45080) kaux, ntetca(kaux)
503 c 3.2.6. ==> les volumes voisins
505 if ( lapyra.le.nbpycf ) then
507 c 3.2.6.1. ==> on commence par dresser la liste de toutes les pyramides
508 c qui bordent les faces de la pyramide courante mais qui ne
509 c peuvent pas etre consideres comme des volumes voisins :
513 volint(3,iaux) = lapyra
514 if ( etat01.ne.0 ) then
522 c 3.2.6.2. ==> liste des faces a examiner
526 if ( lapyra.le.nbpycf ) then
528 c 3.2.6.2.1. ==> voisinage par les triangles
530 do 32621 , iaux = 1, 4
531 if ( voltri(2,facpyr(lapyra,iaux)).ne.0 ) then
533 trav2a(nbface) = facpyr(lapyra,iaux)
537 c 3.2.6.2.2. ==> voisinage par les quadrangles
539 if ( volqua(2,facpyr(lapyra,5)).ne.0 ) then
541 trav2a(nbface) = -facpyr(lapyra,5)
546 c 3.2.6.3. ==> impression
548 #ifdef _DEBUG_HOMARD_
549 write (ulsort,texte(langue,3)) 'INFOVO', nompro
553 call infovo ( iaux, 1, nbface, volint,
556 > hettet, hetpyr, hethex, hetpen,
559 > ulsort, langue, codret )
563 c 3.2.7. ==> le centre de gravite
565 do 327 , iaux = 1 , sdim
566 vn(iaux) = unscq * ( coonoe(listso(1),iaux) +
567 > coonoe(listso(2),iaux) +
568 > coonoe(listso(3),iaux) +
569 > coonoe(listso(4),iaux) +
570 > coonoe(listso(5),iaux) )
573 write (ulecr,49003) (vn(iaux), iaux = 1 , sdim)
575 c 3.2.8. ==> volume, qualite, diametre et torsion
577 call utqpyr ( lapyra, qualit, qualij, volume,
578 > coonoe, somare, aretri,
579 > facpyr, cofapy, arepyr )
581 write (ulecr,49030) volume
583 write (ulecr,49041) qualij
585 call utdpyr ( lapyra, diamet,
586 > coonoe, somare, aretri,
587 > facpyr, cofapy, arepyr )
589 write (ulecr,49050) diamet
591 call uttpyr ( lapyra, torsio,
592 > coonoe, somare, aretri,
593 > facpyr, cofapy, arepyr )
595 write (ulecr,49060) torsio
597 c 3.2.9. ==> les valeurs des fonctions
599 if ( nbpafo.ne.0 .and. numcal.ne.0 ) then
601 if ( degre.eq.1 ) then
606 jaux = npyrcs(numcal)
608 #ifdef _DEBUG_HOMARD_
609 write (ulsort,texte(langue,3)) 'INFOPF', nompro
611 call infopf ( nbpafo, nopafo,
614 > ulsort, langue, codret )
629 > '* Pyramide numero :',i10, ' dans HOMARD *')
632 > '* . C''est une pyramide du maillage initial. ',
636 > '* . Il a un pyramide voisin : *')
638 > '* . Il est le voisin de ',i10, ' pyramides : *')
644 if ( codret.ne.0 ) then
648 write (ulsort,texte(langue,1)) 'Sortie', nompro
649 write (ulsort,texte(langue,2)) codret
653 #ifdef _DEBUG_HOMARD_
654 write (ulsort,texte(langue,1)) 'Sortie', nompro