src/tool/Utilitaire/utb13a.F

   1       subroutine utb13a ( coonoe,
   2      >                    somare, hetare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    tritet, cotrte, aretet, hettet,
   6      >                    quahex, coquhe, arehex, hethex,
   7      >                    facpyr, cofapy, arepyr, hetpyr,
   8      >                    facpen, cofape, arepen, hetpen,
   9      >                    famare, cfaare,
  10      >                    famtri, cfatri,
  11      >                    famqua, cfaqua,
  12      >                    famtet, cfatet,
  13      >                    famhex, cfahex,
  14      >                    fampyr, cfapyr,
  15      >                    fampen, cfapen,
  16      >                    nbfmed, numfam, unicoo,
  17      >                    grfmpo, grfmtl, grfmtb,
  18      >                    nbgrfm, nomgro, lgnogr,
  19      >                    famnum, famval,
  20      >                    lifagr,
  21      >                    ulbila,
  22      >                    ulsort, langue, codret )
  23 c ______________________________________________________________________
  24 c
  25 c                             H O M A R D
  26 c
  27 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  28 c
  29 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  30 c aupres des huissiers de justice Simart et Lavoir a Clamart
  31 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  32 c aupres des huissiers de justice
  33 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  34 c
  35 c    HOMARD est une marque deposee d'Electricite de France
  36 c
  37 c Copyright EDF 1996
  38 c Copyright EDF 1998
  39 c Copyright EDF 2002
  40 c Copyright EDF 2020
  41 c ______________________________________________________________________
  42 c
  43 c    UTilitaire - Bilan sur le maillage - option 13
  44 c    --           -                              --
  45 c ______________________________________________________________________
  46 c
  47 c longueurs, surfaces et volumes des sous-domaines du maillage de calcul
  48 c ______________________________________________________________________
  49 c .        .     .        .                                            .
  50 c .  nom   . e/s . taille .           description                      .
  51 c .____________________________________________________________________.
  52 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  53 c .        .     . * sdim .                                            .
  54 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  55 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  56 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  57 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  58 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  59 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  60 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  61 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  62 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  63 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  64 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  65 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  66 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  67 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  68 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  69 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  70 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  71 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  72 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  73 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  74 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  75 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  76 c . famare . e   . nbarto . famille des aretes                         .
  77 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  78 c .        .     . nbfare .   1 : famille MED                          .
  79 c .        .     .        .   2 : type de segment                      .
  80 c .        .     .        .   3 : orientation                          .
  81 c .        .     .        .   4 : famille d'orientation inverse        .
  82 c .        .     .        .   5 : numero de ligne de frontiere         .
  83 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  84 c .        .     .        . <= 0 si non concernee                      .
  85 c .        .     .        .   6 : famille frontiere active/inactive    .
  86 c .        .     .        .   7 : numero de surface de frontiere       .
  87 c .        .     .        . + l : appartenance a l'equivalence l       .
  88 c . famtri . e   . nbtrto . famille des triangles                      .
  89 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  90 c .        .     . nbftri .   1 : famille MED                          .
  91 c .        .     .        .   2 : type de triangle                     .
  92 c .        .     .        .   3 : numero de surface de frontiere       .
  93 c .        .     .        .   4 : famille des aretes internes apres raf.
  94 c .        .     .        . + l : appartenance a l'equivalence l       .
  95 c . famqua . e   . nbquto . famille des quadrangles                    .
  96 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  97 c .        .     . nbfqua .   1 : famille MED                          .
  98 c .        .     .        .   2 : type de quadrangle                   .
  99 c .        .     .        .   3 : numero de surface de frontiere       .
 100 c .        .     .        .   4 : famille des aretes internes apres raf.
 101 c .        .     .        .   5 : famille des triangles de conformite  .
 102 c .        .     .        .   6 : famille de sf active/inactive        .
 103 c .        .     .        . + l : appartenance a l'equivalence l       .
 104 c . famtet . e   . nbteto . famille des tetraedres                     .
 105 c . cfatet .     . nctfte*. codes des familles des tetraedres          .
 106 c .        .     . nbftet .   1 : famille MED                          .
 107 c .        .     .        .   2 : type de tetraedres                   .
 108 c .        .     .        . + l : appartenance a l'equivalence l       .
 109 c . famhex . e   . nbheto . famille des hexaedres                      .
 110 c . cfahex .     . nctfhe*. codes des familles des hexaedres           .
 111 c .        .     . nbfhex .   1 : famille MED                          .
 112 c .        .     .        .   2 : type d'hexaedres                     .
 113 c .        .     .        .   3 : famille des tetraedres de conformite .
 114 c .        .     .        .   4 : famille des pyramides de conformite  .
 115 c . fampyr . e   . nbpyto . famille des pyramides                      .
 116 c . cfapyr .     . nctfpy*. codes des familles des pyramides           .
 117 c .        .     . nbfpyr .   1 : famille MED                          .
 118 c .        .     .        .   2 : type de pyramides                    .
 119 c . fampen . e   . nbpeto . famille des pentaedres                     .
 120 c . cfapen .     . nctfpe*. codes des familles des pentaedres          .
 121 c .        .     . nbfpen .   1 : famille MED                          .
 122 c .        .     .        .   2 : type de pentaedres                   .
 123 c .        .     .        .   3 : famille des tetraedres de conformite .
 124 c .        .     .        .   4 : famille des pyramides de conformite  .
 125 c . nbfmed . e   .    1   . nombre de familles au sens MED             .
 126 c . numfam . e   . nbfmed . numero des familles au sens MED            .
 127 c . grfmpo . e   .0:nbfmed. pointeur des groupes des familles          .
 128 c . grfmtl . e   .   *    . taille des groupes des familles            .
 129 c . grfmtb . e   .10ngrouc. table des groupes des familles             .
 130 c . unicoo . e   .(2,sdim). nom et unite des coordonnees au sens MED   .
 131 c . nbgrfm . e   .    1   . nombre de groupes                          .
 132 c . nomgro . e   .char*(*). noms des groupes (paquets de 10char8)      .
 133 c . lgnogr . e   . nbgrfm . longueur des noms des groupes              .
 134 c . famnum .  a  .   *    . famille : numero avec une valeur           .
 135 c . famval .  a  .   *    . famille : la valeur                        .
 136 c . lifagr .  a  .   *    . liste des familles contenant le groupe     .
 137 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
 138 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 139 c . langue . e   .    1   . langue des messages                        .
 140 c .        .     .        . 1 : francais, 2 : anglais                  .
 141 c . codret .  s  .    1   . code de retour des modules                 .
 142 c .        .     .        . 0 : pas de probleme                        .
 143 c .        .     .        . 1 : probleme                               .
 144 c .____________________________________________________________________.
 145 c
 146 c====
 147 c 0. declarations et dimensionnement
 148 c====
 149 c
 150 c 0.1. ==> generalites
 151 c
 152       implicit none
 153       save
 154 c
 155       character*6 nompro
 156       parameter ( nompro = 'UTB13A' )
 157 c
 158 #include "nblang.h"
 159 c
 160 c 0.2. ==> communs
 161 c
 162 #include "nbfami.h"
 163 #include "nombno.h"
 164 #include "nombar.h"
 165 #include "nombtr.h"
 166 #include "nombqu.h"
 167 #include "nombte.h"
 168 #include "nombhe.h"
 169 #include "nombpy.h"
 170 #include "nombpe.h"
 171 #include "envca1.h"
 172 c
 173 #include "dicfen.h"
 174 c
 175 c 0.3. ==> arguments
 176 c
 177       double precision coonoe(nbnoto,sdim)
 178 c
 179       integer somare(2,nbarto), hetare(nbarto)
 180       integer hettri(nbtrto), aretri(nbtrto,3)
 181       integer hetqua(nbquto), arequa(nbquto,4)
 182       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 183       integer hettet(nbteto)
 184       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 185       integer hethex(nbheto)
 186       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 187       integer hetpyr(nbpyto)
 188       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 189       integer hetpen(nbpeto)
 190 c
 191       integer famare(nbarto), cfaare(nctfar,nbfare)
 192       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 193       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 194       integer famtet(nbteto), cfatet(nctfte,nbftet)
 195       integer famhex(nbheto), cfahex(nctfhe,nbfhex)
 196       integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr)
 197       integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
 198 c
 199       integer nbfmed, numfam(nbfmed)
 200       integer grfmpo(0:nbfmed)
 201       integer grfmtl(*)
 202       integer nbgrfm, lgnogr(nbgrfm)
 203 c
 204       character*8 grfmtb(*)
 205       character*8 nomgro(*)
 206       character*16 unicoo(2,sdim)
 207 c
 208       integer famnum(*)
 209       double precision famval(*)
 210 c
 211       integer  lifagr(*)
 212 c
 213       integer ulbila
 214       integer ulsort, langue, codret
 215 c
 216 c 0.4. ==> variables locales
 217 c
 218       integer iaux
 219 c
 220       integer nbmess
 221       parameter (nbmess = 10 )
 222       character*80 texte(nblang,nbmess)
 223 c
 224 c 0.5. ==> initialisations
 225 c ______________________________________________________________________
 226 c
 227 c====
 228 c 1. messages
 229 c====
 230 c
 231 #include "impr01.h"
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       write (ulsort,texte(langue,1)) 'Entree', nompro
 235       call dmflsh (iaux)
 236 #endif
 237 c
 238       texte(1,4) =
 239      >'(//,3x,''TAILLES DES SOUS-DOMAINES DE CALCUL'',/,3x,35(''=''),/)'
 240       texte(1,5) =
 241      > '(/,10x,''Direction      |       Unite'',/,5x,41(''-''))'
 242       texte(1,6) = '(8x,a16,'' |  '',a16)'
 243 c
 244       texte(2,4) =
 245      > '(//,3x,''SIZES OF CALCULATION SUB-DOMAINS'',/,3x,32(''=''),/)'
 246       texte(2,5) =
 247      < '(/,10x,''Direction      |       Unit'',/,5x,41(''-''))'
 248       texte(2,6) = '(8x,a16,'' |  '',a16)'
 249 c
 250 #include "impr03.h"
 251 c
 252       codret = 0
 253 c
 254       write (ulbila,texte(langue,4))
 255 c
 256       write (ulbila,texte(langue,5))
 257       do 11 , iaux = 1 , sdim
 258         write (ulbila,texte(langue,6)) unicoo(1,iaux), unicoo(2,iaux)
 259    11 continue
 260 c
 261 c====
 262 c 2. volumes
 263 c====
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,90002) '2. volumes : codret', codret
 266 #endif
 267 c
 268       if ( nbteac.gt.0 .or. nbheac.gt.0 .or.
 269      >     nbpyac.gt.0 .or. nbpeac.gt.0 ) then
 270 c
 271 #ifdef _DEBUG_HOMARD_
 272       write (ulsort,texte(langue,3)) 'UTB13B', nompro
 273 #endif
 274         call utb13b ( coonoe,
 275      >                somare,
 276      >                aretri,
 277      >                arequa,
 278      >                tritet, cotrte, aretet, hettet,
 279      >                quahex, coquhe, arehex, hethex,
 280      >                facpyr, cofapy, arepyr, hetpyr,
 281      >                facpen, cofape, arepen, hetpen,
 282      >                famtet, cfatet,
 283      >                famhex, cfahex,
 284      >                fampyr, cfapyr,
 285      >                fampen, cfapen,
 286      >                nbfmed, numfam,
 287      >                grfmpo, grfmtl, grfmtb,
 288      >                nbgrfm, nomgro, lgnogr,
 289      >                famnum, famval,
 290      >                lifagr,
 291      >                ulbila,
 292      >                ulsort, langue, codret )
 293 c
 294       endif
 295 c
 296 c====
 297 c 3. surfaces
 298 c====
 299 #ifdef _DEBUG_HOMARD_
 300       write (ulsort,90002) '3. surfaces : codret', codret
 301 #endif
 302 c
 303       if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,3)) 'UTB13C', nompro
 307 #endif
 308         call utb13c ( coonoe,
 309      >                somare,
 310      >                hettri, aretri,
 311      >                hetqua, arequa,
 312      >                famtri, cfatri,
 313      >                famqua, cfaqua,
 314      >                nbfmed, numfam,
 315      >                grfmpo, grfmtl, grfmtb,
 316      >                nbgrfm, nomgro, lgnogr,
 317      >                famnum, famval,
 318      >                lifagr,
 319      >                ulbila,
 320      >                ulsort, langue, codret )
 321 c
 322 c
 323       endif
 324 c
 325 c====
 326 c 4. longueurs
 327 c====
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,90002) '4. longueurs : codret', codret
 330 #endif
 331 c
 332       if ( nbarac.gt.0 ) then
 333 c
 334 #ifdef _DEBUG_HOMARD_
 335       write (ulsort,texte(langue,3)) 'UTB13D', nompro
 336 #endif
 337         call utb13d ( coonoe,
 338      >                somare, hetare,
 339      >                famare, cfaare,
 340      >                nbfmed, numfam,
 341      >                grfmpo, grfmtl, grfmtb,
 342      >                nbgrfm, nomgro, lgnogr,
 343      >                famnum, famval,
 344      >                lifagr,
 345      >                ulbila,
 346      >                ulsort, langue, codret )
 347 c
 348       endif
 349 c
 350       end