1 subroutine utb17b ( somare, np2are,
6 > hettet, tritet, cotrte, aretet,
7 > hethex, quahex, coquhe, arehex,
8 > hetpyr, facpyr, cofapy, arepyr,
9 > hetpen, facpen, cofape, arepen,
12 > ulsort, langue, codret )
13 c ______________________________________________________________________
17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
20 c aupres des huissiers de justice Simart et Lavoir a Clamart
21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
22 c aupres des huissiers de justice
23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
25 c HOMARD est une marque deposee d'Electricite de France
31 c ______________________________________________________________________
33 c UTilitaire - Bilan sur le maillage - option 17 - phase b
35 c ______________________________________________________________________
37 c diagnostic des elements volumiques du calcul
38 c un element est surcontraint si tous ses noeuds sont au bord du domaine
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . somare . e .2*nbarto. numeros des extremites d'arete .
44 c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes .
45 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
46 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
47 c . . . . voltri(i,k) definit le i-eme voisin de k .
48 c . . . . 0 : pas de voisin .
49 c . . . . j>0 : tetraedre j .
50 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
51 c . famtri . e . nbtrto . famille des triangles .
52 c . cfatri . e . nctftr*. codes des familles des triangles .
53 c . . . nbftri . 1 : famille MED .
54 c . . . . 2 : type de triangle .
55 c . . . . 3 : numero de surface de frontiere .
56 c . . . . 4 : famille des aretes internes apres raf.
57 c . . . . + l : appartenance a l'equivalence l .
58 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
59 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
60 c . . . . volqua(i,k) definit le i-eme voisin de k .
61 c . . . . 0 : pas de voisin .
62 c . . . . j>0 : hexaedre j .
63 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
64 c . famqua . e . nbquto . famille des quadrangles .
65 c . cfaqua . e . nctfqu*. codes des familles des quadrangles .
66 c . . . nbfqua . 1 : famille MED .
67 c . . . . 2 : type de quadrangle .
68 c . . . . 3 : numero de surface de frontiere .
69 c . . . . 4 : famille des aretes internes apres raf.
70 c . . . . 5 : famille des triangles de conformite .
71 c . . . . 6 : famille de sf active/inactive .
72 c . . . . + l : appartenance a l'equivalence l .
73 c . hettet . e . nbteto . historique de l'etat des tetraedres .
74 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
75 c . cotrte . e .nbtecf*4. codes des triangles des tetraedres .
76 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
77 c . hethex . e . nbheto . historique de l'etat des hexaedres .
78 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
79 c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres .
80 c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres .
81 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
82 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
83 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
84 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
85 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
86 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
87 c . cofape . e .nbpecf*5. codes des faces des pentaedres .
88 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
89 c . tabaux . e . nbnoto . 0 : le noeud est interne .
90 c . . . . 1 : le noeud est au bord d'un volume .
91 c . ulbila . e . 1 . unite logique d'ecriture du bilan .
92 c . ulsort . e . 1 . unite logique de la sortie generale .
93 c . langue . e . 1 . langue des messages .
94 c . . . . 1 : francais, 2 : anglais .
95 c . codret . s . 1 . code de retour des modules .
96 c . . . . 0 : pas de probleme .
97 c . . . . 1 : probleme .
98 c .____________________________________________________________________.
101 c 0. declarations et dimensionnement
104 c 0.1. ==> generalites
110 parameter ( nompro = 'UTB17B' )
133 integer somare(2,nbarto), np2are(nbarto)
135 integer aretri(nbtrto,3), voltri(2,nbtrto)
136 integer famtri(nbtrto), cfatri(nctftr,nbftri)
138 integer arequa(nbquto,4), volqua(2,nbquto)
139 integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
141 integer hettet(nbteto)
142 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
143 integer hethex(nbheto)
144 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
145 integer hetpyr(nbpyto)
146 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
147 integer hetpen(nbpeto)
148 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
150 integer tabaux(nbnoto)
153 integer ulsort, langue, codret
155 c 0.4. ==> variables locales
158 integer letet0, lehex0, lepen0, lapyr0
159 integer letetr, lehexa, lepent, lapyra
160 integer letria, lequad
161 integer nbensc, nbensb
162 integer listar(12), listso(8)
169 parameter (nbmess = 10 )
170 character*80 texte(nblang,nbmess)
172 c 0.5. ==> initialisations
173 c ______________________________________________________________________
181 #ifdef _DEBUG_HOMARD_
182 write (ulsort,texte(langue,1)) 'Entree', nompro
186 texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)'
187 texte(1,5) = '(''. Examen du '',a,i8)'
188 texte(1,6) = '(''... '',a,i10,'' au bord'')'
190 >'(''. Le bord du '',a,i10,'' n''''est pas une maille de calcul.''
192 texte(1,8) = '(''. Le '',a,i8,'' est surcontraint.'')'
194 texte(2,4) = '(''Number of active '',a,'': '',i8)'
195 texte(2,5) = '(''. Examination of '',a,''#'',i8)'
196 texte(2,6) = '(''... '',a,''#'',i8,'' on the boundary'')'
198 >'(''. The boundary of the '',a,i10,'' is not a calculation mesh.''
200 texte(2,8) = '(''. The '',a,''#'',i8,'' is overstressed.'')'
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,texte(langue,4)) mess14(langue,3,3), nbteac
206 write (ulsort,texte(langue,4)) mess14(langue,3,5), nbpyac
207 write (ulsort,texte(langue,4)) mess14(langue,3,6), nbheac
208 write (ulsort,texte(langue,4)) mess14(langue,3,7), nbpeac
214 c 2. Diagnostic sur les tetraedres
216 #ifdef _DEBUG_HOMARD_
217 write (ulsort,90002) '2. tetraedres, codret', codret
220 if ( nbteac.gt.0 ) then
222 #ifdef _DEBUG_HOMARD_
223 write (ulsort,90002) 'nbteto', nbteto
224 write (ulsort,90002) 'nbtecf', nbtecf
225 write (ulsort,90002) 'nbteca', nbteca
228 if ( nbteca.eq.0 ) then
238 do 2 , letet0 = 1, nbteto
242 #ifdef _DEBUG_HOMARD_
243 write (ulsort,texte(langue,5)) mess14(langue,1,3), letetr
246 etat = mod( hettet(letetr),100 )
248 if ( etat.eq.0 ) then
250 c 2.1. ==> On regarde si tous les noeuds sont sur le bord
252 call utaste ( letetr,
253 > nbtrto, nbtecf, nbteca,
255 > tritet, cotrte, aretet,
258 do 211 , iaux = 1 , 4
259 if ( tabaux(listso(iaux)).eq.0 ) then
263 if ( degre.eq.2 ) then
264 do 212 , iaux = 1 , 6
265 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
272 #ifdef _DEBUG_HOMARD_
273 write (ulsort,texte(langue,8)) mess14(langue,1,3), letetr
278 c 2.2. ==> On verifie que chaque face au bord est un element de calcul
284 letria = tritet(letetr,iaux)
285 if ( voltri(2,letria).eq.0 ) then
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
291 if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
293 #ifdef _DEBUG_HOMARD_
294 write (ulsort,texte(langue,7)) mess14(langue,1,3), letetr
311 c 2.3. ==> Impression
313 #ifdef _DEBUG_HOMARD_
314 write (ulsort,texte(langue,3)) 'UTB17E', nompro
317 call utb17e ( iaux, nbensc, aubord, nbensb,
319 > ulsort, langue, codret )
324 c 3. Diagnostic sur les hexaedres
326 #ifdef _DEBUG_HOMARD_
327 write (ulsort,90002) '3. hexaedres, codret', codret
330 if ( nbheac.gt.0 ) then
332 #ifdef _DEBUG_HOMARD_
333 write (ulsort,90002) 'nbheto', nbheto
334 write (ulsort,90002) 'nbhecf', nbhecf
335 write (ulsort,90002) 'nbheca', nbheca
338 if ( nbheca.eq.0 ) then
348 do 3 , lehex0 = 1, nbheto
352 #ifdef _DEBUG_HOMARD_
353 write (ulsort,texte(langue,5)) mess14(langue,1,6), lehexa
356 etat = mod(hethex(lehexa),1000)
358 if ( etat.eq.0 ) then
360 c 3.1. ==> On regarde si tous les noeuds sont sur le bord
362 call utashe ( lehexa,
363 > nbquto, nbhecf, nbheca,
365 > quahex, coquhe, arehex,
368 do 312 , iaux = 1 , 8
369 if ( tabaux(listso(iaux)).eq.0 ) then
373 if ( degre.eq.2 ) then
374 do 313 , iaux = 1 , 12
375 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
382 #ifdef _DEBUG_HOMARD_
383 write (ulsort,texte(langue,8)) mess14(langue,1,6), lehexa
388 c 3.2. ==> On verifie que chaque face au bord est un element de calcul
392 cgn write(ulsort,90002) 'faces', (quahex(lehexa,letet0),letet0=1,6)
395 lequad = quahex(lehexa,iaux)
396 if ( volqua(2,lequad).eq.0 ) then
397 #ifdef _DEBUG_HOMARD_
398 write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
402 if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
404 #ifdef _DEBUG_HOMARD_
405 write (ulsort,texte(langue,7)) mess14(langue,1,6), lehexa
422 c 3.3. ==> Impression
424 #ifdef _DEBUG_HOMARD_
425 write (ulsort,texte(langue,3)) 'UTB17E', nompro
428 call utb17e ( iaux, nbensc, aubord, nbensb,
430 > ulsort, langue, codret )
435 c 4. Diagnostic sur les pyramides
437 #ifdef _DEBUG_HOMARD_
438 write (ulsort,90002) '4. pyramides, codret', codret
441 if ( nbpyac.gt.0 ) then
443 #ifdef _DEBUG_HOMARD_
444 write (ulsort,90002) 'nbpyto', nbpyto
445 write (ulsort,90002) 'nbpycf', nbpycf
446 write (ulsort,90002) 'nbpyca', nbpyca
449 if ( nbpyca.eq.0 ) then
459 do 4 , lapyr0 = 1, nbpyto
463 #ifdef _DEBUG_HOMARD_
464 write (ulsort,texte(langue,5)) mess14(langue,1,5), lapyra
467 etat = mod( hetpyr(lapyra),100)
469 if ( etat.eq.0 ) then
471 c 4.1. ==> On regarde si tous les noeuds sont sur le bord
473 call utaspy ( lapyra,
474 > nbtrto, nbpycf, nbpyca,
476 > facpyr, cofapy, arepyr,
479 do 411 , iaux = 1 , 5
480 if ( tabaux(listso(iaux)).eq.0 ) then
484 if ( degre.eq.2 ) then
485 do 412 , iaux = 1 , 8
486 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
493 #ifdef _DEBUG_HOMARD_
494 write (ulsort,texte(langue,8)) mess14(langue,1,5), lapyra
499 c 4.2. ==> On verifie que chaque face au bord est un element de calcul
505 letria = facpyr(lapyra,iaux)
506 if ( voltri(2,letria).eq.0 ) then
507 #ifdef _DEBUG_HOMARD_
508 write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
512 if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
514 #ifdef _DEBUG_HOMARD_
515 write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra
524 lequad = facpyr(lapyra,5)
525 if ( volqua(2,lequad).eq.0 ) then
526 #ifdef _DEBUG_HOMARD_
527 write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
531 if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
533 #ifdef _DEBUG_HOMARD_
534 write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra
549 c 4.3. ==> Impression
551 #ifdef _DEBUG_HOMARD_
552 write (ulsort,texte(langue,3)) 'UTB17E', nompro
555 call utb17e ( iaux, nbensc, aubord, nbensb,
557 > ulsort, langue, codret )
562 c 5. Diagnostic sur les pentaedres
564 #ifdef _DEBUG_HOMARD_
565 write (ulsort,90002) '5. pentaedres, codret', codret
568 if ( nbpeac.gt.0 ) then
570 #ifdef _DEBUG_HOMARD_
571 write (ulsort,90002) 'nbpeto', nbpeto
572 write (ulsort,90002) 'nbpecf', nbpecf
573 write (ulsort,90002) 'nbpeca', nbpeca
576 if ( nbpeca.eq.0 ) then
586 do 5 , lepen0 = 1, nbpeto
590 #ifdef _DEBUG_HOMARD_
591 write (ulsort,texte(langue,5)) mess14(langue,1,7), lepent
594 etat = mod( hetpen(lepent),100)
596 if ( etat.eq.0 ) then
598 c 5.1. ==> On regarde si tous les noeuds sont sur le bord
600 call utaspe ( lepent,
601 > nbquto, nbpecf, nbpeca,
603 > facpen, cofape, arepen,
606 do 511 , iaux = 1 , 6
607 if ( tabaux(listso(iaux)).eq.0 ) then
611 if ( degre.eq.2 ) then
612 do 512 , iaux = 1 , 9
613 if ( tabaux(np2are(listar(iaux))).eq.0 ) then
620 #ifdef _DEBUG_HOMARD_
621 write (ulsort,texte(langue,8)) mess14(langue,1,7), lepent
626 c 5.2. ==> On verifie que chaque face au bord est un element de calcul
627 c . On regarde si la face est une maille de calcul
631 do 521 , iaux = 1 , 2
633 letria = facpen(lepent,iaux)
634 if ( voltri(2,letria).eq.0 ) then
635 #ifdef _DEBUG_HOMARD_
636 write (ulsort,texte(langue,6)) mess14(langue,1,2), letria
640 if ( cfatri(cotyel,famtri(letria)).eq.0 ) then
642 #ifdef _DEBUG_HOMARD_
643 write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent
652 do 522 , iaux = 3 , 5
654 lequad = facpen(lepent,iaux)
655 if ( volqua(2,lequad).eq.0 ) then
656 #ifdef _DEBUG_HOMARD_
657 write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad
661 if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then
663 #ifdef _DEBUG_HOMARD_
664 write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent
681 c 5.3. ==> Impression
683 #ifdef _DEBUG_HOMARD_
684 write (ulsort,texte(langue,3)) 'UTB17E', nompro
687 call utb17e ( iaux, nbensc, aubord, nbensb,
689 > ulsort, langue, codret )
697 #ifdef _DEBUG_HOMARD_
698 write (ulsort,texte(langue,1)) 'Sortie', nompro