src/tool/Utilitaire/utad06.F

   1       subroutine utad06 ( typenh, option, optio2, nhenti,
   2      >                    nbeold, nbenew, nbaold, nbanew,
   3      >                    adhist, adcode, adfill, admere,
   4      >                    adfami,
   5      >                    adnivo, adinsu, adins2,
   6      >                    adnoim, adanci, 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 - ADresses - phase 06
  29 c    --           --               --
  30 c ______________________________________________________________________
  31 c   Modification des longueurs des tableaux pour une entite HOM_Enti
  32 c   et recuperation de leurs adresses
  33 c   Remarque : le code de retour en entree ne doit pas etre ecrase
  34 c              brutalement ; il doit etre cumule avec les operations
  35 c              de ce programme
  36 c   Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires
  37 c ______________________________________________________________________
  38 c .        .     .        .                                            .
  39 c .  nom   . e/s . taille .           description                      .
  40 c .____________________________________________________________________.
  41 c . typenh . e   .   1    . code des entites au sens homard            .
  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 adresses a recuperer.
  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 .        .     .        . 23 : Deraffin                              .
  61 c .        .     .        . 29 : homologue                             .
  62 c .        .     .        . 31 : connectivite par arete                .
  63 c . optio2 . e   .   1    . 0 : on detruit les objets de taille nulle  .
  64 c .        .     .        . 1 : on garde les objets de taille nulle    .
  65 c . nhenti . e   . char8  . nom de l'objet decrivant l'entite          .
  66 c . nbeold . e   .   1    . nombre d'entites ancien                    .
  67 c . nbenew . e   .   1    . nombre d'entites nouveau                   .
  68 c . nbaold . e   .   1    . nombre d'entites decrites par arete ancien .
  69 c . nbanew . e   .   1    . nombre d'entites decrites par arete nouveau.
  70 c . adhist .  s  .  1    . historique de l'etat                        .
  71 c . adcode .  s  .  1    . connectivite descendante                    .
  72 c . adfill .  s  .  1    . fille des entites                           .
  73 c . admere .  s  .  1    . mere des entites                            .
  74 c . adfami .  s  .  1    . famille des entites                         .
  75 c . adnivo .  s  .  1    . niveau des entites                          .
  76 c . adinsu .  s  .  1    . informations supplementaires                .
  77 c . adins2 .  s  .  1    . informations supplementaires numero 2       .
  78 c . adnoim .  s  .  1    . noeud interne a la maille                   .
  79 c . adanci .  s  .  1    . memorisation du deraffinement               .
  80 c . adhomo .  s  .  1     . homologue                                  .
  81 c . adcoar .   s  .  1    . connectivite par arete                     .
  82 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  83 c . langue . e   .    1   . langue des messages                        .
  84 c .        .     .        . 1 : francais, 2 : anglais                  .
  85 c . codret . es  .    1   . code de retour des modules                 .
  86 c ______________________________________________________________________
  87 c
  88 c====
  89 c 0. declarations et dimensionnement
  90 c====
  91 c
  92 c 0.1. ==> generalites
  93 c
  94       implicit none
  95       save
  96 c
  97       character*6 nompro
  98       parameter ( nompro = 'UTAD06' )
  99 c
 100 #include "nblang.h"
 101 c
 102 c 0.2. ==> communs
 103 c
 104 #include "envex1.h"
 105 #include "impr02.h"
 106 c
 107 c 0.3. ==> arguments
 108 c
 109       character*8 nhenti
 110 c
 111       integer typenh
 112       integer option, optio2
 113       integer nbeold, nbenew, nbaold, nbanew
 114       integer adhist, adcode, adfill, admere
 115       integer adfami
 116       integer adnivo
 117       integer adinsu
 118       integer adins2
 119       integer adnoim
 120       integer adanci
 121       integer adhomo
 122       integer adcoar
 123 c
 124       integer ulsort, langue, codret
 125 c
 126 c 0.4. ==> variables locales
 127 c
 128       integer un
 129       parameter ( un = 1 )
 130 c
 131       integer iaux, jaux, kaux, laux
 132       integer dimaux
 133       integer codava
 134       integer codre0
 135       integer codre1, codre2
 136       integer tabcod(0:13)
 137 c
 138       integer nbmess
 139       parameter ( nbmess = 10 )
 140       character*80 texte(nblang,nbmess)
 141 c
 142 c 0.5. ==> initialisations
 143 c ______________________________________________________________________
 144 c
 145 c====
 146 c 1. messages
 147 c====
 148 c
 149 #include "impr01.h"
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,texte(langue,1)) 'Entree', nompro
 153       call dmflsh (iaux)
 154 #endif
 155 c
 156       texte(1,4) = '(''Reallocations pour les '',a)'
 157       texte(1,6) = '(''On detruit les objets de taille nulle.'')'
 158       texte(1,7) = '(''On garde les objets de taille nulle.'')'
 159       texte(1,8) = '(''Codes de retour'',20i3)'
 160       texte(1,9) =  '(''Ancien nombre d''''entites   : '',i10)'
 161       texte(1,10) = '(''Nouveau nombre d''''entites  : '',i10)'
 162 c
 163       texte(2,4) = '(''Reallocation for the '',a)'
 164       texte(2,6) = '(''Null size objects are destroyed.'')'
 165       texte(2,7) = '(''Null size objetcs are kept.'')'
 166       texte(2,8) = '(''Error codes'',20i3)'
 167       texte(2,9) =  '(''Old number of entities : '',i10)'
 168       texte(2,10) = '(''New number of entities : '',i10)'
 169 c
 170 #include "impr03.h"
 171 c
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 174       write (ulsort,90002) 'option', option
 175       write (ulsort,texte(langue,6+optio2))
 176       write (ulsort,texte(langue,9)) nbeold
 177       write (ulsort,texte(langue,10)) nbenew
 178 cgn      call gmprsx ( nompro, nhenti )
 179       call dmflsh (iaux)
 180 #endif
 181 c
 182       do 10 , iaux = 0 , 13
 183         tabcod(iaux) = 0
 184    10 continue
 185 c
 186       codava = codret
 187       codret = 0
 188 c
 189 c====
 190 c 2. recuperation des adresses
 191 c====
 192 c
 193       if ( option.gt.0 ) then
 194 c
 195 c 2.1. ==> Historique des etats et connectivite descendante
 196 c
 197       if ( mod(option,2).eq.0 ) then
 198 c
 199         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 200 c
 201           call gmlboj ( nhenti//'.HistEtat' , codre1 )
 202           call gmlboj ( nhenti//'.ConnDesc' , codre2 )
 203 c
 204         else
 205 c
 206           call gmmod ( nhenti//'.HistEtat',
 207      >                 adhist, nbeold, nbenew, un, un, codre1 )
 208 c
 209           if ( typenh.eq.0 ) then
 210             dimaux = 1
 211           elseif ( typenh.eq.1 ) then
 212             dimaux = -2
 213           elseif ( typenh.eq.2 ) then
 214             dimaux = 3
 215           elseif ( typenh.eq.3 ) then
 216             dimaux = 4
 217           elseif ( typenh.eq.4 ) then
 218             dimaux = 4
 219           elseif ( typenh.eq.5 ) then
 220             dimaux = 5
 221           elseif ( typenh.eq.6 ) then
 222             dimaux = 6
 223           elseif ( typenh.eq.7 ) then
 224             dimaux = 5
 225           else
 226             codret = 120
 227             tabcod(2) = 1
 228           endif
 229 c
 230           if ( codret.eq.0 ) then
 231 c
 232           if ( dimaux.lt.0 ) then
 233             iaux = -dimaux
 234             jaux = -dimaux
 235             kaux = nbeold
 236             laux = nbenew
 237           else
 238             iaux = (nbeold-nbaold)
 239             jaux = (nbenew-nbanew)
 240             kaux = dimaux
 241             laux = dimaux
 242           endif
 243           call gmmod ( nhenti//'.ConnDesc',
 244      >                 adcode, iaux, jaux, kaux, laux, codre2 )
 245 c
 246           endif
 247 c
 248         endif
 249 c
 250         if ( codre1.ne.0 ) then
 251           codret = 11
 252           tabcod(1) = 1
 253         endif
 254 c
 255         if ( codre2.ne.0 ) then
 256           codret = 12
 257           tabcod(2) = 1
 258         endif
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261       write (ulsort,90002) 'traitement', 2
 262       write (ulsort,texte(langue,8)) codre1, codre2
 263 #endif
 264 c
 265       endif
 266 c
 267 c 2.2. ==> Fille
 268 c
 269       if ( mod(option,3).eq.0 ) then
 270 c
 271         if ( codret.eq.0 ) then
 272 c
 273         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 274 c
 275           call gmlboj ( nhenti//'.Fille' , codre0 )
 276 c
 277         else
 278 c
 279           call gmmod ( nhenti//'.Fille',
 280      >                 adfill, nbeold, nbenew, un, un, codre0 )
 281 c
 282         endif
 283 c
 284         if ( codre0.ne.0 ) then
 285           codret = 2
 286           tabcod(3) = 1
 287         endif
 288 c
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,90002) 'traitement', 3
 291       write (ulsort,texte(langue,8)) codre0
 292 #endif
 293 c
 294         endif
 295 c
 296       endif
 297 c
 298 c 2.3. ==> Mere
 299 c
 300       if ( mod(option,5).eq.0 ) then
 301 c
 302         if ( codret.eq.0 ) then
 303 c
 304         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 305 c
 306           call gmlboj ( nhenti//'.Mere' , codre0 )
 307 c
 308         else
 309 c
 310           call gmmod ( nhenti//'.Mere',
 311      >                 admere, nbeold, nbenew, un, un, codre0 )
 312 c
 313         endif
 314 c
 315         if ( codre0.ne.0 ) then
 316           codret = 3
 317           tabcod(4) = 1
 318         endif
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,90002) 'traitement', 5
 322       write (ulsort,texte(langue,8)) codre0
 323 #endif
 324 c
 325         endif
 326 c
 327       endif
 328 c
 329 c 2.4. ==> Les familles
 330 c          Attention : ne jamais tuer EntiFamm si taille nulle
 331 c
 332       if ( mod(option,7).eq.0 ) then
 333 c
 334         if ( codret.eq.0 ) then
 335 c
 336         call gmmod ( nhenti//'.Famille.EntiFamm',
 337      >               adfami, nbeold, nbenew, un, un, codre0 )
 338 c
 339         if ( codre0.ne.0 ) then
 340           codret = 4
 341           tabcod(5) = 1
 342         endif
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,90002) 'traitement', 7
 346       write (ulsort,texte(langue,8)) codre0
 347 #endif
 348 c
 349         endif
 350 c
 351       endif
 352 c
 353 c 2.5. ==> Le niveau
 354 c
 355       if ( mod(option,11).eq.0 ) then
 356 c
 357         if ( codret.eq.0 ) then
 358 c
 359         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 360 c
 361           call gmlboj ( nhenti//'.Niveau' , codre0 )
 362 c
 363         else
 364 c
 365           call gmmod ( nhenti//'.Niveau',
 366      >                 adnivo, nbeold, nbenew, un, un, codre0 )
 367 c
 368         endif
 369 c
 370         if ( codre0.ne.0 ) then
 371           codret = 5
 372           tabcod(7) = 1
 373         endif
 374 c
 375 #ifdef _DEBUG_HOMARD_
 376       write (ulsort,90002) 'traitement', 11
 377       write (ulsort,texte(langue,8)) codre0
 378 #endif
 379 c
 380         endif
 381 c
 382       endif
 383 c
 384 c 2.6. ==> Les informations supplementaires
 385 c
 386       if ( mod(option,13).eq.0 ) then
 387 c
 388         if ( codret.eq.0 ) then
 389 c
 390         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 391 c
 392           call gmlboj ( nhenti//'.InfoSupp' , codre0 )
 393 c
 394         else
 395 c
 396           if ( typenh.eq.0 ) then
 397             dimaux = 1
 398           elseif ( typenh.eq.1 ) then
 399             dimaux = 1
 400           elseif ( typenh.eq.2 ) then
 401             dimaux = 1
 402           elseif ( typenh.eq.3 ) then
 403             dimaux = 4
 404           elseif ( typenh.eq.4 ) then
 405             dimaux = 1
 406           elseif ( typenh.eq.5 ) then
 407             dimaux = 5
 408           elseif ( typenh.eq.6 ) then
 409             dimaux = 6
 410           elseif ( typenh.eq.7 ) then
 411             dimaux = 5
 412           else
 413             codret = 6
 414             tabcod(8) = 1
 415           endif
 416           iaux = (nbeold-nbaold)
 417           jaux = (nbenew-nbanew)
 418           kaux = dimaux
 419           laux = dimaux
 420           call gmmod ( nhenti//'.InfoSupp',
 421      >                 adinsu, iaux, jaux, kaux, laux, codre0 )
 422 c
 423         endif
 424 c
 425         if ( codre0.ne.0 ) then
 426           codret = 6
 427           tabcod(8) = 1
 428         endif
 429 c
 430 #ifdef _DEBUG_HOMARD_
 431       write (ulsort,90002) 'traitement', 13
 432       write (ulsort,texte(langue,8)) codre0
 433 #endif
 434 c
 435         endif
 436 c
 437       endif
 438 c
 439 c 2.7. ==> Les informations supplementaires numero 2
 440 c
 441       if ( mod(option,17).eq.0 ) then
 442 c
 443         if ( codret.eq.0 ) then
 444 c
 445         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 446 c
 447           call gmlboj ( nhenti//'.InfoSup2' , codre0 )
 448 c
 449         else
 450 c
 451           call gmmod ( nhenti//'.InfoSup2',
 452      >                 adins2, nbeold, nbenew, un, un, codre0 )
 453 c
 454         endif
 455 c
 456         if ( codre0.ne.0 ) then
 457           codret = 7
 458           tabcod(9) = 1
 459         endif
 460 c
 461 #ifdef _DEBUG_HOMARD_
 462       write (ulsort,90002) 'traitement', 17
 463       write (ulsort,texte(langue,8)) codre0
 464 #endif
 465 c
 466         endif
 467 c
 468       endif
 469 c
 470 c 2.8. ==> Le noeud supplementaire
 471 c
 472       if ( mod(option,19).eq.0 ) then
 473 c
 474         if ( codret.eq.0 ) then
 475 c
 476         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 477 c
 478           call gmlboj ( nhenti//'.NoeuInMa' , codre0 )
 479 c
 480         else
 481 c
 482           call gmmod ( nhenti//'.NoeuInMa',
 483      >                 adnoim, nbeold, nbenew, un, un, codre0 )
 484 c
 485         endif
 486 c
 487         if ( codre0.ne.0 ) then
 488           codret = 8
 489           tabcod(10) = 1
 490         endif
 491 c
 492 #ifdef _DEBUG_HOMARD_
 493       write (ulsort,90002) 'traitement', 19
 494       write (ulsort,texte(langue,8)) codre0
 495 #endif
 496 c
 497         endif
 498 c
 499       endif
 500 c
 501 c 2.9. ==> La memorisation du deraffinement
 502 c
 503       if ( mod(option,23).eq.0 ) then
 504 c
 505         if ( codret.eq.0 ) then
 506 c
 507         call gmobal ( nhenti//'.Deraffin', codre0 )
 508 c
 509         if ( codre0.eq.2 ) then
 510 c
 511           if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 512 c
 513             call gmlboj ( nhenti//'.Deraffin' , codre0 )
 514 c
 515           else
 516 c
 517             call gmmod ( nhenti//'.Deraffin',
 518      >                   adanci, nbeold, nbenew, un, un, codre0 )
 519 c
 520           endif
 521 c
 522           if ( codre0.ne.0 ) then
 523             codret = 9
 524             tabcod(11) = 1
 525           endif
 526 c
 527 #ifdef _DEBUG_HOMARD_
 528       write (ulsort,90002) 'traitement', 23
 529       write (ulsort,texte(langue,8)) codre0
 530 #endif
 531 c
 532         endif
 533 c
 534         endif
 535 c
 536       endif
 537 c
 538 c 2.10. ==> Les homologues
 539 c
 540       if ( mod(option,29).eq.0 ) then
 541 c
 542         if ( codret.eq.0 ) then
 543 c
 544         if ( optio2.eq.0 .and. nbenew.eq.0 ) then
 545 c
 546           call gmlboj ( nhenti//'.Homologu' , codre0 )
 547 c
 548         else
 549 c
 550           call gmmod ( nhenti//'.Homologu',
 551      >                 adhomo, nbeold, nbenew, un, un, codre0 )
 552 c
 553         endif
 554 c
 555         if ( codre0.ne.0 ) then
 556           codret = 10
 557           tabcod(12) = 1
 558         endif
 559 c
 560 #ifdef _DEBUG_HOMARD_
 561       write (ulsort,90002) 'traitement', 29
 562       write (ulsort,texte(langue,8)) codre0
 563 #endif
 564 c
 565         endif
 566 c
 567       endif
 568 c
 569 c 2.11. ==> Connectivites par aretes
 570 c
 571       if ( mod(option,31).eq.0 ) then
 572 c
 573         if ( codret.eq.0 ) then
 574 c
 575         if ( optio2.eq.0 .and. nbanew.eq.0 ) then
 576 c
 577           call gmlboj ( nhenti//'.ConnAret' , codre0 )
 578 c
 579         else
 580 c
 581           call gmmod ( nhenti//'.ConnAret',
 582      >                 adcoar, nbaold, nbanew, un, un, codre0 )
 583 c
 584         endif
 585 c
 586         if ( codre0.ne.0 ) then
 587           codret = 11
 588           tabcod(13) = 1
 589         endif
 590 c
 591 #ifdef _DEBUG_HOMARD_
 592       write (ulsort,90002) 'traitement', 31
 593       write (ulsort,texte(langue,8)) codre0
 594 #endif
 595 c
 596         endif
 597 c
 598       endif
 599 c
 600       endif
 601 c
 602 c====
 603 c 3. Attributs
 604 c====
 605 c
 606       if ( codret.eq.0 ) then
 607 c
 608       call gmecat ( nhenti, 1, nbenew, codre1 )
 609       call gmecat ( nhenti, 2, nbanew, codre2 )
 610 c
 611       codre0 = min ( codre1, codre2 )
 612       codret = max ( abs(codre0), codret,
 613      >               codre1, codre2 )
 614 c
 615       if ( codret.ne.0 ) then
 616         codret = 30
 617         tabcod(0) = 1
 618       endif
 619 c
 620       endif
 621 c
 622 c====
 623 c 4. la fin
 624 c====
 625 c
 626       if ( codret.ne.0 ) then
 627 c
 628 #include "envex2.h"
 629 c
 630       write (ulsort,texte(langue,1)) 'Sortie', nompro
 631       write (ulsort,texte(langue,2)) codret
 632       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 633       write (ulsort,90002) 'option', option
 634       write (ulsort,texte(langue,8)) tabcod
 635       write (ulsort,texte(langue,9)) nbeold
 636       write (ulsort,texte(langue,10)) nbenew
 637       call gmprsx(nompro,nhenti)
 638 c
 639       else
 640 c
 641       codret = codava
 642 c
 643       endif
 644 c
 645 #ifdef _DEBUG_HOMARD_
 646       write (ulsort,texte(langue,1)) 'Sortie', nompro
 647       call dmflsh (iaux)
 648 #endif
 649 c
 650       end