src/tool/Utilitaire/utveri.F

   1       subroutine utveri ( action, nomail,
   2      >                    nmprog, avappr,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c   UTilitaire : VERIfication
  25 c   --            ----
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . action . e   . char8  . action en cours                            .
  31 c . nomail . e   . char8  . nom de l'objet maillage homard a verifier  .
  32 c . nmprog . e   . char*  . nom du programme a pister                  .
  33 c . avappr . e   .   1    . 1 : impression avant l'appel a "nmprog"    .
  34 c .        .     .        . 2 : impression apres l'appel a "nmprog"    .
  35 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51       character*6 nompro
  52       parameter ( nompro = 'UTVERI' )
  53 c
  54 #include "nblang.h"
  55 #include "consts.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 c
  61 #include "gmenti.h"
  62 #include "gmreel.h"
  63 #include "nombno.h"
  64 #include "nombar.h"
  65 #include "nombtr.h"
  66 #include "nombqu.h"
  67 #include "nombte.h"
  68 #include "nombhe.h"
  69 #include "nombpy.h"
  70 #include "nombpe.h"
  71 #include "envada.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       character*8 action
  76       character*8 nomail
  77       character*(*) nmprog
  78 c
  79       integer avappr
  80 c
  81       integer ulsort, langue, codret
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85       integer codre0
  86       integer codre1, codre2, codre3
  87 c
  88       integer iaux, jaux, kaux
  89       integer pcoono, psomar
  90       integer paretr
  91       integer parequ
  92       integer phette, ptrite, pcotrt, parete
  93       integer phethe, pquahe, pcoquh, parehe
  94       integer phetpy, pfacpy, pcofay, parepy
  95       integer phetpe, pfacpe, pcofap, parepe
  96       integer   sdim,   mdim
  97       integer  degre, maconf, homolo, hierar
  98       integer rafdef, nbmane, typcca, typsfr, maextr
  99       integer mailet
 100       integer nbnoal, nbtral, nbqual
 101       integer nbteal, nbtaal
 102       integer nbheal, nbhaal
 103       integer nbpyal, nbyaal
 104       integer nbpeal, nbpaal
 105       integer nuroul, lnomfl
 106 c
 107       character*8 norenu
 108       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 109       character*8 nhtetr, nhhexa, nhpyra, nhpent
 110       character*8 nhelig
 111       character*8 nhvois, nhsupe, nhsups
 112       character*15 saux15
 113       character*200 nomflo
 114 c
 115       integer nbmess
 116       parameter ( nbmess = 10 )
 117       character*80 texte(nblang,nbmess)
 118 c
 119 c 0.5. ==> initialisations
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. messages
 124 c====
 125 c
 126 #include "impr01.h"
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,1)) 'Entree', nompro
 130       call dmflsh (iaux)
 131 #endif
 132 c
 133       texte(1,4) = '(/,''A l''''entree de '',a,'' :'',/)'
 134       texte(1,5) = '(/,''Avant appel a '',a,'' :'')'
 135       texte(1,6) = '(/,''Apres appel a '',a,'' :'')'
 136       texte(1,7) = '(/,''Mauvais code pour '',a,'' : '',i8,/)'
 137       texte(1,8) = '(''Le maillage est a corriger.'',/,27(''=''))'
 138       texte(1,9) = '(''Action en cours : '',a)'
 139 c
 140       texte(2,4) = '(/,''At the beginning of '',a,'' :'',/)'
 141       texte(2,5) = '(/,''Before calling '',a,'':'')'
 142       texte(2,6) = '(/,''After calling '',a,'':'')'
 143       texte(2,7) = '(/,''Bad code for '',a,'': '',i8,/)'
 144       texte(2,8) = '(''This mesh is not correct.'',/,25(''=''))'
 145       texte(2,9) = '(''Current action: '',a)'
 146 c
 147 #include "impr03.h"
 148 c
 149 #ifdef _DEBUG_HOMARD_
 150       if ( avappr.ge.0 .and. avappr.le.2 ) then
 151         write (ulsort,texte(langue,4+avappr)) nmprog
 152       else
 153         write (ulsort,texte(langue,7)) nmprog, avappr
 154       endif
 155       write (ulsort,texte(langue,9)) action
 156 #endif
 157 c
 158       codret = 0
 159 c
 160 c====
 161 c 2. recuperation des pointeurs
 162 c====
 163 c
 164 c 2.1. ==> structure generale
 165 c
 166       if ( codret.eq.0 ) then
 167 c
 168       call utnomh ( nomail,
 169      >                sdim,   mdim,
 170      >               degre, maconf, homolo, hierar,
 171      >              rafdef, nbmane, typcca, typsfr, maextr,
 172      >              mailet,
 173      >              norenu,
 174      >              nhnoeu, nhmapo, nharet,
 175      >              nhtria, nhquad,
 176      >              nhtetr, nhhexa, nhpyra, nhpent,
 177      >              nhelig,
 178      >              nhvois, nhsupe, nhsups,
 179      >              ulsort, langue, codret)
 180 c
 181       endif
 182 c
 183 c 2.2. ==> tableaux
 184 c
 185       if ( codret.eq.0 ) then
 186 c
 187       call gmliat ( nhnoeu, 1, nbnoal, codre1 )
 188       call gmadoj ( nhnoeu//'.Coor', pcoono, iaux, codre2 )
 189       call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 )
 190 c
 191       codre0 = min ( codre1, codre2, codre3 )
 192       codret = max ( abs(codre0), codret,
 193      >               codre1, codre2, codre3 )
 194 c
 195       if ( nbtrto.ne.0 ) then
 196 c
 197         call gmliat ( nhtria, 1, nbtral, codre1 )
 198         call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre2 )
 199 c
 200         codre0 = min ( codre1, codre2 )
 201         codret = max ( abs(codre0), codret,
 202      >                 codre1, codre2 )
 203 c
 204       endif
 205 c
 206       if ( nbquto.ne.0 ) then
 207 c
 208         call gmliat ( nhquad, 1, nbqual, codre1 )
 209         call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre2 )
 210 c
 211         codre0 = min ( codre1, codre2 )
 212         codret = max ( abs(codre0), codret,
 213      >                 codre1, codre2 )
 214 c
 215       endif
 216 c
 217       if ( nbteto.ne.0 ) then
 218 c
 219         call gmliat ( nhtetr, 1, nbteal, codre1 )
 220         call gmliat ( nhtetr, 2, nbtaal, codre2 )
 221 c
 222         codre0 = min ( codre1, codre2 )
 223         codret = max ( abs(codre0), codret,
 224      >                 codre1, codre2 )
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 228 #endif
 229         iaux = 26
 230         if ( nbtaal.gt.0 ) then
 231           iaux = iaux*31
 232         endif
 233         call utad02 (   iaux, nhtetr,
 234      >                phette, ptrite,  jaux, jaux,
 235      >                  jaux,   jaux,   jaux,
 236      >                  jaux, pcotrt,   jaux,
 237      >                  jaux,   jaux, parete,
 238      >                ulsort, langue, codret )
 239 c
 240       endif
 241 c
 242       if ( nbheto.ne.0 ) then
 243 c
 244         call gmliat ( nhhexa, 1, nbheal, codre1 )
 245         call gmliat ( nhhexa, 2, nbhaal, codre2 )
 246 c
 247         codre0 = min ( codre1, codre2 )
 248         codret = max ( abs(codre0), codret,
 249      >                 codre1, codre2 )
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 253 #endif
 254         iaux = 26
 255         if ( nbhaal.gt.0 ) then
 256           iaux = iaux*31
 257         endif
 258         call utad02 (   iaux, nhhexa,
 259      >                phethe, pquahe,  jaux, jaux,
 260      >                  jaux,   jaux,   jaux,
 261      >                  jaux, pcoquh,   jaux,
 262      >                  jaux,   jaux, parehe,
 263      >                ulsort, langue, codret )
 264 c
 265       endif
 266 c
 267       if ( nbpyto.ne.0 ) then
 268 c
 269         call gmliat ( nhpyra, 1, nbpyal, codre1 )
 270         call gmliat ( nhpyra, 2, nbyaal, codre2 )
 271 c
 272         codre0 = min ( codre1, codre2 )
 273         codret = max ( abs(codre0), codret,
 274      >                 codre1, codre2 )
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 278 #endif
 279         iaux = 26
 280         if ( nbyaal.gt.0 ) then
 281           iaux = iaux*31
 282         endif
 283         call utad02 (   iaux, nhpyra,
 284      >                phetpy, pfacpy,  jaux, jaux,
 285      >                  jaux,   jaux,   jaux,
 286      >                  jaux, pcofay,   jaux,
 287      >                  jaux,   jaux, parepy,
 288      >                ulsort, langue, codret )
 289 c
 290       endif
 291 c
 292       if ( nbpeto.ne.0 ) then
 293 c
 294         call gmliat ( nhpent, 1, nbpeal, codre1 )
 295         call gmliat ( nhpent, 2, nbpaal, codre2 )
 296 c
 297         codre0 = min ( codre1, codre2 )
 298         codret = max ( abs(codre0), codret,
 299      >                 codre1, codre2 )
 300 c
 301 #ifdef _DEBUG_HOMARD_
 302       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 303 #endif
 304         iaux = 26
 305         if ( nbpaal.gt.0 ) then
 306           iaux = iaux*31
 307         endif
 308         call utad02 (   iaux, nhpent,
 309      >                phetpe, pfacpe,  jaux, jaux,
 310      >                  jaux,   jaux,   jaux,
 311      >                  jaux, pcofap,   jaux,
 312      >                  jaux,   jaux, parepe,
 313      >                ulsort, langue, codret )
 314 c
 315       endif
 316 c
 317       endif
 318 c
 319 c====
 320 c 3. fichier de sortie du bilan
 321 c====
 322 #ifdef _DEBUG_HOMARD_
 323       write (ulsort,90002) '3. fichier sortie ; codret', codret
 324 #endif
 325 c
 326       if ( codret.eq.0 ) then
 327 c
 328       saux15 = 'verif_'//action
 329       iaux = 1
 330       jaux = -1
 331       if ( rafdef.eq.31 ) then
 332         kaux = 1
 333       else
 334         kaux = nbiter
 335       endif
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'UTULBI', nompro
 338 #endif
 339       call utulbi ( nuroul, nomflo, lnomfl,
 340      >                iaux, saux15, kaux, jaux,
 341      >              ulsort, langue, codret )
 342 c
 343       endif
 344 c
 345 c====
 346 c 4. controles
 347 c====
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,90002) '4. controles ; codret', codret
 350 #endif
 351 c
 352 c 4.1. ==> les aretes
 353 c
 354       if ( codret.eq.0 ) then
 355 c
 356 #ifdef _DEBUG_HOMARD_
 357       write (ulsort,texte(langue,3)) 'UTEARE', nompro
 358 #endif
 359       call uteare ( nbarto, nbnoto, imem(psomar),
 360      >              nmprog, avappr, nuroul,
 361      >              ulsort, langue, codret )
 362 c
 363       endif
 364 c
 365 c 4.2. ==> les triangles
 366 #ifdef _DEBUG_HOMARD_
 367       write (ulsort,90002) '4.2. tria ; codret', codret
 368 #endif
 369 c
 370       if ( codret.eq.0 ) then
 371 c
 372       if ( nbtrto.ne.0 ) then
 373 c
 374 #ifdef _DEBUG_HOMARD_
 375       write (ulsort,texte(langue,3)) 'UTETRI', nompro
 376 #endif
 377         call utetri ( nbtrto, nbtral,
 378      >                imem(paretr), imem(psomar),
 379      >                nmprog, avappr, nuroul,
 380      >                ulsort, langue, codret )
 381 c
 382       endif
 383 c
 384       endif
 385 c
 386 c 4.3. ==> les quadrangles
 387 #ifdef _DEBUG_HOMARD_
 388       write (ulsort,90002) '4.3. quad ; codret', codret
 389 #endif
 390 c
 391       if ( codret.eq.0 ) then
 392 c
 393       if ( nbquto.ne.0 ) then
 394 c
 395 #ifdef _DEBUG_HOMARD_
 396       write (ulsort,texte(langue,3)) 'UTEQUA', nompro
 397 #endif
 398         call utequa ( nbquto, nbqual, nbnoal, sdim,
 399      >                rmem(pcoono), imem(psomar), imem(parequ),
 400      >                nmprog, avappr, nuroul,
 401      >                ulsort, langue, codret )
 402 c
 403       endif
 404 c
 405       endif
 406 c
 407 c 4.4. ==> les tetraedres
 408 #ifdef _DEBUG_HOMARD_
 409       write (ulsort,90002) '4.4. tetr ; codret', codret
 410 #endif
 411 c
 412       if ( codret.eq.0 ) then
 413 c
 414       if ( nbteto.ne.0 ) then
 415 c
 416         iaux = nbteal - nbtaal
 417 #ifdef _DEBUG_HOMARD_
 418       write (ulsort,texte(langue,3)) 'UTETET', nompro
 419 #endif
 420         call utetet ( nbteto, iaux, nbtaal, nbtral,
 421      >                imem(psomar), imem(paretr),
 422      >                imem(ptrite), imem(pcotrt), imem(parete),
 423      >                nmprog, avappr, nuroul,
 424      >                ulsort, langue, codret )
 425 c
 426       endif
 427 c
 428       endif
 429 c
 430 c 4.5. ==> les hexaedres
 431 #ifdef _DEBUG_HOMARD_
 432       write (ulsort,90002) '4.5. hexa ; codret', codret
 433 #endif
 434 c
 435       if ( codret.eq.0 ) then
 436 c
 437       if ( nbheto.ne.0 ) then
 438 c
 439         iaux = nbheal - nbhaal
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,texte(langue,3)) 'UTEHEX', nompro
 442 #endif
 443         call utehex ( nbheto, iaux, nbhaal, nbqual,
 444      >                imem(psomar), imem(parequ),
 445      >                imem(pquahe), imem(pcoquh), imem(parehe),
 446      >                nmprog, avappr, nuroul,
 447      >                ulsort, langue, codret )
 448 c
 449       endif
 450 c
 451       endif
 452 c
 453 c 4.6. ==> les pyramides
 454 #ifdef _DEBUG_HOMARD_
 455       write (ulsort,90002) '4.6. pyra ; codret', codret
 456 #endif
 457 c
 458       if ( codret.eq.0 ) then
 459 c
 460       if ( nbpyto.ne.0 ) then
 461 c
 462         iaux = nbpyal - nbyaal
 463 #ifdef _DEBUG_HOMARD_
 464       write (ulsort,texte(langue,3)) 'UTEPYR', nompro
 465 #endif
 466         call utepyr ( nbpyto, iaux, nbyaal, nbtral,
 467      >                imem(psomar), imem(paretr),
 468      >                imem(pfacpy), imem(pcofay), imem(parepy),
 469      >                nmprog, avappr, nuroul,
 470      >                ulsort, langue, codret )
 471 c
 472       endif
 473 c
 474       endif
 475 c
 476 c 4.7. ==> les pentaedres
 477 #ifdef _DEBUG_HOMARD_
 478       write (ulsort,90002) '4.7. pent ; codret', codret
 479 #endif
 480 c
 481       if ( codret.eq.0 ) then
 482 c
 483       if ( nbpeto.ne.0 ) then
 484 c
 485         iaux = nbpeal - nbpaal
 486 #ifdef _DEBUG_HOMARD_
 487       write (ulsort,texte(langue,3)) 'UTEPEN', nompro
 488 #endif
 489         call utepen ( nbpeto, iaux, nbpaal, nbqual,
 490      >                imem(psomar),
 491      >                imem(parequ),
 492      >                imem(pfacpe), imem(pcofap), imem(parepe),
 493      >                nmprog, avappr, nuroul,
 494      >                ulsort, langue, codret )
 495 c
 496       endif
 497 c
 498       endif
 499 c
 500 c====
 501 c 5. fermeture du fichier de sortie du bilan
 502 c====
 503 #ifdef _DEBUG_HOMARD_
 504       write (ulsort,90002) '5. fermeture ; codret', codret
 505 #endif
 506 c
 507       if ( codret.eq.0 ) then
 508 c
 509       call gufeul ( nuroul , codret )
 510 c
 511       endif
 512 c
 513 c====
 514 c 6. On impose un code de retour nul si c'est un maillage avec ajout
 515 c    de joint car par construction des mailles sont aplaties
 516 c====
 517 #ifdef _DEBUG_HOMARD_
 518       write (ulsort,90002) '6. impose ; codret', codret
 519 #endif
 520 c
 521       if ( rafdef.eq.31 ) then
 522 c
 523         codret = 0
 524 c
 525       endif
 526 c
 527 c====
 528 c 7. la fin
 529 c====
 530 c
 531       if ( codret.ne.0 ) then
 532 c
 533 #include "envex2.h"
 534 c
 535       write (nuroul,texte(langue,8))
 536       write (ulsort,texte(langue,1)) 'Sortie', nompro
 537       write (ulsort,texte(langue,2)) codret
 538 c
 539       endif
 540 c
 541 #ifdef _DEBUG_HOMARD_
 542       write (ulsort,texte(langue,1)) 'Sortie', nompro
 543       call dmflsh (iaux)
 544 #endif
 545 c
 546       end