src/tool/Utilitaire/utnomh.F

   1       subroutine utnomh ( nomail,
   2      >                      sdim,   mdim,
   3      >                     degre, maconf, homolo, hierar,
   4      >                    rafdef, nbmane, typcca, typsfr, maextr,
   5      >                    mailet,
   6      >                    norenu,
   7      >                    nhnoeu, nhmapo, nharet,
   8      >                    nhtria, nhquad,
   9      >                    nhtetr, nhhexa, nhpyra, nhpent,
  10      >                    nhelig,
  11      >                    nhvois, nhsupe, nhsups,
  12      >                    ulsort, langue, codret)
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  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
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    UTilitaire - Nom des Objets du Maillage HOMARD
  34 c    --           -       -         -        -
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . nomail . e   . char8  . nom de l'objet maillage homard             .
  40 c . sdim   .  s  .    1   . dimension de l'espace                      .
  41 c . mdim   .  s  .    1   . dimension du maillage                      .
  42 c . degre  .  s  .    1   . degre du maillage                          .
  43 c . maconf .  s  .    1   . conformite du maillage                     .
  44 c .        .     .        .  0 : oui                                   .
  45 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  46 c .        .     .        .      non decoupees en 2 par face           .
  47 c .        .     .        .  2 : non-conforme avec 1 seul noeud pendant.
  48 c .        .     .        .      par arete                             .
  49 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  50 c .        .     .        . -1 : conforme, avec des boites pour les    .
  51 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  52 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  53 c .        .     .        .      decoupee en 2 et des boites pour les  .
  54 c .        .     .        .       quadrangles, hexaedres et pentaedres .
  55 c .        .     .        . 10 : non-conforme sans autre connaissance  .
  56 c . homolo .  s  .    1   . type de relations par homologues           .
  57 c .        .     .        . 0 : pas d'homologues                       .
  58 c .        .     .        . 1 : relations sur les noeuds               .
  59 c .        .     .        . 2 : relations sur les noeuds et les aretes .
  60 c .        .     .        . 3 : relations sur les noeuds, les aretes   .
  61 c .        .     .        .     et les triangles                       .
  62 c . hierar .  s  .    1   . maillage hierarchique                      .
  63 c .        .     .        . 0 : non                                    .
  64 c .        .     .        . 1 : oui                                    .
  65 c . rafdef .  s  .    1   . 0 : macro-maillage                         .
  66 c .        .     .        . 1 : le maillage est inchange               .
  67 c .        .     .        . 2 : le maillage est issu du raffinement pur.
  68 c .        .     .        .     d'un autre maillage                    .
  69 c .        .     .        . 3 : le maillage est issu du deraffinement  .
  70 c .        .     .        .     pur d'un autre maillage                .
  71 c .        .     .        . 4 : le maillage est issu de raffinement et .
  72 c .        .     .        .     de deraffinement d'un autre maillage   .
  73 c .        .     .        . 12 : le maillage est un maillage passe de  .
  74 c .        .     .        .      degre 1 a 2                           .
  75 c .        .     .        . 21 : le maillage est un maillage passe de  .
  76 c .        .     .        .      degre 2 a 1                           .
  77 c . nbmane .  s  .    1   . nombre maximum de noeuds par element       .
  78 c . typcca .  s  .   1    . type du code de calcul                     .
  79 c . typsfr .  s  .   1    . type du suivi de frontiere                 .
  80 c .        .     .        . 0 : aucun                                  .
  81 c .        .     .        . 1 : maillage de degre 1, avec projection   .
  82 c .        .     .        .     des nouveaux sommets                   .
  83 c .        .     .        . 2 : maillage de degre 2, seuls les noeuds  .
  84 c .        .     .        .     P1 sont sur la frontiere ; les noeuds  .
  85 c .        .     .        .     P2 restent au milieu des P1            .
  86 c .        .     .        . 3 : maillage de degre 2, les noeuds P2     .
  87 c .        .     .        .     etant sur la frontiere                 .
  88 c . maextr .  s  .   1    . maillage extrude                           .
  89 c .        .     .        . 0 : non                                    .
  90 c .        .     .        . 1 : selon X                                .
  91 c .        .     .        . 2 : selon Y                                .
  92 c .        .     .        . 3 : selon Z (cas de Saturne ou Neptune)    .
  93 c . mailet .  s  .    1   . presence de mailles etendues               .
  94 c .        .     .        .  1 : aucune                                .
  95 c .        .     .        . 2x : TRIA7                                 .
  96 c .        .     .        . 3x : QUAD9                                 .
  97 c .        .     .        . 5x : HEXA27                                .
  98 c . norenu .  s  . char8  . nom de la branche RenuMail                 .
  99 c . nhnoeu .  s  . char8  . nom de l'objet decrivant les noeuds        .
 100 c . nhmapo .  s  . char8  . nom de l'objet decrivant les mailles-points.
 101 c . nharet .  s  . char8  . nom de l'objet decrivant les aretes        .
 102 c . nhtria .  s  . char8  . nom de l'objet decrivant les triangles     .
 103 c . nhquad .  s  . char8  . nom de l'objet decrivant les quadrangles   .
 104 c . nhtetr .  s  . char8  . nom de l'objet decrivant les tetraedres    .
 105 c . nhhexa .  s  . char8  . nom de l'objet decrivant les hexaedres     .
 106 c . nhpyra .  s  . char8  . nom de l'objet decrivant les pyramides     .
 107 c . nhpent .  s  . char8  . nom de l'objet decrivant les pentaedres    .
 108 c . nhelig .  s  . char8  . nom de l'objet decrivant les ignores       .
 109 c . nhvois .   s . char8  . nom de la branche Voisins                  .
 110 c . nhsupe .  s  . char8  . informations supplementaires entieres      .
 111 c . nhsups .  s  . char8  . informations supplementaires caracteres 8  .
 112 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 113 c . langue . e   .    1   . langue des messages                        .
 114 c .        .     .        . 1 : francais, 2 : anglais                  .
 115 c . codret . es  .    1   . code de retour des modules                 .
 116 c .        .     .        . 0 : pas de probleme                        .
 117 c .        .     .        . 1 : probleme                               .
 118 c ______________________________________________________________________
 119 c
 120 c====
 121 c 0. declarations et dimensionnement
 122 c====
 123 c
 124 c 0.1. ==> generalites
 125 c
 126       implicit none
 127       save
 128 c
 129       character*6 nompro
 130       parameter ( nompro = 'UTNOMH' )
 131 c
 132 #include "nblang.h"
 133 #include "consts.h"
 134 c
 135 c 0.2. ==> communs
 136 c
 137 #include "envex1.h"
 138 c
 139 c 0.3. ==> arguments
 140 c
 141       character*8 nomail
 142 c
 143       character*8 norenu
 144       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 145       character*8 nhtetr, nhhexa, nhpyra, nhpent
 146       character*8 nhelig
 147       character*8 nhvois, nhsupe, nhsups
 148 c
 149       integer   sdim,   mdim
 150       integer  degre, maconf, homolo, hierar
 151       integer rafdef, nbmane, typcca, typsfr, maextr
 152       integer mailet
 153 c
 154       integer ulsort, langue, codret
 155 c
 156 c 0.4. ==> variables locales
 157 c
 158       integer iaux, jaux, kaux
 159       integer codre1, codre2, codre3, codre4, codre5
 160       integer codre0
 161 c
 162       character*4 saux02(3,2)
 163       character*8 saux08
 164       character*80 saux80
 165 c
 166       integer nbmess
 167       parameter ( nbmess = 10 )
 168       character*80 texte(nblang,nbmess)
 169 c
 170 c 0.5. ==> initialisations
 171 c ______________________________________________________________________
 172 c
 173 c====
 174 c 1. messages
 175 c====
 176 c
 177 #include "impr01.h"
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,1)) 'Entree', nompro
 181       call dmflsh (iaux)
 182 #endif
 183 c
 184       texte(1,4) = '(''Noms des objets du maillage : '',a)'
 185       texte(1,5) = '(''.. L''''objet n''''est pas alloue.'')'
 186       texte(1,6) = '(''.. L''''objet est un objet simple !'')'
 187       texte(1,7) = '(''.. L''''objet a un nom bizarre.'')'
 188       texte(1,8) = '(''Une branche est indefinie.'')'
 189 c
 190       texte(2,4) = '(''Names oj objects for mesh : '',a)'
 191       texte(2,5) = '(''.. The object is not allocated.'')'
 192       texte(2,6) = '(''.. The object is a simple object.'')'
 193       texte(2,7) = '(''.. The object name is strange.'')'
 194       texte(2,8) = '(''A branch is undefined.'')'
 195 c
 196 #include "impr03.h"
 197 c
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,4)) nomail
 200       call gmprsx (nompro, nomail )
 201       call gmprsx (nompro, nomail//'.RenuMail' )
 202       call gmprsx (nompro, nomail//'.Noeud' )
 203       call gmprsx (nompro, nomail//'.Arete' )
 204       call gmprsx (nompro, nomail//'.Face' )
 205       call gmprsx (nompro, nomail//'.Volume' )
 206 #endif
 207 c
 208 c====
 209 c 2. recuperation des donnees du maillage
 210 c====
 211 c
 212 c 2.1. ==> l'objet existe-t-il vraiment ?
 213 c
 214       call gmobal ( nomail, codret )
 215 c
 216       if ( codret.eq.1 ) then
 217 c
 218         codret = 0
 219 c
 220       else
 221 c
 222         write (ulsort,texte(langue,4)) nomail
 223 c
 224         if ( codret.eq.0 ) then
 225           write (ulsort,texte(langue,5))
 226 c
 227         elseif ( codret.eq.2 ) then
 228           write (ulsort,texte(langue,6))
 229 c
 230         else
 231           write (ulsort,texte(langue,7))
 232 c
 233         endif
 234 c
 235         codret = 1
 236 c
 237       endif
 238 c
 239 c 2.2. ==> caracteristiques de base
 240 c
 241       if ( codret.eq.0 ) then
 242 c
 243       call gmliat ( nomail, 1, sdim  , codre1 )
 244       call gmliat ( nomail, 2, mdim  , codre2 )
 245       call gmliat ( nomail, 3, degre , codre3 )
 246       call gmliat ( nomail, 4, maconf, codre4 )
 247       call gmliat ( nomail, 5, homolo, codre5 )
 248 c
 249       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 250       codret = max ( abs(codre0), codret,
 251      >               codre1, codre2, codre3, codre4, codre5 )
 252 c
 253       call gmliat ( nomail, 6, hierar, codre1 )
 254       call gmliat ( nomail, 7, rafdef, codre2 )
 255       call gmliat ( nomail, 8, nbmane, codre3 )
 256       call gmliat ( nomail, 9, typcca, codre4 )
 257 c
 258       codre0 = min ( codre1, codre2, codre3, codre4 )
 259       codret = max ( abs(codre0), codret,
 260      >               codre1, codre2, codre3, codre4 )
 261 c
 262       call gmliat ( nomail,10, typsfr, codre1 )
 263       call gmliat ( nomail,11, maextr, codre2 )
 264 c
 265       codre0 = min ( codre1, codre2 )
 266       codret = max ( abs(codre0), codret,
 267      >               codre1, codre2 )
 268 c
 269       endif
 270 c
 271 c 2.3. ==> noms des branches
 272 c
 273 c    le code de retour de gmnomc est :
 274 c      0 : tout va bien
 275 c     -1 : l'objet n'est pas defini ; dans ce cas, le nom est "Indefini"
 276 c     -3 : le nom etendu est invalide
 277 c
 278 c    Ici, on tolere le retour -1, car selon les endroits, les branches
 279 c    ne sont pas toutes definies.
 280 c    En revanche, le -3 est une vraie erreur car c'est que le nom
 281 c    de l'objet maillage est mauvais.
 282 c
 283 c    Consequence : Il faut cumuler le codret et le tester seulement
 284 c                  a la fin du 2.3
 285 c
 286       if ( codret.eq.0 ) then
 287 c
 288 c 2.3.1 ==> Renumerotations et noeuds
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,*) nompro//' 2.3.1 Renum etc. ; codret = ', codret
 291 #endif
 292 c
 293       call gmnomc ( nomail//'.RenuMail', norenu, codre1 )
 294       call gmnomc ( nomail//'.Noeud'   , nhnoeu, codre2 )
 295 c
 296       codre0 = min ( codre1, codre2 )
 297       codret = max ( abs(codre0), codret,
 298      >               codre1, codre2 )
 299 c
 300 c 2.3.2 ==> Aretes, tetraedres, pyramides et pentaedres
 301 #ifdef _DEBUG_HOMARD_
 302       write (ulsort,*) nompro//' 2.3.2 Are etc. ; codret = ', codret
 303 #endif
 304 c
 305 cgn      call gmprsx ('nomail.Face dans '//nompro, nomail//'.Face')
 306 cgn      call gmprsx ('nomail.Volume dans '//nompro, nomail//'.Volume')
 307       if ( degre.eq.1 ) then
 308         call gmnomc ( nomail//'.Arete.HOM_Se02' , nharet, codre1 )
 309         call gmnomc ( nomail//'.Volume.HOM_Te04', nhtetr, codre2 )
 310         call gmnomc ( nomail//'.Volume.HOM_Py05', nhpyra, codre3 )
 311         call gmnomc ( nomail//'.Volume.HOM_Pe06', nhpent, codre4 )
 312       else
 313         call gmnomc ( nomail//'.Arete.HOM_Se03' , nharet, codre1 )
 314         call gmnomc ( nomail//'.Volume.HOM_Te10', nhtetr, codre2 )
 315         call gmnomc ( nomail//'.Volume.HOM_Py13', nhpyra, codre3 )
 316         call gmnomc ( nomail//'.Volume.HOM_Pe15', nhpent, codre4 )
 317       endif
 318 c
 319       codre0 = min ( codre1, codre2, codre3, codre4 )
 320       codret = max ( abs(codre0), codret,
 321      >               codre1, codre2, codre3, codre4 )
 322 c
 323 c 2.3.3 ==> Triangles, quadrangles et hexaedres : eventuellement etendu
 324 #ifdef _DEBUG_HOMARD_
 325       write (ulsort,*) nompro//' 2.3.3 Tri etc. ; codret = ', codret
 326 #endif
 327 c
 328       mailet = 1
 329 c
 330       if ( degre.eq.1 ) then
 331 c
 332         call gmnomc ( nomail//'.Face.HOM_Tr03'  , nhtria, codre1 )
 333         call gmnomc ( nomail//'.Face.HOM_Qu04'  , nhquad, codre2 )
 334         call gmnomc ( nomail//'.Volume.HOM_He08', nhhexa, codre3 )
 335 c
 336         codre0 = min ( codre1, codre2, codre3 )
 337         codret = max ( abs(codre0), codret,
 338      >                 codre1, codre2, codre3 )
 339 c
 340       else
 341 c
 342 cgn            call gmprsx ( nompro, nomail//'.Face' )
 343 cgn            call gmprsx ( nompro, nomail//'.Volume' )
 344         saux02(1,1) = 'Tr06'
 345         saux02(1,2) = 'Tr07'
 346         saux02(2,1) = 'Qu08'
 347         saux02(2,2) = 'Qu09'
 348         saux02(3,1) = 'He20'
 349         saux02(3,2) = 'He27'
 350 c
 351         do 233 , iaux = 1 , 3
 352 c
 353           saux80 = blan80
 354           if ( iaux.le.2 ) then
 355             kaux = 8 + 10
 356             saux80(1:kaux) = nomail//'.Face.HOM_'
 357           else
 358             kaux = 8 + 12
 359             saux80(1:kaux) = nomail//'.Volume.HOM_'
 360           endif
 361           do 2331 , jaux = 1 , 2
 362 c
 363             saux80(kaux+1:kaux+4) = saux02(iaux,jaux)
 364             call gmobal ( saux80 , codre0 )
 365 cgn        write(ulsort,90002) 'gmobal pour '//saux80(1:kaux+4),codre0
 366             if ( codre0.eq.0 ) then
 367               goto 2331
 368             elseif ( codre0.eq.1 ) then
 369               call gmnomc ( saux80 , saux08, codre1 )
 370               if ( codre1.eq.0 ) then
 371 cgn             write(ulsort,90003) 'nom de '//saux80(1:kaux+4), saux08
 372                 if ( iaux.eq.1 ) then
 373                   nhtria = saux08
 374                   if ( jaux.eq.2 ) then
 375                     mailet = mailet*2
 376                   endif
 377                 elseif ( iaux.eq.2 ) then
 378                   nhquad = saux08
 379                   if ( jaux.eq.2 ) then
 380                     mailet = mailet*3
 381                   endif
 382                 else
 383                   nhhexa = saux08
 384                   if ( jaux.eq.2 ) then
 385                     mailet = mailet*5
 386                   endif
 387                 endif
 388                 goto 233
 389               else
 390                 codret = 1
 391               endif
 392             else
 393               codret = 1
 394             endif
 395 c
 396  2331     continue
 397 c
 398   233   continue
 399 #ifdef _DEBUG_HOMARD_
 400         write(ulsort,90002) 'mailet' , mailet
 401         write(ulsort,90003) 'nhtria' , nhtria
 402         write(ulsort,90003) 'nhquad' , nhquad
 403         write(ulsort,90003) 'nhhexa' , nhhexa
 404 #endif
 405 c
 406       endif
 407 c
 408 c 2.3.4 ==> Voisinages et autres
 409 #ifdef _DEBUG_HOMARD_
 410       write (ulsort,*) nompro//' 2.3.4 Voisinages ; codret = ', codret
 411 #endif
 412 c
 413       call gmnomc ( nomail//'.Voisins' , nhvois, codre1 )
 414       call gmnomc ( nomail//'.Ma_Point', nhmapo, codre2 )
 415       call gmnomc ( nomail//'.ElemIgno', nhelig, codre3 )
 416 c
 417       codre0 = min ( codre1, codre2, codre3 )
 418       codret = max ( abs(codre0), codret,
 419      >               codre1, codre2, codre3 )
 420 c
 421       call gmnomc ( nomail//'.InfoSupE', nhsupe, codre1 )
 422       call gmnomc ( nomail//'.InfoSupS', nhsups, codre2 )
 423 c
 424       codre0 = min ( codre1, codre2 )
 425       codret = max ( abs(codre0), codret,
 426      >               codre1, codre2 )
 427 c
 428 c 2.3.5 ==> Corrections du code de retour
 429 #ifdef _DEBUG_HOMARD_
 430       write (ulsort,*) nompro//' 2.3.5 correction ; codret = ', codret
 431 #endif
 432 c
 433       if ( codret.eq.1 ) then
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436         write (ulsort,texte(langue,1)) 'Sortie', nompro
 437         write (ulsort,texte(langue,8))
 438 #endif
 439         codret = 0
 440 c
 441       endif
 442 c
 443       endif
 444 c
 445 c====
 446 c 3. la fin
 447 c====
 448 c
 449       if ( codret.ne.0 ) then
 450 c
 451 #include "envex2.h"
 452 c
 453       write (ulsort,texte(langue,1)) 'Sortie', nompro
 454       write (ulsort,texte(langue,2)) codret
 455 c
 456       endif
 457 c
 458 #ifdef _DEBUG_HOMARD_
 459       write (ulsort,texte(langue,1)) 'Sortie', nompro
 460       call dmflsh (iaux)
 461 #endif
 462 c
 463       end