src/tool/Utilitaire/utal00.F

   1       subroutine utal00 ( option, optimp,
   2      >                    nomail, ndecar, ndecfa,
   3      >                    indnoe, indnp2, indnim, indare,
   4      >                    indtri, indqua,
   5      >                    indtet, indhex, indpen,
   6      >                    nbsoan, nbsono,
   7      >                    nbnoan, nbnono,
   8      >                    nbaran, nbarno,
   9      >                    nbtran, nbtrno,
  10      >                    nbquan, nbquno,
  11      >                    nbtean, nbteno,
  12      >                    nbhean, nbheno,
  13      >                    nbpean, nbpeno,
  14      >                    nbpyan, nbpyno,
  15      >                    ulsort, langue, codret )
  16 c ______________________________________________________________________
  17 c
  18 c                             H O M A R D
  19 c
  20 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  21 c
  22 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  23 c aupres des huissiers de justice Simart et Lavoir a Clamart
  24 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  25 c aupres des huissiers de justice
  26 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  27 c
  28 c    HOMARD est une marque deposee d'Electricite de France
  29 c
  30 c Copyright EDF 1996
  31 c Copyright EDF 1998
  32 c Copyright EDF 2002
  33 c Copyright EDF 2020
  34 c ______________________________________________________________________
  35 c
  36 c     UTilitaire : ALlocations - 00
  37 c     --           --            --
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . option . e   .    1   . type de traitement                         .
  43 c .        .     .        . 0 : raffinement                            .
  44 c .        .     .        . 1 : deraffinement                          .
  45 c .        .     .        . 2 : conformite                             .
  46 c . optimp . e   .   1    . impressions 0:non, 1:oui                   .
  47 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  48 c . ndecar . e   .  ch8   . nom de l'objet des decisions sur les aretes.
  49 c . ndecfa . e   .  ch8   . nom de l'objet des decisions sur les faces .
  50 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  51 c . indnp2 . es  .   1    . nombre de noeuds p2 en vigueur             .
  52 c . indnim . es  .   1    . nombre de noeuds internes en vigueur       .
  53 c . indare . es  .   1    . indice de la derniere arete creee          .
  54 c . indtri . es  .   1    . indice du dernier triangle cree            .
  55 c . indqua . es  .   1    . indice du dernier quadrangle cree          .
  56 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  57 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  58 c . indpen . es  .   1    . indice du dernier pentaedre cree           .
  59 c . nbsoan . s   .    1   . nombre de sommets - ancien                 .
  60 c . nbsono . s   .    1   . nombre de sommets - nouveau                .
  61 c . nbnoan . e   .    1   . nombre de noeuds - ancien                  .
  62 c . nbnono . e   .    1   . nombre de noeuds - nouveau                 .
  63 c . nbaran . e   .    1   . nombre d'aretes - ancien                   .
  64 c . nbarno . e   .    1   . nombre d'aretes - nouveau                  .
  65 c . nbtran . e   .    1   . nombre de triangles - ancien               .
  66 c . nbtrno . e   .    1   . nombre de triangles - nouveau              .
  67 c . nbquan . e   .    1   . nombre de quadrangles - ancien             .
  68 c . nbquno . e   .    1   . nombre de quadrangles - nouveau            .
  69 c . nbtean . e   .    1   . nombre de tetraedres - ancien              .
  70 c . nbteno . e   .    1   . nombre de tetraedres - nouveau             .
  71 c . nbhean . e   .    1   . nombre d'hexaedres - ancien                .
  72 c . nbheno . e   .    1   . nombre d'hexaedres - nouveau               .
  73 c . nbpean . e   .    1   . nombre de pentaedres - ancien              .
  74 c . nbpeno . e   .    1   . nombre de pentaedres - nouveau             .
  75 c . nbpyan . e   .    1   . nombre de pyramides - ancien               .
  76 c . nbpyno . e   .    1   . nombre de pyramides - nouveau              .
  77 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  78 c . langue . e   .   1    . langue des messages                        .
  79 c .        .     .        . 1 : francais, 2 : anglais                  .
  80 c . codret . e/s .   1    . code de retour des modules                 .
  81 c .        .     .        . 0 : pas de probleme                        .
  82 c ______________________________________________________________________
  83 c
  84 c====
  85 c 0. declarations et dimensionnement
  86 c====
  87 c
  88 c 0.1. ==> generalites
  89 c
  90       implicit none
  91       save
  92 c
  93       character*6 nompro
  94       parameter ( nompro = 'UTAL00' )
  95 c
  96 #include "nblang.h"
  97 c
  98 c 0.2. ==> communs
  99 c
 100 #include "envex1.h"
 101 #include "envca1.h"
 102 #include "gmenti.h"
 103 c
 104 c 0.3. ==> arguments
 105 c
 106       integer option
 107       integer optimp
 108 c
 109       character*8 nomail
 110       character*8 ndecar, ndecfa
 111 c
 112       integer indnoe, indnp2, indnim, indare, indtri, indqua
 113       integer indtet, indhex, indpen
 114       integer nbsoan, nbsono
 115       integer nbnoan, nbnono
 116       integer nbaran, nbarno
 117       integer nbtran, nbtrno
 118       integer nbquan, nbquno
 119       integer nbtean, nbteno
 120       integer nbhean, nbheno
 121       integer nbpean, nbpeno
 122       integer nbpyan, nbpyno
 123 c
 124       integer ulsort, langue, codret
 125 c
 126 c 0.4. ==> variables locales
 127 c
 128       integer iaux, jaux
 129 c
 130       integer codre0
 131       integer codre1, codre2, codre3
 132       integer pdecfa, pdecar
 133       integer phettr, paretr
 134       integer phetqu, parequ
 135       integer phette, ptrite
 136       integer phethe, pquahe
 137       integer phetpe, pfacpe
 138 cgn      integer phetpy, pfacpy
 139 c
 140       character*8 norenu
 141       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 142       character*8 nhtetr, nhhexa, nhpyra, nhpent
 143       character*8 nhelig
 144       character*8 nhvois, nhsupe, nhsups
 145 c
 146       integer nbmess
 147       parameter ( nbmess = 10 )
 148       character*80 texte(nblang,nbmess)
 149 c
 150 c 0.5. ==> initialisations
 151 c ______________________________________________________________________
 152 c
 153 c====
 154 c 1. initialisations
 155 c====
 156 c
 157 #include "impr01.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,texte(langue,1)) 'Entree', nompro
 161       call dmflsh (iaux)
 162 #endif
 163 c
 164 #include "impr03.h"
 165 c
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,90002) 'option', option
 168 #endif
 169 c
 170 c====
 171 c 2. recuperation des pointeurs
 172 c====
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 178 #endif
 179 c
 180       call utnomh ( nomail,
 181      >                sdim,   mdim,
 182      >               degre, maconf, homolo, hierar,
 183      >              rafdef, nbmane, typcca, typsfr, maextr,
 184      >              mailet,
 185      >              norenu,
 186      >              nhnoeu, nhmapo, nharet,
 187      >              nhtria, nhquad,
 188      >              nhtetr, nhhexa, nhpyra, nhpent,
 189      >              nhelig,
 190      >              nhvois, nhsupe, nhsups,
 191      >              ulsort, langue, codret)
 192 c
 193       endif
 194 c
 195 c====
 196 c 3. recuperation des adresses
 197 c====
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,90002) '3. recuperation ; codret', codret
 200 #endif
 201 c
 202       if ( option.eq.0 ) then
 203 c
 204 c 3.1. ==> Quelques nombres
 205 c
 206       if ( codret.eq.0 ) then
 207 c
 208       call gmliat ( nhtetr, 1, nbtean, codre1 )
 209       call gmliat ( nhhexa, 1, nbhean, codre2 )
 210       call gmliat ( nhpent, 1, nbpean, codre3 )
 211 c
 212       codre0 = min ( codre1, codre2, codre3 )
 213       codret = max ( abs(codre0), codret,
 214      >               codre1, codre2, codre3 )
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,90002) 'nbtean', nbtean
 218       write (ulsort,90002) 'nbhean', nbhean
 219       write (ulsort,90002) 'nbpean', nbpean
 220 #endif
 221 c
 222       endif
 223 c
 224 c 3.2. ==> Adresses
 225 c
 226       if ( codret.eq.0 ) then
 227 c
 228       if ( nbtean.ne.0 .or. nbpean.ne.0 ) then
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 232 #endif
 233         iaux = 2
 234         call utad02 ( iaux, nhtria,
 235      >                phettr, paretr, jaux, jaux,
 236      >                  jaux,   jaux,   jaux,
 237      >                  jaux,   jaux,   jaux,
 238      >                  jaux,   jaux,   jaux,
 239      >                ulsort, langue, codret )
 240 c
 241       endif
 242 c
 243       if ( nbhean.ne.0 .or. nbpean.ne.0 ) then
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 247 #endif
 248         iaux = 2
 249         call utad02 ( iaux, nhquad,
 250      >                phetqu, parequ, jaux, jaux,
 251      >                  jaux,   jaux,   jaux,
 252      >                  jaux,   jaux,   jaux,
 253      >                  jaux,   jaux,   jaux,
 254      >                ulsort, langue, codret )
 255 c
 256       endif
 257 c
 258       if ( nbtean.ne.0 ) then
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 262 #endif
 263         iaux = 2
 264         call utad02 ( iaux, nhtetr,
 265      >                phette, ptrite, jaux, jaux,
 266      >                  jaux,   jaux,   jaux,
 267      >                  jaux,   jaux,   jaux,
 268      >                  jaux,   jaux,   jaux,
 269      >                ulsort, langue, codret )
 270 c
 271       endif
 272 c
 273       if ( nbhean.ne.0 ) then
 274 c
 275 #ifdef _DEBUG_HOMARD_
 276       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 277 #endif
 278         iaux = 2
 279         call utad02 ( iaux, nhhexa,
 280      >                phethe, pquahe, jaux, jaux,
 281      >                  jaux,   jaux,   jaux,
 282      >                  jaux,   jaux,   jaux,
 283      >                  jaux,   jaux,   jaux,
 284      >                ulsort, langue, codret )
 285 c
 286       endif
 287 c
 288       if ( nbpean.ne.0 ) then
 289 c
 290 #ifdef _DEBUG_HOMARD_
 291       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 292 #endif
 293         iaux = 2
 294         call utad02 ( iaux, nhpent,
 295      >                phetpe, pfacpe, jaux, jaux,
 296      >                  jaux,   jaux,   jaux,
 297      >                  jaux,   jaux,   jaux,
 298      >                  jaux,   jaux,   jaux,
 299      >                ulsort, langue, codret )
 300 c
 301       endif
 302 c
 303       endif
 304 c
 305 c 3.3. ==> Decisions
 306 c
 307       if ( codret.eq.0 ) then
 308 c
 309       call gmadoj ( ndecar, pdecar, iaux, codre1 )
 310       call gmadoj ( ndecfa, pdecfa, iaux, codre2 )
 311 c
 312       codre0 = min ( codre1, codre2 )
 313       codret = max ( abs(codre0), codret,
 314      >               codre1, codre2 )
 315 c
 316       endif
 317 c
 318       else
 319 c
 320         write (ulsort,*) 'Arret dans ', nompro
 321         stop
 322 c
 323       endif
 324 c
 325 c====
 326 c 4. decompte des nouvelles entites a creer
 327 c====
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,90002) '4. decompte ; codret', codret
 330 #endif
 331 c
 332       if ( option.eq.0 ) then
 333 c
 334       if ( codret.eq.0 ) then
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'UTPLRA', nompro
 338 #endif
 339 c
 340       call utplra ( optimp,
 341      >              indnoe, indnp2, indnim, indare,
 342      >              indtri, indqua, indtet, indhex, indpen,
 343      >              imem(pdecar), imem(pdecfa),
 344      >              imem(phettr),
 345      >              imem(phetqu),
 346      >              imem(ptrite), imem(phette),
 347      >              imem(pquahe), imem(phethe),
 348      >              imem(pfacpe), imem(phetpe),
 349      >              nbsoan, nbsono,
 350      >              nbnoan, nbnono,
 351      >              nbaran, nbarno,
 352      >              nbtran, nbtrno,
 353      >              nbquan, nbquno,
 354      >              nbtean, nbteno,
 355      >              nbhean, nbheno,
 356      >              nbpean, nbpeno,
 357      >              nbpyan, nbpyno,
 358      >              ulsort, langue, codret )
 359 c
 360       endif
 361 c
 362       endif
 363 c
 364 c====
 365 c 5. la fin
 366 c====
 367 c
 368       if ( codret.ne.0 ) then
 369 c
 370 #include "envex2.h"
 371 c
 372       write (ulsort,texte(langue,1)) 'Sortie', nompro
 373       write (ulsort,texte(langue,2)) codret
 374 c
 375       endif
 376 c
 377 #ifdef _DEBUG_HOMARD_
 378       write (ulsort,texte(langue,1)) 'Sortie', nompro
 379       call dmflsh (iaux)
 380 #endif
 381 c
 382       end