subroutine utb19a ( choix, > coonoe, somare, > hettri, aretri, > famtri, cfatri, > hetqua, arequa, > famqua, cfaqua, > tritet, cotrte, aretet, hettet, > quahex, coquhe, arehex, hethex, > facpyr, cofapy, arepyr, hetpyr, > facpen, cofape, arepen, hetpen, > nbiter, > tbiau1, tabaur, > ulbila, > ulsort, langue, codret ) c ______________________________________________________________________ c c H O M A R D c c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D c c Version originale enregistree le 18 juin 1996 sous le numero 96036 c aupres des huissiers de justice Simart et Lavoir a Clamart c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 c aupres des huissiers de justice c Lavoir, Silinski & Cherqui-Abrahmi a Clamart c c HOMARD est une marque deposee d'Electricite de France c c Copyright EDF 1996 c Copyright EDF 1998 c Copyright EDF 2002 c Copyright EDF 2020 c ______________________________________________________________________ c c UTilitaire - Bilan - option 19 - etape a c -- - -- - c remarque : utb05a et utb19a sont des clones c ______________________________________________________________________ c c but : controle des diametres des mailles c ______________________________________________________________________ c . . . . . c . nom . e/s . taille . description . c .____________________________________________________________________. c . choix . e . 1 . choix du traitement . c . . . . 0 : creation et affichage des histogrammes . c . . . . 2 : sortie du diametre des triangles . c . . . . 3 : sortie du diametre des tetraedres . c . . . . 4 : sortie du diametre des quadrangles . c . . . . 5 : sortie du diametre des pyramides . c . . . . 6 : sortie du diametre des hexaedres . c . . . . 7 : sortie du diametre des pentaedres . c . coonoe . e . nbnoto . coordonnees des noeuds . c . . . * sdim . . c . somare . e .2*nbarto. numeros des extremites d'arete . c . hettri . e . nbtrto . historique de l'etat des triangles . c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . c . famtri . e . nbtrto . famille des triangles . c . cfatri . e . nctftr*. codes des familles des triangles . c . . . nbftri . 1 : famille MED . c . . . . 2 : type de triangle . c . . . . 3 : numero de surface de frontiere . c . . . . 4 : famille des aretes internes apres raf. c . . . . + l : appartenance a l'equivalence l . c . hetqua . e . nbquto . historique de l'etat des quadrangles . c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . c . famqua . e . nbquto . famille des quadrangles . c . cfaqua . e . nctfqu*. codes des familles des quadrangles . c . . . nbfqua . 1 : famille MED . c . . . . 2 : type de quadrangle . c . . . . 3 : numero de surface de frontiere . c . . . . 4 : famille des aretes internes apres raf. c . . . . 5 : famille des triangles de conformite . c . . . . 6 : famille de sf active/inactive . c . . . . + l : appartenance a l'equivalence l . c . hettet . e . nbteto . historique de l'etat des tetraedres . c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . c . hethex . e . nbheto . historique de l'etat des hexaedres . c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . c . hetpyr . e . nbpyto . historique de l'etat des pyramides . c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . c . cofapy . e .nbpycf*5. codes des faces des pyramides . c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . c . hetpen . e . nbpeto . historique de l'etat des pentaedres . c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . c . tbiau1 . a . * . liste des entites examinees . c . tabaur . a . * . qualite des entites . c . nbiter . e . 1 . numero de l'iteration courante . c . ulbila . e . 1 . unite logique d'ecriture du bilan . c . ulsort . e . 1 . unite logique de la sortie generale . c . langue . e . 1 . langue des messages . c . . . . 1 : francais, 2 : anglais . c . codret . s . 1 . code de retour des modules . c . . . . 0 : pas de probleme . c . . . . 1 : probleme . c .____________________________________________________________________. c c==== c 0. declarations et dimensionnement c==== c c 0.1. ==> generalites c implicit none save c character*6 nompro parameter ( nompro = 'UTB19A' ) c #include "nblang.h" #include "coftex.h" c c 0.2. ==> communs c #include "envex1.h" c #include "dicfen.h" #include "nbfami.h" #include "nombno.h" #include "nombar.h" #include "nombtr.h" #include "nombqu.h" #include "nombte.h" #include "nombhe.h" #include "nombpy.h" #include "nombpe.h" #include "envca1.h" #include "impr02.h" c c 0.3. ==> arguments c double precision coonoe(nbnoto,sdim) double precision tabaur(*) c integer choix c integer somare(2,nbarto) integer hettri(nbtrto), aretri(nbtrto,3) integer cfatri(nctftr,nbftri), famtri(nbtrto) integer hetqua(nbquto), arequa(nbquto,4) integer cfaqua(nctfqu,nbfqua), famqua(nbquto) integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) integer hettet(nbteto) integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) integer hethex(nbheto) integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) integer hetpyr(nbpyto) integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) integer hetpen(nbpeto) integer tbiau1(*) integer nbiter c integer ulbila integer ulsort, langue, codret c c 0.4. ==> variables locales c integer letria, lequad integer iaux, jaux integer nbvoto integer nbeexa integer nbqinf integer tbiau2(1) c double precision daux double precision tbdaux(1) c integer nbmess parameter (nbmess = 10 ) character*80 texte(nblang,nbmess) c c 0.5. ==> initialisations c ______________________________________________________________________ c c==== c 1. titre c==== c #include "impr01.h" c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Entree', nompro call dmflsh (iaux) #endif c texte(1,4) = > '(//,3x,''DIAMETRES DES MAILLES'',/,3x,21(''=''))' texte(1,5) = '(''Diametre '',a,'' des '',a,'' : '',g12.5)' texte(1,6) = '(''Nombre de '',a,'' a examiner : '',i8)' c texte(2,4) = > '(//,3x,''DIAMETERS OF MESHES'',/,3x,19(''=''))' texte(2,5) = '(''Diameter '',a,'' of '',a,'': '',g12.5)' texte(2,6) = '(''Number of '',a,'' to be examined: '',i8)' c write (ulsort,texte(langue,4)) write (ulbila,texte(langue,4)) c codret = 0 c nbvoto = nbteto + nbpyto + nbheto + nbpeto c nbqinf = 0 c c==== c 2. calcul des diametres des tetraedres c=== c if ( choix.eq.0 .or. choix.eq.3 ) then c if ( nbteto.ne.0 ) then c iaux = 3 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB19C_te', nompro #endif call utb19c ( choix, iaux, nbteto, nbtecf, nbteca, > coonoe, somare, > aretri, arequa, > hettet, tritet, cotrte, aretet, > nbiter, tabaur, > ulbila, > ulsort, langue, codret ) c endif c endif c c==== c 3. calcul des diametres des pyramides c=== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '3. pyramides ; codret = ', codret #endif c if ( codret.eq.0 ) then c if ( choix.eq.0 .or. choix.eq.5 ) then c if ( nbpyto.ne.0 ) then c iaux = 5 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB19C_py', nompro #endif call utb19c ( choix, iaux, nbpyto, nbpycf, nbpyca, > coonoe, somare, > aretri, arequa, > hetpyr, facpyr, cofapy, arepyr, > nbiter, tabaur, > ulbila, > ulsort, langue, codret ) c endif c endif c endif c c==== c 4. calcul des diametres des hexaedres c=== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '4. hexaedres ; codret = ', codret #endif c if ( codret.eq.0 ) then c if ( choix.eq.0 .or. choix.eq.6 ) then c if ( nbheto.ne.0 ) then c iaux = 6 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB19C_he', nompro #endif call utb19c ( choix, iaux, nbheto, nbhecf, nbheca, > coonoe, somare, > aretri, arequa, > hethex, quahex, coquhe, arehex, > nbiter, tabaur, > ulbila, > ulsort, langue, codret ) c endif c endif c endif c c==== c 5. calcul des diametres des pentaedres c=== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '5. pentaedres ; codret = ', codret #endif c if ( codret.eq.0 ) then c if ( choix.eq.0 .or. choix.eq.7 ) then c if ( nbpeto.ne.0 ) then c iaux = 7 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB19C_pe', nompro #endif call utb19c ( choix, iaux, nbpeto, nbpecf, nbpeca, > coonoe, somare, > aretri, arequa, > hetpen, facpen, cofape, arepen, > nbiter, tabaur, > ulbila, > ulsort, langue, codret ) c endif c endif c endif c c==== c 6. calcul des diametres des triangles d'un maillage 2d ou 2,5d c==== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '6. triangles ; codret = ', codret #endif c if ( codret.eq.0 ) then c if ( choix.eq.0 .or. choix.eq.2 ) then c if ( nbtrto.ne.0 ) then c c 6.1. ==> liste des triangles a examiner : c . en l'absence de tetraedre, pentaedre et pyramide, ce sont c tous les triangles actifs ; c . en presence de tetraedre, pentaedre ou pyramide, ce sont les c triangles actifs qui sont des elements de calcul c nbeexa = 0 c if ( nbteto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then c do 611 , letria = 1 , nbtrto if ( mod(hettri(letria),10).eq.0 ) then nbeexa = nbeexa + 1 tbiau1(nbeexa) = letria endif 611 continue c else c do 612 , letria = 1 , nbtrto if ( mod(hettri(letria),10).eq.0 .and. > cfatri(cotyel,famtri(letria)).ne.0 ) then nbeexa = nbeexa + 1 tbiau1(nbeexa) = letria endif 612 continue c endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,6)) mess14(langue,3,2), nbeexa #endif c c 6.2. ==> calcul #ifdef _DEBUG_HOMARD_ write (ulsort,*) '6.2. calcul ; codret = ', codret #endif c if ( nbeexa.gt.0 ) then c do 62 , iaux = 1 , nbeexa c letria = tbiau1(iaux) c call utdtri ( letria, daux, > coonoe, somare, aretri ) c tabaur(iaux) = daux c 62 continue c endif c c 6.3. ==> impression sur la sortie standard et sur un fichier c a exploiter par xmgrace c if ( choix.eq.0 ) then c if ( nbeexa.gt.0 ) then c jaux = 0 iaux = 2 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB05B', nompro #endif call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, > nbiter, rafdef, nbvoto, > tbiau2, > ulbila, > ulsort, langue, codret ) c endif c endif c endif c endif c endif c c==== c 7. calcul des diametres des quadrangles d'un maillage 2d ou 2,5d c==== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '7. quadrangles ; codret = ', codret #endif c if ( codret.eq.0 ) then c if ( choix.eq.0 .or. choix.eq.4 ) then c if ( nbquto.ne.0 ) then c c 7.1. ==> liste des quadrangles a examiner : c . en l'absence d'hexaedre, pentaedre et pyramide, ce sont c tous les quadrangles actifs ; c . en presence d'hexaedre, pentaedre ou pyramide, ce sont les c quadrangles actifs qui sont des elements de calcul c nbeexa = 0 c if ( nbheto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then c do 711 , lequad = 1 , nbquto if ( mod(hetqua(lequad),100).eq.0 ) then nbeexa = nbeexa + 1 tbiau1(nbeexa) = lequad endif 711 continue c else c do 712 , lequad = 1 , nbquto if ( mod(hetqua(lequad),100).eq.0 .and. > cfaqua(cotyel,famqua(lequad)).ne.0 ) then nbeexa = nbeexa + 1 tbiau1(nbeexa) = lequad endif 712 continue c endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,6)) mess14(langue,3,4), nbeexa #endif c c 7.2. ==> calcul #ifdef _DEBUG_HOMARD_ write (ulsort,*) '7.2. calcul ; codret = ', codret #endif c if ( nbeexa.gt.0 ) then c do 72 , iaux = 1 , nbeexa c lequad = tbiau1(iaux) c call utdqua ( lequad, daux, > coonoe, somare, arequa ) c tabaur(iaux) = daux c 72 continue c endif c c 7.3. ==> impression sur la sortie standard et sur un fichier c a exploiter par xmgrace c if ( choix.eq.0 ) then c if ( nbeexa.gt.0 ) then c jaux = 0 iaux = 4 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'UTB05B', nompro #endif call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, > nbiter, rafdef, nbvoto, > tbiau2, > ulbila, > ulsort, langue, codret ) c endif c endif c endif c endif c endif c c==== c 8. la fin c==== c if ( codret.ne.0 ) then c #include "envex2.h" c write (ulsort,texte(langue,1)) 'Sortie', nompro write (ulsort,texte(langue,2)) codret c endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Sortie', nompro call dmflsh (iaux) #endif c end