src/tool/Utilitaire/utal02.F

   1       subroutine utal02 ( typenh, option,
   2      >                    nhenti, nbento, nbenca,
   3      >                    adhist, adcode, adfill, admere,
   4      >                    adfami, adcofa,
   5      >                    adnivo, adinsu, adins2,
   6      >                    adnoim, adhomo, adcoar,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    UTilitaire - ALlocations - phase 02
  29 c    --           --                  --
  30 c ______________________________________________________________________
  31 c   Allocations des tableaux pour une entite HOM_Enti
  32 c   Remarque : le code de retour en entree ne doit pas etre ecrase
  33 c              brutalement ; il doit etre cumule avec les operations
  34 c              de ce programme
  35 c   Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . typenh . e   .   1    . code des entites au sens homard            .
  41 c .        .     .        .  -1 : noeuds                               .
  42 c .        .     .        .   0 : mailles-points                       .
  43 c .        .     .        .   1 : segments                             .
  44 c .        .     .        .   2 : triangles                            .
  45 c .        .     .        .   3 : tetraedres                           .
  46 c .        .     .        .   4 : quadrangles                          .
  47 c .        .     .        .   5 : pyramides                            .
  48 c .        .     .        .   6 : hexaedres                            .
  49 c .        .     .        .   7 : pentaedres                           .
  50 c . option . e   .   1    . option de pilotage des allocations a faire .
  51 c .        .     .        . c'est un multiple des entiers suivants :   .
  52 c .        .     .        .  2 : historique, connectivite descendante  .
  53 c .        .     .        .  3 : fille                                 .
  54 c .        .     .        .  5 : mere                                  .
  55 c .        .     .        .  7 : fami                                  .
  56 c .        .     .        . 11 : nivo                                  .
  57 c .        .     .        . 13 : isup                                  .
  58 c .        .     .        . 17 : isup2                                 .
  59 c .        .     .        . 19 : noeud interne a la maille             .
  60 c .        .     .        . 29 : homologue                             .
  61 c . nhenti . e   . char8  . nom de l'objet decrivant l'entite          .
  62 c . nbento . e   .    1   . nombre d'entites                           .
  63 c . nbenca . e   .    1   . nombre d'entites en connectivite par arete .
  64 c . adhist .  s  .  1     . historique de l'etat                       .
  65 c . adcode .  s  .  1     . connectivite descendante                   .
  66 c . adfill .  s  .  1     . fille des entites                          .
  67 c . admere .  s  .  1     . mere des entites                           .
  68 c . adfami .  s  .  1     . famille des entites                        .
  69 c . adcofa .  s  .  1     . code des familles des entites              .
  70 c . adnivo .  s  .  1     . niveau des entites                         .
  71 c . adinsu .  s  .  1     . informations supplementaires               .
  72 c . adins2 .  s  .  1     . informations supplementaires numero 2      .
  73 c . adnoim .  s  .  1     . noeud interne a la maille                  .
  74 c . adhomo .  s  .  1     . homologue                                  .
  75 c . adcoar .  s   .  1    . connectivite par arete                     .
  76 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  77 c . langue . e   .    1   . langue des messages                        .
  78 c .        .     .        . 1 : francais, 2 : anglais                  .
  79 c . codret . es  .    1   . code de retour des modules                 .
  80 c ______________________________________________________________________
  81 c
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'UTAL02' )
  93 c
  94 #include "nblang.h"
  95 c
  96 c 0.2. ==> communs
  97 c
  98 #include "envex1.h"
  99 #include "impr02.h"
 100 #include "indefi.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       character*8 nhenti
 105 c
 106       integer typenh, option
 107       integer nbento, nbenca
 108       integer adhist, adcode, adfill, admere
 109       integer adfami, adcofa
 110       integer adnivo
 111       integer adinsu
 112       integer adins2
 113       integer adnoim
 114       integer adhomo
 115       integer adcoar
 116 c
 117       integer ulsort, langue, codret
 118 c
 119 c 0.4. ==> variables locales
 120 c
 121       integer iaux, jaux
 122       integer codava
 123       integer codre0
 124       integer codre1, codre2
 125       integer tabcod(0:12)
 126 c
 127       integer nbmess
 128       parameter ( nbmess = 10 )
 129       character*80 texte(nblang,nbmess)
 130 c
 131 c 0.5. ==> initialisations
 132 c ______________________________________________________________________
 133 c
 134 c====
 135 c 1. messages
 136 c====
 137 c
 138 #include "impr01.h"
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,1)) 'Entree', nompro
 142       call dmflsh (iaux)
 143 #endif
 144 c
 145       texte(1,4) = '(''Allocations pour les '',a)'
 146       texte(1,6) = '(''Structure : '',a)'
 147       texte(1,8) = '(''Codes de retour'',20i3)'
 148 c
 149       texte(2,4) = '(''Allocations for '',a)'
 150       texte(2,6) = '(''Structure: '',a)'
 151       texte(2,8) = '(''Error codes'',20i3)'
 152 c
 153 #include "impr03.h"
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 157       write (ulsort,90002) 'option', option
 158       write (ulsort,90002) 'nbento', nbento
 159       write (ulsort,90002) 'nbenca', nbenca
 160 cgn      call gmprsx(nompro,nhenti)
 161 cgn      call gmprsx(nompro,nhenti//'.Famille')
 162       call dmflsh (iaux)
 163 #endif
 164 c
 165       do 10 , iaux = 0 , 12
 166         tabcod(iaux) = 0
 167    10 continue
 168 c
 169       adcofa = iindef
 170       adhist = iindef
 171       adcode = iindef
 172       adfill = iindef
 173       admere = iindef
 174       adfami = iindef
 175       adcofa = iindef
 176       adnivo = iindef
 177       adinsu = iindef
 178       adins2 = iindef
 179       adnoim = iindef
 180       adhomo = iindef
 181       adcoar = iindef
 182 c
 183       codava = codret
 184       codret = 0
 185 c
 186 c====
 187 c 2. Allocation et recuperation des adresses
 188 c====
 189 c
 190       if ( option.gt.0 ) then
 191 c
 192 c 2.1. ==> Historique des etats et connectivite descendante
 193 c
 194       if ( mod(option,2).eq.0 ) then
 195 c
 196         if ( codret.eq.0 ) then
 197 c
 198         call gmaloj ( nhenti//'.HistEtat', ' ', nbento, adhist, codre1 )
 199         if ( codre1.ne.0 ) then
 200           codret = 11
 201           tabcod(1) = codre1
 202         endif
 203 c
 204         if ( typenh.eq.0 ) then
 205           jaux = 1
 206         elseif ( typenh.eq.1 ) then
 207           jaux = 2
 208         elseif ( typenh.eq.2 ) then
 209           jaux = 3
 210         elseif ( typenh.eq.3 ) then
 211           jaux = 4
 212         elseif ( typenh.eq.4 ) then
 213           jaux = 4
 214         elseif ( typenh.eq.5 ) then
 215           jaux = 5
 216         elseif ( typenh.eq.6 ) then
 217           jaux = 6
 218         elseif ( typenh.eq.7 ) then
 219           jaux = 5
 220         else
 221           codret = 120
 222           tabcod(2) = 1
 223         endif
 224 c
 225         endif
 226 c
 227         if ( codret.eq.0 ) then
 228 c
 229         iaux = (nbento-nbenca)*jaux
 230         call gmaloj ( nhenti//'.ConnDesc', ' ', iaux, adcode, codre2 )
 231 c
 232         if ( codre2.ne.0 ) then
 233           codret = 12
 234           tabcod(2) = codre2
 235         endif
 236 c
 237         endif
 238 c
 239       endif
 240 c
 241 c 2.2. ==> Fille
 242 c
 243       if ( mod(option,3).eq.0 ) then
 244 c
 245         if ( codret.eq.0 ) then
 246 c
 247         call gmaloj ( nhenti//'.Fille', ' ', nbento, adfill, codre0 )
 248 c
 249         if ( codre0.ne.0 ) then
 250           codret = 2
 251           tabcod(3) = codre0
 252         endif
 253 c
 254         endif
 255 c
 256       endif
 257 c
 258 c 2.3. ==> Mere
 259 c
 260       if ( mod(option,5).eq.0 ) then
 261 c
 262         if ( codret.eq.0 ) then
 263 c
 264         call gmaloj ( nhenti//'.Mere', ' ', nbento, admere, codre0 )
 265 c
 266         if ( codre0.ne.0 ) then
 267           codret = 3
 268           tabcod(4) = codre0
 269         endif
 270 c
 271         endif
 272 c
 273       endif
 274 c
 275 c 2.4. ==> Les familles
 276 c
 277       if ( mod(option,7).eq.0 ) then
 278 c
 279         if ( codret.eq.0 ) then
 280 c
 281         call gmaloj ( nhenti//'.Famille.EntiFamm', ' ',
 282      >                nbento, adfami, codre0 )
 283 c
 284         if ( codre0.ne.0 ) then
 285           codret = 4
 286           tabcod(5) = codre0
 287         endif
 288 c
 289         endif
 290 c
 291       endif
 292 c
 293 c 2.5. ==> Le niveau
 294 c
 295       if ( mod(option,11).eq.0 ) then
 296 c
 297         if ( codret.eq.0 ) then
 298 c
 299         call gmaloj ( nhenti//'.Niveau', ' ', nbento, adnivo, codre0 )
 300 c
 301         if ( codre0.ne.0 ) then
 302           codret = 5
 303           tabcod(7) = codre0
 304         endif
 305 c
 306         endif
 307 c
 308       endif
 309 c
 310 c 2.6. ==> Les informations supplementaires
 311 c
 312       if ( mod(option,13).eq.0 ) then
 313 c
 314         if ( codret.eq.0 ) then
 315 c
 316         if ( typenh.eq.3 ) then
 317           iaux = (nbento-nbenca)*4
 318         elseif ( typenh.eq.5 ) then
 319           iaux = (nbento-nbenca)*5
 320         elseif ( typenh.eq.6 ) then
 321           iaux = (nbento-nbenca)*6
 322         elseif ( typenh.eq.7 ) then
 323           iaux = (nbento-nbenca)*5
 324         else
 325           iaux = nbento
 326         endif
 327         call gmaloj ( nhenti//'.InfoSupp', ' ', iaux, adinsu, codre0 )
 328 c
 329         if ( codre0.ne.0 ) then
 330           codret = 6
 331           tabcod(8) = codre0
 332         endif
 333 c
 334         endif
 335 c
 336       endif
 337 c
 338 c 2.7. ==> Les informations supplementaires numero 2
 339 c
 340       if ( mod(option,17).eq.0 ) then
 341 c
 342         if ( codret.eq.0 ) then
 343 c
 344         call gmaloj ( nhenti//'.InfoSup2', ' ', nbento, adins2, codre0 )
 345 c
 346         if ( codre0.ne.0 ) then
 347           codret = 7
 348           tabcod(9) = codre0
 349         endif
 350 c
 351         endif
 352 c
 353       endif
 354 c
 355 c 2.8. ==> Le noeud supplementaire
 356 c
 357       if ( mod(option,19).eq.0 ) then
 358 c
 359         if ( codret.eq.0 ) then
 360 c
 361         call gmaloj ( nhenti//'.NoeuInMa', ' ', nbento, adnoim, codre0 )
 362 c
 363         if ( codre0.ne.0 ) then
 364           codret = 8
 365           tabcod(10) = codre0
 366         endif
 367 c
 368         endif
 369 c
 370       endif
 371 c
 372 c 2.9. ==> Les homologues
 373 c
 374       if ( mod(option,29).eq.0 ) then
 375 c
 376         if ( codret.eq.0 ) then
 377 c
 378         call gmaloj ( nhenti//'.Homologu', ' ', nbento, adhomo, codre0 )
 379 c
 380         if ( codre0.ne.0 ) then
 381           codret = 9
 382           tabcod(11) = codre0
 383         endif
 384 c
 385         endif
 386 c
 387       endif
 388 c
 389 c 2.10. ==> La connectivite par aretes
 390 c
 391       if ( mod(option,31).eq.0 ) then
 392 c
 393         if ( codret.eq.0 ) then
 394 c
 395         if ( typenh.eq.3 ) then
 396           iaux = nbenca*6
 397         elseif ( typenh.eq.5 ) then
 398           iaux = nbenca*8
 399         elseif ( typenh.eq.6 ) then
 400           iaux = nbenca*12
 401         elseif ( typenh.eq.7 ) then
 402           iaux = nbenca*9
 403         else
 404           iaux = 0
 405         endif
 406         call gmaloj ( nhenti//'.ConnAret', ' ', iaux, adcoar, codre0 )
 407 c
 408         if ( codre0.ne.0 ) then
 409           codret = 10
 410           tabcod(12) = codre0
 411         endif
 412 c
 413         endif
 414 c
 415       endif
 416 c
 417       endif
 418 c
 419 c====
 420 c 3. Attributs
 421 c====
 422 c
 423       if ( codret.eq.0 ) then
 424 c
 425       call gmecat ( nhenti, 1, nbento, codre1 )
 426       call gmecat ( nhenti, 2, nbenca, codre2 )
 427 c
 428       codre0 = min ( codre1, codre2 )
 429       codret = max ( abs(codre0), codret,
 430      >               codre1, codre2 )
 431 c
 432       if ( codret.ne.0 ) then
 433         tabcod(0) = codret
 434         codret = 30
 435       endif
 436 c
 437       endif
 438 c
 439 c====
 440 c 4. la fin
 441 c====
 442 c
 443       if ( codret.ne.0 ) then
 444 c
 445 #include "envex2.h"
 446 c
 447       write (ulsort,texte(langue,1)) 'Sortie', nompro
 448       write (ulsort,texte(langue,2)) codret
 449       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 450       write (ulsort,90002) 'option', option
 451       write (ulsort,texte(langue,6)) nhenti
 452       write (ulsort,texte(langue,8)) tabcod
 453 c
 454       else
 455 c
 456       codret = codava
 457 c
 458       endif
 459 c
 460 #ifdef _DEBUG_HOMARD_
 461       write (ulsort,texte(langue,1)) 'Sortie', nompro
 462       call dmflsh (iaux)
 463 #endif
 464 c
 465       end