src/tool/Utilitaire/utb17a.F

   1       subroutine utb17a ( hetare, somare, np2are,
   2      >                    posifa, facare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    hettet, tritet, cotrte, aretet,
   6      >                    hethex, quahex, coquhe, arehex,
   7      >                    hetpyr, facpyr, cofapy, arepyr,
   8      >                    hetpen, facpen, cofape, arepen,
   9      >                    voltri,
  10      >                    volqua,
  11      >                    famare, cfaare,
  12      >                    famtri, cfatri,
  13      >                    famqua, cfaqua,
  14      >                    tabaux,
  15      >                    ulbila,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  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
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c    UTilitaire - Bilan sur le maillage - option 17
  38 c    --           -                              --
  39 c ______________________________________________________________________
  40 c
  41 c diagnostic des elements du calcul
  42 c ______________________________________________________________________
  43 c .        .     .        .                                            .
  44 c .  nom   . e/s . taille .           description                      .
  45 c .____________________________________________________________________.
  46 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  47 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  48 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  49 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  50 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  51 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  52 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  53 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  54 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  55 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  56 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  57 c . cotrte . e   .nbtecf*4. codes des triangles des tetraedres         .
  58 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  59 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  60 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  61 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  62 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  63 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  64 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  65 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  66 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  67 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  68 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  69 c .        .     .        .   0 : pas de voisin                        .
  70 c .        .     .        . j>0 : tetraedre j                          .
  71 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  72 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  73 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  74 c .        .     .        .   0 : pas de voisin                        .
  75 c .        .     .        . j>0 : hexaedre j                           .
  76 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  77 c . famare . e   . nbarto . famille des aretes                         .
  78 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  79 c .        .     . nbfare .   1 : famille MED                          .
  80 c .        .     .        .   2 : type de segment                      .
  81 c .        .     .        .   3 : orientation                          .
  82 c .        .     .        .   4 : famille d'orientation inverse        .
  83 c .        .     .        .   5 : numero de ligne de frontiere         .
  84 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  85 c .        .     .        . <= 0 si non concernee                      .
  86 c .        .     .        .   6 : famille frontiere active/inactive    .
  87 c .        .     .        .   7 : numero de surface de frontiere       .
  88 c .        .     .        . + l : appartenance a l'equivalence l       .
  89 c . famtri . e   . nbtrto . famille des triangles                      .
  90 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  91 c .        .     . nbftri .   1 : famille MED                          .
  92 c .        .     .        .   2 : type de triangle                     .
  93 c .        .     .        .   3 : numero de surface de frontiere       .
  94 c .        .     .        .   4 : famille des aretes internes apres raf.
  95 c .        .     .        . + l : appartenance a l'equivalence l       .
  96 c . famqua . e   . nbquto . famille des quadrangles                    .
  97 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  98 c .        .     . nbfqua .   1 : famille MED                          .
  99 c .        .     .        .   2 : type de quadrangle                   .
 100 c .        .     .        .   3 : numero de surface de frontiere       .
 101 c .        .     .        .   4 : famille des aretes internes apres raf.
 102 c .        .     .        .   5 : famille des triangles de conformite  .
 103 c .        .     .        .   6 : famille de sf active/inactive        .
 104 c .        .     .        . + l : appartenance a l'equivalence l       .
 105 c . tabaux . a   . nbnoto . tableau auxiliaire                         .
 106 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
 107 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 108 c . langue . e   .    1   . langue des messages                        .
 109 c .        .     .        . 1 : francais, 2 : anglais                  .
 110 c . codret .  s  .    1   . code de retour des modules                 .
 111 c .        .     .        . 0 : pas de probleme                        .
 112 c .        .     .        . 1 : probleme                               .
 113 c .____________________________________________________________________.
 114 c
 115 c====
 116 c 0. declarations et dimensionnement
 117 c====
 118 c
 119 c 0.1. ==> generalites
 120 c
 121       implicit none
 122       save
 123 c
 124       character*6 nompro
 125       parameter ( nompro = 'UTB17A' )
 126 c
 127 #include "nblang.h"
 128 c
 129 c 0.2. ==> communs
 130 c
 131 #include "nbfami.h"
 132 #include "nombno.h"
 133 #include "nombar.h"
 134 #include "nombtr.h"
 135 #include "nombqu.h"
 136 #include "nombte.h"
 137 #include "nombhe.h"
 138 #include "nombpy.h"
 139 #include "nombpe.h"
 140 c
 141 #include "dicfen.h"
 142 c
 143 c 0.3. ==> arguments
 144 c
 145       integer hetare(nbarto), somare(2,nbarto), np2are(nbarto)
 146 c
 147       integer hettri(nbtrto), aretri(nbtrto,3)
 148       integer hetqua(nbquto), arequa(nbquto,4)
 149       integer hettet(nbteto)
 150       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 151       integer hethex(nbheto)
 152       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 153       integer hetpyr(nbpyto)
 154       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 155       integer hetpen(nbpeto)
 156       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 157 c
 158       integer posifa(0:nbarto), facare(nbfaar)
 159       integer volqua(2,nbquto)
 160       integer voltri(2,nbtrto)
 161 c
 162       integer famare(nbarto), cfaare(nctfar,nbfare)
 163       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 164       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 165 c
 166       integer tabaux(nbnoto)
 167 c
 168       integer ulbila
 169       integer ulsort, langue, codret
 170 c
 171 c 0.4. ==> variables locales
 172 c
 173       integer iaux
 174 c
 175       integer nbmess
 176       parameter (nbmess = 10 )
 177       character*80 texte(nblang,nbmess)
 178 c
 179 c 0.5. ==> initialisations
 180 c ______________________________________________________________________
 181 c
 182 c====
 183 c 1. messages
 184 c====
 185 c
 186 #include "impr01.h"
 187 c
 188 #ifdef _DEBUG_HOMARD_
 189       write (ulsort,texte(langue,1)) 'Entree', nompro
 190       call dmflsh (iaux)
 191 #endif
 192 c
 193       texte(1,4) =
 194      >'(//,3x,''DIAGNOSTICS SUR LES ELEMENTS DU CALCUL'',/,3x,38(''=''),
 195      >/)'
 196       texte(1,5) =
 197      > '(3x,''Un element est surcontraint si tous ses noeuds sont'')'
 198       texte(1,6) =
 199      > '(3x,''sur le bord du domaine. Cela peut poser un probleme'')'
 200       texte(1,7) =
 201      > '(3x,''selon les conditions aux limites utilisees.'')'
 202 c
 203       texte(2,4) =
 204      > '(//,3x,''DIAGNOSIS OF CALCULATION ELEMENTS'',/,3x,33(''=''),/)'
 205       texte(2,5) =
 206      > '(3x,''An element is overstressed if all its nodes are'')'
 207       texte(2,6) =
 208      > '(3x,''located on the boundary of the domain. It may give,'')'
 209       texte(2,7) =
 210      > '(3x,''problem depending on the used boundary conditions.'')'
 211 c
 212       codret = 0
 213 c
 214       do 11 , iaux = 4, 7
 215         write (ulbila,texte(langue,iaux))
 216    11 continue
 217 c
 218 c====
 219 c 2. Mailles surfaciques
 220 c====
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,*) '2. Mailles surfaciques : codret = ', codret
 223 #endif
 224 c
 225       if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then
 226 c
 227 c 2.1. ==> Reperage des noeuds de bord
 228 c
 229         if ( codret.eq.0 ) then
 230 c
 231         iaux = 1
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       write (ulsort,texte(langue,3)) 'UTB17D', nompro
 235 #endif
 236         call utb17d ( iaux,
 237      >                hetare, somare, np2are,
 238      >                posifa, facare,
 239      >                hettri, aretri, voltri,
 240      >                hetqua, arequa, volqua,
 241      >                tabaux,
 242      >                ulsort, langue, codret )
 243 c
 244         endif
 245 c
 246 c 2.2. ==> Calcul
 247 c
 248         if ( codret.eq.0 ) then
 249 c
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,texte(langue,3)) 'UTB17C', nompro
 252 #endif
 253         call utb17c ( somare, np2are,
 254      >                hettri, aretri,
 255      >                hetqua, arequa,
 256      >                voltri,
 257      >                volqua,
 258      >                posifa, facare,
 259      >                famare, cfaare,
 260      >                famtri, cfatri,
 261      >                famqua, cfaqua,
 262      >                tabaux,
 263      >                ulbila,
 264      >                ulsort, langue, codret )
 265 c
 266         endif
 267 c
 268       endif
 269 c
 270 c====
 271 c 3. Mailles volumiques
 272 c====
 273 #ifdef _DEBUG_HOMARD_
 274       write (ulsort,*) '3. Mailles volumiques : codret = ', codret
 275 #endif
 276 c
 277       if ( nbteac.gt.0 .or. nbheac.gt.0 .or.
 278      >     nbpyac.gt.0 .or. nbpeac.gt.0 ) then
 279 c
 280 c 3.1. ==> Reperage des noeuds de bord
 281 c
 282         if ( codret.eq.0 ) then
 283 c
 284         iaux = 2
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'UTB17D', nompro
 288 #endif
 289         call utb17d ( iaux,
 290      >                hetare, somare, np2are,
 291      >                posifa, facare,
 292      >                hettri, aretri, voltri,
 293      >                hetqua, arequa, volqua,
 294      >                tabaux,
 295      >                ulsort, langue, codret )
 296 c
 297         endif
 298 c
 299 c 3.2. ==> Calcul
 300 c
 301         if ( codret.eq.0 ) then
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,texte(langue,3)) 'UTB17B', nompro
 305 #endif
 306         call utb17b ( somare, np2are,
 307      >                aretri, voltri,
 308      >                famtri, cfatri,
 309      >                arequa, volqua,
 310      >                famqua, cfaqua,
 311      >                hettet, tritet, cotrte, aretet,
 312      >                hethex, quahex, coquhe, arehex,
 313      >                hetpyr, facpyr, cofapy, arepyr,
 314      >                hetpen, facpen, cofape, arepen,
 315      >                tabaux,
 316      >                ulbila,
 317      >                ulsort, langue, codret )
 318 c
 319         endif
 320 c
 321       endif
 322 c
 323       end