1 subroutine infope ( choix, lepent,
2 > facpen, cofape, arepen,
3 > hetpen, filpen, perpen, fppyte,
5 > npenho, npenca, npencs,
6 > hetare, somare, np2are, coonoe,
8 > hetqua, arequa, nivqua,
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 : PEntaedre
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . choix . e . ch2 . choix .
44 c . lepent . e . 1 . numero du pentaedre a analyser .
45 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
46 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
47 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
48 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
49 c . filpen . e . nbpeto . premier fils des pentaedres .
50 c . perpen . e . nbpeto . pere des pentaedres .
51 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
52 c . . . . fille du pentaedre k tel que filpen(k) = -j.
53 c . . . . fppyte(2,j) = numero du 1er tetraedre .
54 c . . . . fils du pentaedre k tel que filpen(k) = -j .
55 c . fampen . e . nbpeto . famille des pentaedres .
56 c . npenho . e . repeac . numero des pentaedres dans HOMARD .
57 c . npenca . e . * . numero des pentaedres dans le calcul .
58 c . npencs . e . * . nro des pent. 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 . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement .
66 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
67 c . arequa . e .nbquto*4. numeros des 4 aretes 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 . hetpyr . e . nbpyto . historique de l'etat des pyramides .
73 c . npyrca . e . * . numero des pyramides dans le calcul .
74 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
75 c . . . . voltri(i,k) definit le i-eme voisin de k .
76 c . . . . 0 : pas de voisin .
77 c . . . . j>0 : tetraedre j .
78 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
79 c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
80 c . . . . du triangle k tel que voltri(1/2,k) = -j .
81 c . . . . pypetr(2,j) = numero du pentaedre voisin .
82 c . . . . du triangle k tel que voltri(1/2,k) = -j .
83 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
84 c . . . . volqua(i,k) definit le i-eme voisin de k .
85 c . . . . 0 : pas de voisin .
86 c . . . . j>0 : hexaedre j .
87 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
88 c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
89 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
90 c . . . . pypequ(2,j) = numero du pentaedre voisin .
91 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
92 c . nbpafo . e . 1 . nombre de paquets de fonctions .
93 c . nopafo . e . nbpafo . nom des objets qui contiennent la .
94 c . . . . description de chaque paquet de fonctions .
95 c . ulsost . e . 1 . unite logique de la sortie standard .
96 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
97 c . langue . e . 1 . langue des messages .
98 c . . . . 1 : francais, 2 : anglais .
99 c . codret . es . 1 . code de retour des modules .
100 c . . . . 0 : pas de probleme .
101 c . . . . non nul : probleme .
102 c ______________________________________________________________________
105 c 0. declarations et dimensionnement
108 c 0.1. ==> generalites
114 parameter ( nompro = 'INFOPE' )
117 parameter ( langst = 1 )
148 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
149 integer hetpen(nbpeto)
150 integer filpen(nbpeto), perpen(nbpeto), fppyte(2,nbpeco)
151 integer fampen(nbpeto)
152 integer npenho(repeac), npenca(*), npencs(*)
153 integer hetare(nbarto), somare(2,nbarto), np2are(nbarto)
154 integer hettri(nbtrto), nivtri(nbtrto)
155 integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
156 integer hettet(nbteto), ntetca(*)
157 integer hethex(nbheto)
158 integer hetpyr(nbpyto), npyrca(*)
159 integer volqua(2,nbquto), pypequ(2,*)
160 integer voltri(2,nbtrto), pypetr(2,*)
163 double precision coonoe(nbnoto,sdim)
165 character*8 nopafo(*)
168 integer ulsort, langue, codret
170 c 0.4. ==> variables locales
172 integer nbfa, nbar, nbso
173 parameter ( nbfa = 5, nbar = 9, nbso = 6 )
175 integer iaux, jaux, kaux
177 integer etat00, etat01, etatpe
178 integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5
179 integer laface, lecode
181 integer freain, larete
182 integer nbfipy, filspy
183 integer nbfite, filste
185 integer listar(nbar), listso(nbso), volint(4,0:5)
186 integer uldeb, ulfin, ulpas, ulecr
188 integer trav1a(tbdim), trav2a(tbdim)
192 double precision qualit, qualij, volume, diamet, torsio
193 double precision vn(4)
196 parameter ( nbmess = 10 )
197 character*80 texte(nblang,nbmess)
200 c ______________________________________________________________________
210 #ifdef _DEBUG_HOMARD_
211 write (ulsort,texte(langue,1)) 'Entree', nompro
217 uldeb = min(ulsost,ulsort)
218 ulfin = max(ulsost,ulsort)
219 ulpas = max ( 1 , ulfin-uldeb )
222 c 2. numero du pentaedre dans HOMARD
225 if ( choix.eq.'PE' ) then
227 if ( lepent.gt.0 .and. lepent.le.repeac ) then
228 lepent = npenho(iaux)
238 do 30 , ulecr = uldeb , ulfin, ulpas
242 c 3.1. ==> numero de pentaedre impossible
244 if ( lepent.le.0 .or. lepent.gt.nbpeto ) then
246 if ( choix.eq.'PE' ) then
247 write (ulecr,40010) iaux
249 write (ulecr,40020) lepent
253 c 3.2. ==> numero de pentaedre correct
257 if ( repeac.gt.0 ) then
258 numcal = npenca(lepent)
262 if ( numcal.ne.0 ) then
263 write (ulecr,40020) lepent
264 write (ulecr,40010) numcal
266 write (ulecr,40020) lepent
272 if ( lepent.le.nbpema ) then
275 if ( lepent.le.nbpecf ) then
276 lafac1 = facpen(lepent,1)
277 lafac2 = facpen(lepent,2)
278 lafac3 = facpen(lepent,3)
279 lafac4 = facpen(lepent,4)
280 lafac5 = facpen(lepent,5)
281 niveau = max(nivtri(lafac1),nivtri(lafac2),
282 > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5))
284 if ( lepent.le.nbpepe ) then
285 write (ulecr,41010) niveau
287 write (ulecr,41011) niveau-1
292 c 3.2.2. ==> caracteristiques
294 write (ulecr,42000) fampen(lepent)
296 c 3.2.3. ==> les faces, les aretes et les noeuds
297 c 3.2.3.1. ==> les faces
299 if ( lepent.le.nbpecf ) then
302 do 3231 , iaux = 1 , nbfa
303 laface = facpen(lepent,iaux)
304 lecode = cofape(lepent,iaux)
305 if ( iaux.le.2 ) then
306 taux40 = texttr(mod(hettri(laface),10))
308 taux40 = textqu(mod(hetqua(laface),100))
311 write (ulecr,43320) laface, lecode, taux40
316 c 3.2.3.2. ==> les aretes et les sommets
318 call utaspe ( lepent,
319 > nbquto, nbpecf, nbpeca,
321 > facpen, cofape, arepen,
325 do 3232 , iaux = 1 , nbar
326 larete = listar(iaux)
327 taux40 = textar(mod(hetare(larete),10))
328 write (ulecr,43031) larete, taux40
332 write (ulecr,50006) (listso(iaux),iaux=1,nbso)
334 c 3.2.3.3. ==> les noeuds au milieu des aretes
336 if ( degre.eq.2 ) then
339 write (ulecr,50009) (np2are(listar(iaux)),iaux=1,nbar)
345 etat01 = mod(hetpen(lepent),100)
346 etat00 = (hetpen(lepent)-etat01) / 100
348 taux40 = textpe(etat01)
350 write (ulecr,40001) taux40
351 if ( nbiter.ge.1 ) then
352 taux40 = textpe(etat00)
354 write (ulecr,40001) taux40
357 c 3.2.5. ==> la parente
358 c 3.2.5.1. ==> les fils
360 if ( etat01.ne.0 ) then
362 freain = filpen(lepent)
364 c 3.2.5.1. ==> les fils
365 c 3.2.5.1.1. ==> fils pour le decoupage de conformite
367 if ( ( etat01.ge. 1 .and. etat01.le. 6 ) .or.
368 > ( etat01.ge.17 .and. etat01.le.19 ) .or.
369 > ( etat01.ge.21 .and. etat01.le.26 ) .or.
370 > ( etat01.ge.31 .and. etat01.le.36 ) .or.
371 > ( etat01.ge.43 .and. etat01.le.45 ) .or.
372 > ( etat01.ge.51 .and. etat01.le.52 ) ) then
375 filspy = fppyte(1,freain)
376 filste = fppyte(2,freain)
377 if ( etat01.ge.1 .and. etat01.le.6 ) then
380 elseif ( etat01.ge.17 .and. etat01.le.19 ) then
383 elseif ( etat01.ge.21 .and. etat01.le.26 ) then
386 elseif ( etat01.ge.31 .and. etat01.le.36 ) then
389 elseif ( etat01.ge.43 .and. etat01.le.45 ) then
392 elseif ( etat01.ge.51 .and. etat01.le.52 ) then
399 if ( nbfipy.ge.0 ) then
400 write (ulecr,45010) mess14(langst,3,5)
401 do 3251 , jaux = 0 , nbfipy
403 write (ulecr,45080) kaux, npyrca(kaux)
406 if ( nbfite.ge.0 ) then
407 write (ulecr,45010) mess14(langst,3,3)
408 do 3252 , jaux = 0 , nbfite
410 write (ulecr,45080) kaux, ntetca(kaux)
414 c 3.2.5.1.2. ==> fils pour le decoupage standard
418 write (ulecr,45010) mess14(langst,3,7)
420 do 3253 , jaux = 0 , nbfipe
422 if ( repeac.eq.0 .or. npenca(kaux).eq.0 ) then
423 write (ulecr,45070) kaux
425 write (ulecr,45080) kaux, npenca(kaux)
434 if ( perpen(lepent).ne.0 ) then
436 write (ulecr,45040) mess14(langst,1,7), perpen(lepent)
437 etatpe = mod(hetpen(perpen(lepent)),100)
438 if ( etatpe.eq.80 .or. etatpe.eq.99 ) then
444 freain = filpen(perpen(lepent))
445 write (ulecr,45050) mess14(langst,3,7)
446 do 3254 , jaux = 0 , iaux
448 if ( kaux.ne.lepent ) then
449 if ( repeac.eq.0 ) then
450 write (ulecr,45070) kaux
452 write (ulecr,45080) kaux, npenca(kaux)
459 c 3.2.6. ==> les volumes voisins
460 c 3.2.6.1. ==> on commence par dresser la liste de tous les pentaedres
461 c qui bordent les faces du pentaedre courant mais qui ne
462 c peuvent pas etre consideres comme des volumes voisins :
463 c lui-meme et ses fils dans les cas de conformite.
464 c il suffit d'eliminer les pyramides dont la base est une
465 c des faces quadrangulaires de l'hexaedre et les tetraedres
466 c s'appuyant sur une face triangulaire non decoupee.
467 c Dans les autres cas, le volume ne peut pas etre voisin
469 c voir cmcdpe pour les conventions sur les fils
472 if ( etat01.ge.1 .and. etat01.le.9 ) then
474 volint(1,iaux) = fppyte(2,-filpen(lepent))
475 elseif ( etat01.ge.7 .and. etat01.le.9 ) then
477 volint(1,iaux) = fppyte(2,-filpen(lepent))
479 volint(1,iaux) = fppyte(2,-filpen(lepent)) + 1
480 elseif ( etat01.ge.11 .and. etat01.le.16 ) then
482 volint(1,iaux) = fppyte(2,-filpen(lepent))
483 elseif ( etat01.ge.31 .and. etat01.le.32 ) then
485 volint(1,iaux) = fppyte(2,-filpen(lepent)) + 10
490 if ( etat01.ge.1 .and. etat01.le.9 ) then
492 volint(3,iaux) = fppyte(1,-filpen(lepent))
494 volint(3,iaux) = fppyte(1,-filpen(lepent)) + 1
495 elseif ( etat01.ge.7 .and. etat01.le.9 ) then
497 volint(3,iaux) = fppyte(1,-filpen(lepent))
498 elseif ( etat01.ge.21 .and. etat01.le.23 ) then
500 volint(3,iaux) = fppyte(2,-filpen(lepent))
503 volint(4,iaux) = lepent
506 c 3.2.6.2. ==> liste des faces a examiner
510 c 3.2.6.2.1. ==> voisinage par les triangles
512 do 32621 , iaux = 1, 2
513 if ( voltri(2,facpen(lepent,iaux)).ne.0 ) then
515 trav2a(nbface) = facpen(lepent,iaux)
519 c 3.2.6.2.2. ==> voisinage par les quadrangles
521 do 32622 , iaux = 3, 5
522 if ( volqua(2,facpen(lepent,iaux)).ne.0 ) then
524 trav2a(nbface) = -facpen(lepent,iaux)
528 c 3.2.6.3. ==> impression
530 #ifdef _DEBUG_HOMARD_
531 write (ulsort,texte(langue,3)) 'INFOVO', nompro
535 call infovo ( iaux, 1, nbface, volint,
538 > hettet, hetpyr, hethex, hetpen,
541 > ulsort, langue, codret )
543 c 3.2.7. ==> le centre de gravite
545 do 327 , iaux = 1 , sdim
546 vn(iaux) = unssix * ( coonoe(listso(1),iaux) +
547 > coonoe(listso(2),iaux) +
548 > coonoe(listso(3),iaux) +
549 > coonoe(listso(4),iaux) +
550 > coonoe(listso(5),iaux) +
551 > coonoe(listso(6),iaux) )
554 write (ulecr,49003) (vn(iaux), iaux = 1 , sdim)
556 c 3.2.8. ==> volume, qualite, diametre et torsion
558 call utqpen ( lepent, qualit, qualij, volume,
559 > coonoe, somare, arequa,
560 > facpen, cofape, arepen )
562 write (ulecr,49030) volume
564 write (ulecr,49041) qualij
566 call utdpen ( lepent, diamet,
567 > coonoe, somare, arequa,
568 > facpen, cofape, arepen )
570 write (ulecr,49050) diamet
572 call uttpen ( lepent, torsio,
573 > coonoe, somare, arequa,
574 > facpen, cofape, arepen )
576 write (ulecr,49060) torsio
578 c 3.2.9. ==> les valeurs des fonctions
580 if ( nbpafo.ne.0 .and. numcal.ne.0 ) then
582 if ( degre.eq.1 ) then
587 jaux = npencs(numcal)
589 #ifdef _DEBUG_HOMARD_
590 write (ulsort,texte(langue,3)) 'INFOPF', nompro
592 call infopf ( nbpafo, nopafo,
595 > ulsort, langue, codret )
610 > '* Pentaedre numero :',i10, ' dans HOMARD *')
613 > '* . C''est un pentaedre du maillage initial. ',
617 > '* . Il a un pentaedre voisin : *')
619 > '* . Il est le voisin de ',i10, ' pentaedres : *')
625 if ( codret.ne.0 ) then
629 write (ulsort,texte(langue,1)) 'Sortie', nompro
630 write (ulsort,texte(langue,2)) codret
634 #ifdef _DEBUG_HOMARD_
635 write (ulsort,texte(langue,1)) 'Sortie', nompro