1 subroutine utb11b ( nbbloc,
20 > lapile, tabau2, tabau3, tabau4,
21 > taba11, taba12, taba13, taba14,
25 > ulsort, langue, codret )
26 c ______________________________________________________________________
30 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
32 c Version originale enregistree le 18 juin 1996 sous le numero 96036
33 c aupres des huissiers de justice Simart et Lavoir a Clamart
34 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
35 c aupres des huissiers de justice
36 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
38 c HOMARD est une marque deposee d'Electricite de France
44 c ______________________________________________________________________
46 c UTilitaire - Bilan sur le maillage - option 11 - phase b
48 c ______________________________________________________________________
50 c analyse de la connexite des volumes
51 c remarque : on s'est arrange pour que les mailles externes soient
52 c numerotes dans cet ordre :
56 c . les mailles-points
61 c ______________________________________________________________________
63 c . nom . e/s . taille . description .
64 c .____________________________________________________________________.
65 c . nbbloc . s . 1 . nombre de blocs .
66 c . hetare . e . nbarto . historique de l'etat des aretes .
67 c . somare . e .2*nbarto. numeros des extremites d'arete .
68 c . hettri . e . nbtrto . historique de l'etat des triangles .
69 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
70 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
71 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
72 c . hettet . e . nbteto . historique de l'etat des tetraedres .
73 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
74 c . hethex . e . nbheto . historique de l'etat des hexaedres .
75 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
76 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
77 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
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 . povoso . e .0:nbnoto. pointeur des voisins par noeud .
81 c . voisom . e . nvosom . aretes voisines de chaque noeud .
82 c . posifa . e .0:nbarto. pointeur sur tableau facare .
83 c . facare . e . nbfaar . liste des faces contenant une arete .
84 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
85 c . . . . voltri(i,k) definit le i-eme voisin de k .
86 c . . . . 0 : pas de voisin .
87 c . . . . j>0 : tetraedre j .
88 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
89 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
90 c . . . . du triangle k tel que voltri(1/2,k) = -j .
91 c . . . . pypetr(2,j) = numero du pentaedre voisin .
92 c . . . . du triangle k tel que voltri(1/2,k) = -j .
93 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
94 c . . . . volqua(i,k) definit le i-eme voisin de k .
95 c . . . . 0 : pas de voisin .
96 c . . . . j>0 : hexaedre j .
97 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
98 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
99 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
100 c . . . . pypequ(2,j) = numero du pentaedre voisin .
101 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
102 c . famare . e . nbarto . famille des aretes .
103 c . cfaare . e . nctfar*. codes des familles des aretes .
104 c . famtri . e . nbtrto . famille des triangles .
105 c . cfatri . e . nctftr*. codes des familles des triangles .
106 c . . . nbftri . 1 : famille MED .
107 c . . . . 2 : type de triangle .
108 c . . . . 3 : numero de surface de frontiere .
109 c . . . . 4 : famille des aretes internes apres raf.
110 c . . . . + l : appartenance a l'equivalence l .
111 c . famqua . e . nbquto . famille des quadrangles .
112 c . cfaqua . e . nctfqu*. codes des familles des quadrangles .
113 c . . . nbfqua . 1 : famille MED .
114 c . . . . 2 : type de quadrangle .
115 c . . . . 3 : numero de surface de frontiere .
116 c . . . . 4 : famille des aretes internes apres raf.
117 c . . . . 5 : famille des triangles de conformite .
118 c . . . . 6 : famille de sf active/inactive .
119 c . . . . + l : appartenance a l'equivalence l .
120 c . famtet . e . nbteto . famille des tetraedres .
121 c . cfatet . . nctfte*. codes des familles des tetraedres .
122 c . . . nbftet . 1 : famille MED .
123 c . . . . 2 : type de tetraedres .
124 c . famhex . e . nbheto . famille des hexaedres .
125 c . cfahex . . nctfhe*. codes des familles des hexaedres .
126 c . . . nbfhex . 1 : famille MED .
127 c . . . . 2 : type d'hexaedres .
128 c . . . . 3 : famille des tetraedres de conformite .
129 c . . . . 4 : famille des pyramides de conformite .
130 c . fampyr . e . nbpyto . famille des pyramides .
131 c . cfapyr . . nctfpy*. codes des familles des pyramides .
132 c . . . nbfpyr . 1 : famille MED .
133 c . . . . 2 : type de pyramides .
134 c . fampen . e . nbpeto . famille des pentaedres .
135 c . cfapen . . nctfpe*. codes des familles des pentaedres .
136 c . . . nbfpen . 1 : famille MED .
137 c . . . . 2 : type de pentaedres .
138 c . . . . 3 : famille des tetraedres de conformite .
139 c . . . . 4 : famille des pyramides de conformite .
140 c . lapile . a . * . tableau de travail .
141 c . tabau2 . a . nbnoto . tableau de travail .
142 c . tabau3 . a . nbarto . tableau de travail .
143 c . tabau4 . a .-nbquto . tableau de travail .
145 c . taba11 . a . * . tableau de travail .
146 c . taba12 . a . nbnoto . tableau de travail .
147 c . taba13 . a . nbarto . tableau de travail .
148 c . taba14 . a . * . tableau de travail .
149 c . taba15 . a . nbarto . tableau de travail .
150 c . taba16 . a . * . tableau de travail .
151 c . nublvo . s . * . numero de blocs des volumes, ranges ainsi :.
152 c . . . . les tetraedres .
153 c . . . . les hexaedres .
154 c . . . . les pyramides .
155 c . . . . les pentaedres .
156 c . ulbila . e . 1 . unite logique d'ecriture du bilan .
157 c . . . . si 0 : on n'ecrit rien .
158 c . ulsort . e . 1 . unite logique de la sortie generale .
159 c . langue . e . 1 . langue des messages .
160 c . . . . 1 : francais, 2 : anglais .
161 c . codret . s . 1 . code de retour des modules .
162 c . . . . 0 : pas de probleme .
163 c . . . . 1 : probleme .
164 c .____________________________________________________________________.
167 c 0. declarations et dimensionnement
170 c 0.1. ==> generalites
176 parameter ( nompro = 'UTB11B' )
200 integer hetare(nbarto), somare(2,nbarto)
201 integer hettri(nbtrto), aretri(nbtrto,3)
202 integer hetqua(nbquto), arequa(nbquto,4)
203 integer hettet(nbteto), tritet(nbtecf,4)
204 integer hethex(nbheto), quahex(nbhecf,6)
205 integer hetpyr(nbpyto), facpyr(nbpycf,5)
206 integer hetpen(nbpeto), facpen(nbpecf,5)
207 integer posifa(0:nbarto), facare(nbfaar)
208 integer povoso(0:nbnoto), voisom(*)
209 integer voltri(2,nbtrto), pypetr(2,*)
210 integer volqua(2,nbquto), pypequ(2,*)
212 integer famare(nbarto), cfaare(nctfar,nbfare)
213 integer famtri(nbtrto), cfatri(nctftr,nbftri)
214 integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
215 integer famtet(nbteto), cfatet(nctfte,nbftet)
216 integer famhex(nbheto), cfahex(nctfhe,nbfhex)
217 integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr)
218 integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
221 integer tabau2(nbnoto)
222 integer tabau3(nbarto)
223 integer tabau4(-nbquto:*)
225 integer taba12(nbnoto)
226 integer taba13(nbarto)
228 integer taba15(nbarto)
233 integer ulsort, langue, codret
235 c 0.4. ==> variables locales
237 integer iaux, jaux, kaux, laux, maux
239 integer levolu, nument, typvo0, typvol
241 integer lamail, lgpile
242 integer maxtet, maxhex, maxpyr, maxpen
243 integer dectet, dechex, decpyr, decpen
244 integer lapyra, lepent
246 #ifdef _DEBUG_HOMARD_
252 parameter (nbmess = 10 )
253 character*80 texte(nblang,nbmess)
261 #ifdef _DEBUG_HOMARD_
262 write (ulsort,texte(langue,1)) 'Entree', nompro
266 c 1.1. ==> Les messages
268 texte(1,4) = '(/,3x,''. Connexite des '',a)'
270 >'(5x,''* Les '',a,'' sont en un seul bloc.'',15x,''*'')'
272 >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')'
274 >'(5x,''* Bloc numero '',i8,5x,'' * '',i11,1x,a,'' *'')'
276 >'(5x,''* Nombre d''''Euler (2+V-F+A-S) :'',i5,19x,''*'')'
277 texte(1,9) = '(''.. Nombre de blocs de '',a,'':'',i5)'
278 texte(1,10) = '(''.. Impression du bloc'',i8)'
280 texte(2,4) = '(/,3x,''. Connexity of '',a)'
282 >'(5x,''* All the '',a,'' are connected.'',18x,''*'')'
284 >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')'
286 >'(5x,''* Block # '',i8,9x,'' * '',i11,1x,a,'' *'')'
288 >'(5x,''* Euler characteristic (2+V-F+A-S):'',i5,14x,''*'')'
289 texte(2,9) = '(''.. Number of blocks of '',a,'':'',i5)'
290 texte(2,10) = '(''.. Printing of block #'',i8)'
293 cgn print 91020,(voltri(1,iaux),iaux=1,nbtrto)
294 cgn print 91020,(voltri(2,iaux),iaux=1,nbtrto)
295 cgn print 91020,(pypetr(1,iaux),iaux=1,16)
296 cgn print 91020,(pypetr(2,iaux),iaux=1,56)
297 cgn print 91020,(pypequ(1,iaux),iaux=1,4)
298 cgn print 91020,(pypequ(2,iaux),iaux=1,14)
300 10100 format(/,5x,58('*'))
301 10200 format( 5x,58('*'))
303 c 1.2. ==> constantes
305 if ( nbpyac.eq.0 .and. nbheac.eq.0 .and. nbpeac.eq.0 ) then
307 elseif ( nbheac.eq.0 .and. nbpeac.eq.0 .and. nbteac.eq.0 ) then
309 elseif ( nbpeac.eq.0 .and. nbteac.eq.0 .and. nbpyac.eq.0 ) then
311 elseif ( nbteac.eq.0 .and. nbpyac.eq.0 .and. nbheac.eq.0 ) then
317 #ifdef _DEBUG_HOMARD_
318 if ( ulbila.gt.0 ) then
319 write (ulsort,texte(langue,4)) mess14(langue,3,typvo0)
323 #ifdef _DEBUG_HOMARD_
324 write (ulsort,90002) 'nbteto, nbtecf, nbteca',
325 > nbteto, nbtecf, nbteca
326 write (ulsort,90002) 'nbheto, nbhecf, nbheca',
327 > nbheto, nbhecf, nbheca
328 write (ulsort,90002) 'nbpyto, nbpycf, nbpyca',
329 > nbpyto, nbpycf, nbpyca
330 write (ulsort,90002) 'nbpeto, nbpecf, nbpeca',
331 > nbpeto, nbpecf, nbpeca
335 maxtet = dectet + nbteto
337 maxhex = dechex + nbheto
339 maxpyr = decpyr + nbpyto
341 maxpen = decpen + nbpeto
343 #ifdef _DEBUG_HOMARD_
344 write (ulsort,90015) 'dectet', dectet, ', maxtet', maxtet
345 write (ulsort,90015) 'dechex', dechex, ', maxhex', maxhex
346 write (ulsort,90015) 'decpyr', decpyr, ', maxpyr', maxpyr
347 write (ulsort,90015) 'decpen', decpen, ', maxpen', maxpen
350 c 1.3. ==> Aucun bloc au depart
352 do 13 , iaux = 1 , maxpen
359 c 2. blocs de volumes
361 #ifdef _DEBUG_HOMARD_
362 write (ulsort,90002) '2. blocs de volumes ; codret =', codret
366 iaux = iaux + ( nbteac + nbheac + nbpyac + nbpeac )
367 iaux = iaux - ( nbtrac + nbquac )
371 write (ulbila,texte(langue,8)) iaux
377 do 20 , levolu = 1, maxpen
380 #ifdef _DEBUG_HOMARD_
381 if ( levolu.eq.0 ) then
387 #ifdef _DEBUG_HOMARD_
388 if ( glop.ne.0 ) then
389 write (ulsort,90002) 'Volume', levolu
392 if ( levolu.le.maxtet ) then
393 nument = levolu - dectet
394 if ( cfatet(cotyel,famtet(nument)).ne.0 ) then
395 etat = mod(hettet(nument),100)
397 elseif ( levolu.le.maxhex ) then
398 nument = levolu - dechex
399 if ( cfahex(cotyel,famhex(nument)).ne.0 ) then
400 etat = mod(hethex(nument),1000)
402 elseif ( levolu.le.maxpyr ) then
403 nument = levolu - decpyr
404 if ( cfapyr(cotyel,fampyr(nument)).ne.0 ) then
405 etat = mod(hetpyr(nument),100)
408 nument = levolu - decpen
409 if ( cfapen(cotyel,fampen(nument)).ne.0 ) then
410 etat = mod(hetpen(nument),100)
413 #ifdef _DEBUG_HOMARD_
414 if ( glop.ne.0 ) then
415 write (ulsort,90002) '============== etat', etat
419 if ( etat.eq.0 ) then
421 if ( nublvo(levolu).eq.0 ) then
423 c 2.1. ==> on commence un nouveau bloc
424 c 2.1.1. ==> impression des caracteristiques du bloc precedent
426 if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then
427 #ifdef _DEBUG_HOMARD_
428 write (ulsort,90002) 'nbbloc', nbbloc
431 c 2.1.1.1. ==> recherche des faces actives de ce bloc
433 if ( codret.eq.0 ) then
437 #ifdef _DEBUG_HOMARD_
438 write (ulsort,texte(langue,3)) 'UTB11E', nompro
440 call utb11e ( iaux, nbbloc, nublvo,
443 > tritet, quahex, facpyr, facpen,
444 > maxtet, maxhex, maxpyr, maxpen,
446 > ulsort, langue, codret )
450 c 2.1.1.2. ==> recherche des blocs de faces actives de ce bloc
452 if ( codret.eq.0 ) then
456 #ifdef _DEBUG_HOMARD_
457 write (ulsort,texte(langue,3)) 'UTB11C', nompro
459 call utb11c ( nbblfa, iaux, tabau4,
468 > taba11, taba12, taba13,
472 > ulsort, langue, codret )
476 c 2.1.1.3. ==> impression veritable
478 if ( codret.eq.0 ) then
480 #ifdef _DEBUG_HOMARD_
481 write (ulsort,texte(langue,10)) nbbloc
484 #ifdef _DEBUG_HOMARD_
485 write (ulsort,texte(langue,3)) 'UTB11F', nompro
487 call utb11f ( nbbloc, nbblfa, typvo0, typvol,
488 > nublvo, tabau2, tabau3, tabau4,
490 > ulsort, langue, codret )
496 c 2.1.2. ==> initialisations pour un nouveau bloc
500 #ifdef _DEBUG_HOMARD_
501 write (ulsort,90015) 'debut du bloc ',nbbloc,
502 > ' avec lamail = ', lamail
505 do 2121 , iaux = 1 , nbnoto
508 do 2122 , iaux = 1 , nbarto
516 #ifdef _DEBUG_HOMARD_
517 if ( glop.ne.0 ) then
518 if ( lamail.le.maxtet ) then
520 elseif ( lamail.le.maxhex ) then
522 elseif ( lamail.le.maxpyr ) then
527 write (ulsort,*) '... Maille', lamail,
528 > ' (',mess14(langue,1,typenh),')'
532 c 2.2. ==> memorisation du bloc pour la maille courante
534 nublvo(lamail) = nbbloc
536 if ( lamail.le.maxtet ) then
537 if ( typvol.eq.0 ) then
539 elseif ( typvol.ne.3 ) then
542 elseif ( lamail.le.maxhex ) then
543 if ( typvol.eq.0 ) then
545 elseif ( typvol.ne.6 ) then
548 elseif ( lamail.le.maxpyr ) then
549 if ( typvol.eq.0 ) then
551 elseif ( typvol.ne.5 ) then
555 if ( typvol.eq.0 ) then
557 elseif ( typvol.ne.7 ) then
562 c 2.3. ==> mise des voisins dans la pile s'ils n'ont pas ete vus.
563 c Il faut faire attention a la numerotation. Pour la pile et
564 c nublvo, c'est la numerotation globale des mailles ; pour les
565 c caracteristiques des entites, c'est leur numero local.
567 c 2.3.1. ==> Cas d'un tetraedre
569 if ( lamail.le.maxtet ) then
571 nument = lamail - dectet
572 #ifdef _DEBUG_HOMARD_
573 if ( glop.eq.1 ) then
574 write (ulsort,90002) 'C''est le tetraedre ', nument
578 if ( nument.le.nbtecf ) then
580 do 231 , iaux = 1 , 4
582 jaux = tritet(nument,iaux)
583 #ifdef _DEBUG_HOMARD_
584 if ( glop.ne.0 ) then
585 write (ulsort,90002) '..... triangle jaux = ', jaux
588 do 2311 , laux = 1 , 3
589 kaux = aretri(jaux,laux)
590 tabau3(kaux) = tabau3(kaux) + 1
591 maux = somare(1,kaux)
592 tabau2(maux) = tabau2(maux) + 1
593 maux = somare(2,kaux)
594 tabau2(maux) = tabau2(maux) + 1
597 do 2312 , laux = 1 , 2
599 kaux = voltri(laux,jaux)
601 c 2.3.1.1. ==> Le voisin est un autre tetraedre
603 if ( kaux.gt.0 .and. kaux.ne.nument ) then
604 #ifdef _DEBUG_HOMARD_
605 if ( glop.ne.0 ) then
606 write (ulsort,90015) '....... Le ',laux,
607 > '-ieme voisin est le tetraedre ',kaux
608 write (ulsort,90002) '....... du bloc ',nublvo(kaux)
612 if ( nublvo(kaux).eq.0 ) then
613 if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
614 etat = mod( hettet(kaux),100)
615 if ( etat.eq.0 ) then
617 lapile(lgpile) = kaux
622 elseif ( kaux.lt.0 ) then
626 c 2.3.1.2. ==> Le voisin est une pyramide
628 if ( pypetr(1,kaux).ne.0 ) then
629 lapyra = pypetr(1,kaux)
630 #ifdef _DEBUG_HOMARD_
631 if ( glop.ne.0 ) then
632 write (ulsort,90015) '....... Le ',laux,
633 > '-ieme voisin est la pyramide ',lapyra
634 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
637 if ( nublvo(decpyr+lapyra).eq.0 ) then
638 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
639 etat = mod( hetpyr(lapyra),100)
640 if ( etat.eq.0 ) then
642 lapile(lgpile) = decpyr+lapyra
648 c 2.3.1.3. ==> Le voisin est un pentaedre
650 if ( pypetr(2,kaux).ne.0 ) then
651 lepent = pypetr(2,kaux)
652 #ifdef _DEBUG_HOMARD_
653 if ( glop.ne.0 ) then
654 write (ulsort,90015) '....... Le ',laux,
655 > '-ieme voisin est le pentaedre ',lepent
656 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
659 if ( nublvo(decpen+lepent).eq.0 ) then
660 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
661 etat = mod( hetpen(lepent),100)
662 if ( etat.eq.0 ) then
664 lapile(lgpile) = decpen+lepent
675 #ifdef _DEBUG_HOMARD_
676 if ( glop.ne.0 ) then
677 write (ulsort,*) 'OK'
683 c 2.3.2. ==> Cas d'un hexaedre
685 elseif ( lamail.le.maxhex ) then
687 nument = lamail-dechex
688 #ifdef _DEBUG_HOMARD_
689 if ( glop.eq.1 ) then
690 write (ulsort,90002) 'C''est l''hexaedre ', nument
694 if ( nument.le.nbhecf ) then
696 do 232 , iaux = 1 , 6
698 jaux = quahex(nument,iaux)
699 #ifdef _DEBUG_HOMARD_
700 if ( glop.eq.1 ) then
701 write (ulsort,90002) '..... quadrangle jaux = ', jaux
704 do 2321 , laux = 1 , 4
705 kaux = arequa(jaux,laux)
706 tabau3(kaux) = tabau3(kaux) + 1
707 maux = somare(1,kaux)
708 tabau2(maux) = tabau2(maux) + 1
709 maux = somare(2,kaux)
710 tabau2(maux) = tabau2(maux) + 1
713 do 2322 , laux = 1 , 2
715 kaux = volqua(laux,jaux)
717 #ifdef _DEBUG_HOMARD_
718 if ( glop.eq.1 ) then
719 write (ulsort,90002) '....... kaux = ', kaux
723 c 2.3.2.1. ==> Le voisin est un autre hexaedre
725 if ( kaux.gt.0 .and. kaux.ne.nument ) then
727 #ifdef _DEBUG_HOMARD_
728 if ( glop.eq.1 ) then
729 write (ulsort,90015) '....... Le ',laux,
730 > '-ieme voisin est l''hexaedre ',kaux
731 write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
734 if ( nublvo(dechex+kaux).eq.0 ) then
735 if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
736 etat = mod( hethex(kaux),1000)
737 if ( etat.eq.0 ) then
739 lapile(lgpile) = dechex+kaux
744 elseif ( kaux.lt.0 ) then
747 cgn if ( glop.eq.1 ) then
748 cgn write (ulsort,90002) 'pypequ(1,kaux)', pypequ(1,kaux)
749 cgn write (ulsort,90002) 'pypequ(2,kaux)', pypequ(2,kaux)
752 c 2.3.2.2. ==> Le voisin est une pyramide
754 if ( pypequ(1,kaux).ne.0 ) then
755 lapyra = pypequ(1,kaux)
756 #ifdef _DEBUG_HOMARD_
757 if ( glop.eq.1 ) then
758 write (ulsort,90015) '....... Le ',laux,
759 > '-ieme voisin est la pyramide ', lapyra
760 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
763 if ( nublvo(decpyr+lapyra).eq.0 ) then
764 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
765 etat = mod( hetpyr(lapyra),100)
766 if ( etat.eq.0 ) then
768 lapile(lgpile) = decpyr+lapyra
774 c 2.3.2.3. ==> Le voisin est un pentaedre
776 if ( pypequ(2,kaux).ne.0 ) then
777 lepent = pypequ(2,kaux)
778 #ifdef _DEBUG_HOMARD_
779 if ( glop.eq.1 ) then
780 write (ulsort,90015) '....... Le ',laux,
781 > '-ieme voisin est le pentaedre ',lepent
782 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
785 if ( nublvo(decpen+lepent).eq.0 ) then
786 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
787 etat = mod( hetpen(lepent),100)
788 if ( etat.eq.0 ) then
790 lapile(lgpile) = decpen+lepent
804 c 2.3.3. ==> Cas de la pyramide
806 elseif ( lamail.le.maxpyr ) then
808 nument = lamail-decpyr
809 #ifdef _DEBUG_HOMARD_
810 if ( glop.eq.1 ) then
811 write (ulsort,90002) 'C''est la pyramide ',nument
815 if ( nument.le.nbpycf ) then
817 c 2.3.3.1. ==> Le voisinage par les triangles
819 do 233 , iaux = 1 , 4
821 jaux = facpyr(nument,iaux)
822 #ifdef _DEBUG_HOMARD_
823 if ( glop.eq.1 ) then
824 write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux
827 do 2331 , laux = 1 , 3
828 kaux = aretri(jaux,laux)
829 tabau3(kaux) = tabau3(kaux) + 1
830 maux = somare(1,kaux)
831 tabau2(maux) = tabau2(maux) + 1
832 maux = somare(2,kaux)
833 tabau2(maux) = tabau2(maux) + 1
836 do 2332 , laux = 1 , 2
838 kaux = voltri(laux,jaux)
840 c 2.3.3.1.1. ==> Le voisin est un tetraedre
842 if ( kaux.gt.0 ) then
844 #ifdef _DEBUG_HOMARD_
845 if ( glop.eq.1 ) then
846 write (ulsort,90015) '....... Le ',laux,
847 > '-ieme voisin est le tetraedre ',kaux
848 write (ulsort,90002) '....... du bloc ', nublvo(kaux)
851 if ( nublvo(kaux).eq.0 ) then
852 if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
853 etat = mod( hettet(kaux),100)
854 if ( etat.eq.0 ) then
856 lapile(lgpile) = kaux
861 elseif ( kaux.lt.0 ) then
865 c 2.3.3.1.2. ==> Le voisin est une autre pyramide
867 lapyra = pypetr(1,kaux)
868 if ( lapyra.ne.0 .and. lapyra.ne.nument ) then
869 #ifdef _DEBUG_HOMARD_
870 if ( glop.eq.1 ) then
871 write (ulsort,90015) '....... Le ',laux,
872 > '-ieme voisin est la pyramide ',lapyra
873 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
876 if ( nublvo(decpyr+lapyra).eq.0 ) then
877 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
878 etat = mod( hetpyr(lapyra),100)
879 if ( etat.eq.0 ) then
881 lapile(lgpile) = decpyr+lapyra
887 c 2.3.3.1.3. ==> Le voisin est un pentaedre
889 if ( pypetr(2,kaux).ne.0 ) then
890 lepent = pypetr(2,kaux)
891 #ifdef _DEBUG_HOMARD_
892 if ( glop.eq.1 ) then
893 write (ulsort,90015) '....... Le ',laux,
894 > '-ieme voisin est le pentaedre ',lepent
895 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
898 if ( nublvo(decpen+lepent).eq.0 ) then
899 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
900 etat = mod( hetpen(lepent),100)
901 if ( etat.eq.0 ) then
903 lapile(lgpile) = decpen+lepent
915 c 2.3.3.2. ==> Le voisinage par le quadrangle
917 jaux = facpyr(nument,5)
918 #ifdef _DEBUG_HOMARD_
919 if ( glop.eq.1 ) then
920 write (ulsort,90002) '..... le quadrangle numero', jaux
923 do 2333 , laux = 1 , 4
924 kaux = arequa(jaux,laux)
925 tabau3(kaux) = tabau3(kaux) + 1
926 maux = somare(1,kaux)
927 tabau2(maux) = tabau2(maux) + 1
928 maux = somare(2,kaux)
929 tabau2(maux) = tabau2(maux) + 1
932 do 2334 , laux = 1 , 2
934 kaux = volqua(laux,jaux)
936 c 2.3.3.2.1. ==> Le voisin est un hexaedre
938 if ( kaux.gt.0 ) then
939 #ifdef _DEBUG_HOMARD_
940 if ( glop.eq.1 ) then
941 write (ulsort,90015) '....... Le ',laux,
942 > '-ieme voisin est l''hexaedre ',kaux
943 write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
947 if ( nublvo(dechex+kaux).eq.0 ) then
948 if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
949 etat = mod( hethex(kaux),1000)
950 if ( etat.eq.0 ) then
952 lapile(lgpile) = dechex+kaux
957 elseif ( kaux.lt.0 ) then
961 c 2.3.3.2.2. ==> Le voisin est une autre pyramide
963 lapyra = pypequ(1,kaux)
964 if ( lapyra.ne.0 .and. lapyra.ne.nument ) then
965 #ifdef _DEBUG_HOMARD_
966 if ( glop.eq.1 ) then
967 write (ulsort,90015) '....... Le ',laux,
968 > '-ieme voisin est la pyramide ',lapyra
969 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
972 if ( nublvo(decpyr+lapyra).eq.0 ) then
973 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
974 etat = mod( hetpyr(lapyra),100)
975 if ( etat.eq.0 ) then
977 lapile(lgpile) = decpyr+lapyra
983 c 2.3.3.2.3. ==> Le voisin est un pentaedre
985 if ( pypequ(2,kaux).ne.0 ) then
986 lepent = pypequ(2,kaux)
987 #ifdef _DEBUG_HOMARD_
988 if ( glop.eq.1 ) then
989 write (ulsort,90015) '....... Le ',laux,
990 > '-ieme voisin est le pentaedre ',lepent
991 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
994 if ( nublvo(decpen+lepent).eq.0 ) then
995 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
996 etat = mod( hetpen(lepent),100)
997 if ( etat.eq.0 ) then
999 lapile(lgpile) = decpen+lepent
1011 c 2.3.4. ==> Cas du pentaedre
1015 nument = lamail-decpen
1016 #ifdef _DEBUG_HOMARD_
1017 if ( glop.eq.1 ) then
1018 write (ulsort,90002) 'C''est le pentaedre ',nument
1022 if ( nument.le.nbpecf ) then
1024 c 2.3.4.1. ==> Le voisinage par les triangles
1026 do 2341 , iaux = 1 , 2
1028 jaux = facpen(nument,iaux)
1029 #ifdef _DEBUG_HOMARD_
1030 if ( glop.eq.1 ) then
1031 write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux
1034 do 23411 , laux = 1 , 3
1035 kaux = aretri(jaux,laux)
1036 tabau3(kaux) = tabau3(kaux) + 1
1037 maux = somare(1,kaux)
1038 tabau2(maux) = tabau2(maux) + 1
1039 maux = somare(2,kaux)
1040 tabau2(maux) = tabau2(maux) + 1
1043 do 23412 , laux = 1 , 2
1045 kaux = voltri(laux,jaux)
1047 c 2.3.4.1.1. ==> Le voisin est un tetraedre
1049 if ( kaux.gt.0 ) then
1051 #ifdef _DEBUG_HOMARD_
1052 if ( glop.eq.1 ) then
1053 write (ulsort,90015) '....... Le ',laux,
1054 > '-ieme voisin est le tetraedre ',kaux
1055 write (ulsort,90002) '....... du bloc ', nublvo(kaux)
1058 if ( nublvo(kaux).eq.0 ) then
1059 if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then
1060 etat = mod( hettet(kaux),100)
1061 if ( etat.eq.0 ) then
1063 lapile(lgpile) = kaux
1068 elseif ( kaux.lt.0 ) then
1072 c 2.3.4.1.2. ==> Le voisin est une pyramide
1074 if ( pypetr(1,kaux).ne.0 ) then
1075 lapyra = pypetr(1,kaux)
1076 #ifdef _DEBUG_HOMARD_
1077 if ( glop.eq.1 ) then
1078 write (ulsort,90015) '....... Le ',laux,
1079 > '-ieme voisin est la pyramide ',lapyra
1080 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
1083 if ( nublvo(decpyr+lapyra).eq.0 ) then
1084 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
1085 etat = mod( hetpyr(lapyra),100)
1086 if ( etat.eq.0 ) then
1088 lapile(lgpile) = decpyr+lapyra
1094 c 2.3.4.1.3. ==> Le voisin est un autre pentaedre
1096 lepent = pypetr(2,kaux)
1097 if ( lepent.ne.0 .and. lepent.ne.nument ) then
1098 #ifdef _DEBUG_HOMARD_
1099 if ( glop.eq.1 ) then
1100 write (ulsort,90002) 'nument', nument
1101 write (ulsort,90015) '....... Le ',laux,
1102 > '-ieme voisin est le pentaedre ',lepent
1103 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
1106 if ( nublvo(decpen+lepent).eq.0 ) then
1107 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
1108 etat = mod( hetpen(lepent),100)
1109 if ( etat.eq.0 ) then
1111 lapile(lgpile) = decpen+lepent
1123 c 2.3.4.2. ==> Le voisinage par les quadrangles
1125 do 2342 , iaux = 3 , 5
1127 jaux = facpen(nument,iaux)
1128 #ifdef _DEBUG_HOMARD_
1129 if ( glop.eq.1 ) then
1130 write (ulsort,90015) '..... ', iaux,'-ieme quadrangle =', jaux
1133 do 23421 , laux = 1 , 4
1134 kaux = arequa(jaux,laux)
1135 tabau3(kaux) = tabau3(kaux) + 1
1136 maux = somare(1,kaux)
1137 tabau2(maux) = tabau2(maux) + 1
1138 maux = somare(2,kaux)
1139 tabau2(maux) = tabau2(maux) + 1
1142 do 23422 , laux = 1 , 2
1144 kaux = volqua(laux,jaux)
1146 #ifdef _DEBUG_HOMARD_
1147 if ( glop.eq.1 ) then
1148 write (ulsort,90002) '....... kaux = ', kaux
1152 c 2.3.4.2.1. ==> Le voisin est un hexaedre
1154 if ( kaux.gt.0 ) then
1155 #ifdef _DEBUG_HOMARD_
1156 if ( glop.eq.1 ) then
1157 write (ulsort,90015) '....... Le ',laux,
1158 > '-ieme voisin est l''hexaedre ',kaux
1159 write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux)
1163 if ( nublvo(dechex+kaux).eq.0 ) then
1164 if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then
1165 etat = mod( hethex(kaux),1000)
1166 if ( etat.eq.0 ) then
1168 lapile(lgpile) = dechex+kaux
1173 elseif ( kaux.lt.0 ) then
1177 c 2.3.4.2.2. ==> Le voisin est une pyramide
1179 if ( pypequ(1,kaux).ne.0 ) then
1180 lapyra = pypequ(1,kaux)
1181 #ifdef _DEBUG_HOMARD_
1182 if ( glop.eq.1 ) then
1183 write (ulsort,90015) '....... Le ',laux,
1184 > '-ieme voisin est la pyramide ',lapyra
1185 write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra)
1188 if ( nublvo(decpyr+lapyra).eq.0 ) then
1189 if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
1190 etat = mod( hetpyr(lapyra),100)
1191 if ( etat.eq.0 ) then
1193 lapile(lgpile) = decpyr+lapyra
1199 c 2.3.4.2.3. ==> Le voisin est un autre pentaedre
1201 lepent = pypequ(2,kaux)
1202 if ( lepent.ne.0 .and. lepent.ne.nument ) then
1203 #ifdef _DEBUG_HOMARD_
1204 if ( glop.eq.1 ) then
1205 write (ulsort,90015) '....... Le ',laux,
1206 > '-ieme voisin est le pentaedre ',lepent
1207 write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent)
1210 if ( nublvo(decpen+lepent).eq.0 ) then
1211 if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
1212 etat = mod( hetpen(lepent),100)
1213 if ( etat.eq.0 ) then
1215 lapile(lgpile) = decpen+lepent
1231 c 2.4. ==> on passe a la maille suivante de la pile
1233 if ( lgpile.gt.0 ) then
1235 lamail = lapile(lgpile)
1240 #ifdef _DEBUG_HOMARD_
1241 write (ulsort,90002) 'fin du bloc', nbbloc
1251 c 3. impression du dernier bloc
1253 #ifdef _DEBUG_HOMARD_
1254 write(ulsort,90002) '3. impression dernier bloc ; codret', codret
1257 if ( codret.eq.0 ) then
1259 if ( ulbila.gt.0 ) then
1261 c 3.1. ==> recherche des faces actives de ce bloc
1263 if ( codret.eq.0 ) then
1267 #ifdef _DEBUG_HOMARD_
1268 write (ulsort,texte(langue,3)) 'UTB11E', nompro
1270 call utb11e ( iaux, nbbloc, nublvo,
1273 > tritet, quahex, facpyr, facpen,
1274 > maxtet, maxhex, maxpyr, maxpen,
1276 > ulsort, langue, codret )
1280 c 3.2. ==> recherche des blocs de faces actives de ce bloc
1282 if ( codret.eq.0 ) then
1286 #ifdef _DEBUG_HOMARD_
1287 write (ulsort,texte(langue,3)) 'UTB11C', nompro
1289 call utb11c ( nbblfa, iaux, tabau4,
1298 > taba11, taba12, taba13,
1302 > ulsort, langue, codret )
1306 c 3.3. ==> impression veritable
1308 if ( codret.eq.0 ) then
1310 #ifdef _DEBUG_HOMARD_
1311 write (ulsort,texte(langue,9)) mess14(langue,3,8), nbblfa
1312 write (ulsort,texte(langue,10)) nbbloc
1315 if ( nbbloc.eq.1 ) then
1320 #ifdef _DEBUG_HOMARD_
1321 write (ulsort,texte(langue,3)) 'UTB11F', nompro
1323 call utb11f ( iaux, nbblfa, typvo0, typvol,
1324 > nublvo, tabau2, tabau3, tabau4,
1326 > ulsort, langue, codret )
1329 3000 format(5x,58('*'))
1341 if ( codret.ne.0 ) then
1345 write (ulsort,texte(langue,1)) 'Sortie', nompro
1346 write (ulsort,texte(langue,2)) codret
1350 #ifdef _DEBUG_HOMARD_
1351 write (ulsort,texte(langue,1)) 'Sortie', nompro