src/tool/Information/infvec.F

   1       subroutine infvec ( nomail, nosolu, action,
   2      >                    ulfido, ulenst, ulsost,
   3      >                    lgetco, taetco,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c   INformation : Fichiers VECtoriels
  26 c   --            -        ---
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   . char8  . nom de l'objet maillage homard iteration n .
  32 c . nosolu . e   . char8  . nom de l'objet solution                    .
  33 c . action . e   . char8  . action en cours                            .
  34 c . ulfido . e   .   1    . unite logique du fichier de donnees correct.
  35 c . ulenst . e   .   1    . unite logique de l'entree standard         .
  36 c . ulsost . e   .   1    . unite logique de la sortie standard        .
  37 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  38 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  39 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  40 c . langue . e   .    1   . langue des messages                        .
  41 c .        .     .        . 1 : francais, 2 : anglais                  .
  42 c . codret . es  .    1   . code de retour des modules                 .
  43 c .        .     .        . 0 : pas de probleme                        .
  44 c .        .     .        . 2 : probleme dans les memoires             .
  45 c .        .     .        . 3 : probleme dans les fichiers             .
  46 c .        .     .        . 5 : probleme autre                         .
  47 c ______________________________________________________________________
  48 c
  49 c====
  50 c 0. declarations et dimensionnement
  51 c====
  52 c
  53 c 0.1. ==> generalites
  54 c
  55       implicit none
  56       save
  57 c
  58       character*6 nompro
  59       parameter ( nompro = 'INFVEC' )
  60 c
  61 cfonc      integer nbtych
  62 cfonc      parameter ( nbtych = 5 )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "gmenti.h"
  71 #include "gmreel.h"
  72 #include "gmstri.h"
  73 c
  74 #include "nombno.h"
  75 #include "nombar.h"
  76 #include "nombtr.h"
  77 #include "nombqu.h"
  78 #include "nombte.h"
  79 #include "nombhe.h"
  80 #include "nombpy.h"
  81 #include "nombpe.h"
  82 #include "nbfami.h"
  83 #include "envca1.h"
  84 #include "envada.h"
  85 #include "nomber.h"
  86 #include "nbutil.h"
  87 c
  88 c 0.3. ==> arguments
  89 c
  90       character*8 action
  91       character*8 nomail, nosolu
  92 c
  93       integer ulfido, ulenst, ulsost
  94       integer lgetco
  95       integer taetco(lgetco)
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101       integer codava
 102       integer nretap, nrsset
 103       integer iaux, jaux, kaux
 104       integer ideb, ifin
 105 c
 106       integer pcoono, adcocs
 107       integer psomar
 108       integer pnp2ar, phetar, pmerar
 109       integer phettr, paretr, pnivtr, adnmtr
 110       integer advotr, adpptr
 111       integer advoqu, adppqu
 112       integer phetqu, parequ, pnivqu, adnmqu
 113       integer ptrite, phette
 114       integer pquahe, phethe
 115       integer pfacpy, phetpy
 116       integer pfacpe, phetpe
 117       integer pposif, pfacar
 118       integer ppovos, pvoiso
 119       integer pfamar, pcfaar
 120       integer pfamtr, pcfatr
 121       integer pfamqu, pcfaqu
 122       integer pfamte, pcfate
 123       integer pfamhe, pcfahe
 124       integer pfampy, pcfapy
 125       integer pfampe, pcfape
 126       integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5
 127       integer ptra11, ptra12, ptra13, ptra14
 128       integer ptra15, ptra16
 129       integer ptrac1, ptrab1
 130       integer adnbrn
 131       integer adarcn
 132       integer adnohn, adnocn, adnoin, lgnoin
 133       integer adtrhn, adtrcn, adtrin, lgtrin
 134       integer adquhn, adqucn, adquin, lgquin
 135       integer option, infsup, typcof, typcop, typbor, optnoe
 136       integer porpay, triedr
 137       integer numfic
 138 c
 139       integer codre1, codre2, codre3, codre4, codre5
 140       integer codre0
 141 c
 142       integer nbcham, nbfonc, nbprof, nblopg
 143       integer aninch, aninfo, aninpr, adinlg
 144       integer nrocha, nrocmp, nrotab
 145 c
 146       integer decanu(-1:7)
 147 c
 148       integer nbblfa, nbblvo
 149 c
 150       double precision anglex, angley, anglez
 151       double precision xyzmiz(3), xyzmaz(3)
 152       double precision vafomi, vafoma
 153 c
 154       logical zoom
 155 c
 156       character*6 saux06
 157       character*8 norenu
 158       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 159       character*8 nhtetr, nhhexa, nhpyra, nhpent
 160       character*8 nhelig
 161       character*8 nhvois, nhsupe, nhsups
 162       character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5
 163       character*8 ntra11, ntra12, ntra13, ntra14
 164       character*8 ntra15, ntra16
 165       character*8 ntrac1, ntrab1
 166       character*16 nomcmp
 167       character*64 nomcha
 168 c
 169       integer nbmess
 170       parameter ( nbmess = 10 )
 171       character*80 texte(nblang,nbmess)
 172 c
 173 c 0.5. ==> initialisations
 174 c ______________________________________________________________________
 175 c
 176 c====
 177 c 1. messages
 178 c====
 179 c
 180       codava = codret
 181 c
 182 c=======================================================================
 183       if ( codava.eq.0 ) then
 184 c=======================================================================
 185 c
 186 c 1.1. ==> les messages
 187 c
 188 #include "impr01.h"
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,1)) 'Entree', nompro
 192       call dmflsh (iaux)
 193 #endif
 194 c
 195       texte(1,4) = '(a6,'' FICHIERS Xfig'')'
 196       texte(1,5) = '(20(''=''),/)'
 197       texte(1,6) = '(''Lancement du trace numero'',i3)'
 198       texte(1,7) = '(''Action en cours : '',a)'
 199 c
 200       texte(2,4) = '(a6,'' Xfig FILES'')'
 201       texte(2,5) = '(17(''=''),/)'
 202       texte(2,6) = '(''Beginning of writings #'',i3)'
 203       texte(2,7) = '(''Current action : '',a)'
 204 c
 205 #include "impr03.h"
 206 c
 207 c 1.4. ==> le numero de sous-etape
 208 c
 209       nretap = taetco(1)
 210       nrsset = taetco(2) + 1
 211       taetco(2) = nrsset
 212 c
 213       call utcvne ( nretap, nrsset, saux06, iaux, codret )
 214 c
 215 c 1.5 ==> le titre
 216 c
 217       write (ulsort,texte(langue,4)) saux06
 218       write (ulsort,texte(langue,5))
 219 c
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,texte(langue,7)) action
 222 #endif
 223 c
 224 c====
 225 c 2. recuperation des pointeurs
 226 c====
 227 c 2.1. ==> structure generale
 228 c
 229       if ( codret.eq.0 ) then
 230 c
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 233 #endif
 234       call utnomh ( nomail,
 235      >                sdim,   mdim,
 236      >               degre, maconf, homolo, hierar,
 237      >              rafdef, nbmane, typcca, typsfr, maextr,
 238      >              mailet,
 239      >              norenu,
 240      >              nhnoeu, nhmapo, nharet,
 241      >              nhtria, nhquad,
 242      >              nhtetr, nhhexa, nhpyra, nhpent,
 243      >              nhelig,
 244      >              nhvois, nhsupe, nhsups,
 245      >              ulsort, langue, codret)
 246 c
 247       endif
 248 c
 249 c 2.2. ==> tableaux
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,90002) '2.2. tableaux ; codret', codret
 252 #endif
 253 c
 254       if ( codret.eq.0 ) then
 255 c
 256       iaux = 3*19
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 259 #endif
 260       call utad01 ( iaux, nhnoeu,
 261      >                jaux,
 262      >                jaux,   jaux,   jaux,
 263      >              pcoono,   jaux,   jaux, adcocs,
 264      >              ulsort, langue, codret )
 265 c
 266       iaux = 2590
 267       if ( degre.eq.2 ) then
 268         iaux = iaux*13
 269       endif
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 272 #endif
 273       call utad02 (   iaux, nharet,
 274      >              phetar, psomar,   jaux, pmerar,
 275      >              pfamar, pcfaar,   jaux,
 276      >              jaux  , pnp2ar,   jaux,
 277      >                jaux,   jaux,   jaux,
 278      >              ulsort, langue, codret )
 279 c
 280       if ( nbftri.ne.0 ) then
 281 c
 282         iaux = 37
 283         if ( nbtrto.ne.0 ) then
 284           iaux = iaux*154
 285           if ( mod(mailet,2).eq.0 ) then
 286             iaux = iaux*19
 287           endif
 288         endif
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 291 #endif
 292         call utad02 (   iaux, nhtria,
 293      >                phettr, paretr,   jaux,   jaux,
 294      >                pfamtr, pcfatr,   jaux,
 295      >                pnivtr,   jaux,   jaux,
 296      >                adnmtr,   jaux,   jaux,
 297      >                ulsort, langue, codret )
 298 c
 299       endif
 300 c
 301       if ( nbquto.ne.0 ) then
 302 c
 303         iaux = 5698
 304         if ( mod(mailet,3).eq.0 ) then
 305           iaux = iaux*19
 306         endif
 307 #ifdef _DEBUG_HOMARD_
 308       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 309 #endif
 310         call utad02 (   iaux, nhquad,
 311      >                phetqu, parequ,   jaux,   jaux,
 312      >                pfamqu, pcfaqu,   jaux,
 313      >                pnivqu,   jaux,   jaux,
 314      >                adnmqu,   jaux,   jaux,
 315      >                ulsort, langue, codret )
 316 c
 317       endif
 318 c
 319       if ( nbteto.ne.0 ) then
 320 c
 321         iaux = 518
 322 #ifdef _DEBUG_HOMARD_
 323       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 324 #endif
 325         call utad02 (   iaux, nhtetr,
 326      >                phette, ptrite, jaux  , jaux,
 327      >                pfamte, pcfate,   jaux,
 328      >                  jaux,   jaux,   jaux,
 329      >                  jaux,   jaux,   jaux,
 330      >                ulsort, langue, codret )
 331 c
 332       endif
 333 c
 334       if ( nbheto.ne.0 ) then
 335 c
 336         iaux = 518
 337 #ifdef _DEBUG_HOMARD_
 338       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 339 #endif
 340         call utad02 (   iaux, nhhexa,
 341      >                phethe, pquahe, jaux  , jaux,
 342      >                pfamhe, pcfahe,   jaux,
 343      >                  jaux,   jaux,   jaux,
 344      >                  jaux,   jaux,   jaux,
 345      >                ulsort, langue, codret )
 346 c
 347       endif
 348 c
 349       if ( nbpyto.ne.0 ) then
 350 c
 351         iaux = 518
 352 #ifdef _DEBUG_HOMARD_
 353       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 354 #endif
 355         call utad02 (   iaux, nhpyra,
 356      >                phetpy, pfacpy, jaux  , jaux,
 357      >                pfampy, pcfapy,   jaux,
 358      >                  jaux,   jaux,   jaux,
 359      >                  jaux,   jaux,   jaux,
 360      >                ulsort, langue, codret )
 361 c
 362       endif
 363 c
 364       if ( nbpeto.ne.0 ) then
 365 c
 366         iaux = 518
 367 #ifdef _DEBUG_HOMARD_
 368       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 369 #endif
 370         call utad02 (   iaux, nhpent,
 371      >                phetpe, pfacpe, jaux  , jaux,
 372      >                pfampe, pcfape,   jaux,
 373      >                  jaux,   jaux,   jaux,
 374      >                  jaux,   jaux,   jaux,
 375      >                ulsort, langue, codret )
 376 c
 377       endif
 378 c
 379       endif
 380 c
 381 c 2.3. ==> les voisinages
 382 #ifdef _DEBUG_HOMARD_
 383       write (ulsort,90002) '2.3. voisinages ; codret', codret
 384 #endif
 385 c
 386       if ( codret.eq.0 ) then
 387 c
 388       iaux = 1
 389       jaux = 0
 390 #ifdef _DEBUG_HOMARD_
 391       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
 392 #endif
 393       call utvois ( nomail, nhvois,
 394      >                iaux,   jaux,   jaux,   jaux,
 395      >              ppovos, pvoiso,
 396      >              nbfaar, pposif, pfacar,
 397      >              ulsort, langue, codret )
 398 c
 399       endif
 400 c
 401       if ( codret.eq.0 ) then
 402 c
 403 #ifdef _DEBUG_HOMARD_
 404       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 405 #endif
 406       iaux = 3
 407       if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 408         iaux = iaux*5
 409       endif
 410       if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 411         iaux = iaux*7
 412       endif
 413       if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 414         iaux = iaux*221
 415       endif
 416       call utad04 ( iaux, nhvois,
 417      >                jaux,   jaux, pposif, pfacar,
 418      >              advotr, advoqu,
 419      >                jaux,   jaux, adpptr, adppqu,
 420      >                jaux,   jaux,   jaux,
 421      >                jaux,   jaux,   jaux,
 422      >                jaux,   jaux,   jaux,
 423      >                jaux,   jaux,   jaux,
 424      >              ulsort, langue, codret )
 425 c
 426       endif
 427 c
 428 c 2.4. ===> tableaux lies a la renumerotation
 429 #ifdef _DEBUG_HOMARD_
 430       write (ulsort,90002) '2.4. renumerotation ; codret', codret
 431 #endif
 432 c
 433 #ifdef _DEBUG_HOMARD_
 434       call gmprsx (nompro,norenu)
 435       call gmprsx (nompro,norenu//'.Nombres')
 436       call gmprsx (nompro,norenu//'.TrHOMARD')
 437       call gmprsx (nompro,norenu//'.TrCalcul')
 438       call gmprsx (nompro,norenu//'.InfoSupE')
 439 #endif
 440 c
 441       if ( codret.eq.0 ) then
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,3)) 'UTRE03_no', nompro
 445 #endif
 446       iaux = -1
 447       jaux = 210
 448       call utre03 ( iaux, jaux, norenu,
 449      >              renoac, renoto, adnohn, adnocn,
 450      >              ulsort, langue, codret)
 451 c
 452       endif
 453 c
 454       if ( codret.eq.0 ) then
 455 c
 456 #ifdef _DEBUG_HOMARD_
 457       write (ulsort,texte(langue,3)) 'UTRE04_no', nompro
 458 #endif
 459       iaux = -1
 460       jaux = -11
 461       call utre04 ( iaux, jaux, norenu,
 462      >              lgnoin, adnoin,
 463      >              ulsort, langue, codret)
 464 c
 465       endif
 466 c
 467       if ( codret.eq.0 ) then
 468 c
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro
 471 #endif
 472       iaux = 1
 473       jaux = -21
 474       call utre03 ( iaux, jaux, norenu,
 475      >                kaux, rearto,   kaux, adarcn,
 476      >              ulsort, langue, codret)
 477 c
 478       endif
 479 c
 480       if ( nbtrac.ne.0 ) then
 481 c
 482         if ( codret.eq.0 ) then
 483 c
 484 #ifdef _DEBUG_HOMARD_
 485         write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro
 486 #endif
 487         iaux = 2
 488         jaux = -210
 489         call utre03 ( iaux, jaux, norenu,
 490      >                retrac, retrto, adtrhn, adtrcn,
 491      >                ulsort, langue, codret)
 492 c
 493         endif
 494 c
 495         if ( codret.eq.0 ) then
 496 c
 497 #ifdef _DEBUG_HOMARD_
 498       write (ulsort,texte(langue,3)) 'UTRE04_tr', nompro
 499 #endif
 500         iaux = 2
 501         jaux = -11
 502         call utre04 ( iaux, jaux, norenu,
 503      >                lgtrin, adtrin,
 504      >                ulsort, langue, codret)
 505 c
 506        endif
 507 c
 508       endif
 509 c
 510       if ( nbquac.ne.0 ) then
 511 c
 512         if ( codret.eq.0 ) then
 513 c
 514 #ifdef _DEBUG_HOMARD_
 515         write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro
 516 #endif
 517         iaux = 4
 518         jaux = -210
 519         call utre03 ( iaux, jaux, norenu,
 520      >                requac, requto, adquhn, adqucn,
 521      >                ulsort, langue, codret)
 522 c
 523         endif
 524 c
 525         if ( codret.eq.0 ) then
 526 c
 527 #ifdef _DEBUG_HOMARD_
 528       write (ulsort,texte(langue,3)) 'UTRE04_qu', nompro
 529 #endif
 530         iaux = 4
 531         jaux = -11
 532         call utre04 ( iaux, jaux, norenu,
 533      >                lgquin, adquin,
 534      >                ulsort, langue, codret)
 535 c
 536         endif
 537 c
 538       endif
 539 c
 540       if ( codret.eq.0 ) then
 541 c
 542 cgn      call gmprsx ( nompro, norenu//'.Nombres' )
 543       call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret )
 544 c
 545       endif
 546 c
 547       if ( codret.eq.0 ) then
 548 c
 549 #ifdef _DEBUG_HOMARD_
 550       write (ulsort,texte(langue,3)) 'UTNBMH', nompro
 551 #endif
 552       call utnbmh ( imem(adnbrn),
 553      >              nbnois, nbnoei, nbnomp,
 554      >              nbnop1, nbnop2, nbnoim,
 555      >                iaux,   iaux,   iaux,
 556      >              nbelem, nbmaae, nbmafe, nbmane,
 557      >              nbmapo, nbsegm, nbtria, nbtetr,
 558      >              nbquad, nbhexa, nbpent, nbpyra,
 559      >              numano, numael,
 560      >              nvoare, nvosom,
 561      >              ulsort, langue, codret )
 562 #ifdef _DEBUG_HOMARD_
 563       write(ulsort,90002) 'nbmapo', nbmapo
 564       write(ulsort,90002) 'nbsegm', nbsegm
 565       write(ulsort,90002) 'nbtria', nbtria
 566       write(ulsort,90002) 'nbtetr', nbtetr
 567       write(ulsort,90002) 'nbquad', nbquad
 568       write(ulsort,90002) 'nbhexa', nbhexa
 569       write(ulsort,90002) 'nbpent', nbpent
 570       write(ulsort,90002) 'nbpyra', nbpyra
 571 #endif
 572 c
 573       decanu(-1) = 0
 574       decanu(3) = 0
 575       decanu(2) = nbtetr
 576       decanu(1) = nbtetr + nbtria
 577       decanu(0) = nbtetr + nbtria + nbsegm
 578       decanu(4) = nbtetr + nbtria + nbsegm + nbmapo
 579       decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad
 580       decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 581       decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 582      >          + nbpyra
 583 #ifdef _DEBUG_HOMARD_
 584       write(ulsort,90002) 'decanu', decanu
 585 #endif
 586 c
 587       endif
 588 c
 589 c 2.5. ===> tableaux lies a la solution eventuelle
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,90002) '2.5. Solution ; codret', codret
 592 #endif
 593 c
 594       if ( codret.eq.0 ) then
 595 c
 596 #ifdef _DEBUG_HOMARD_
 597       call gmprsx (nompro,nosolu)
 598       call gmprsx (nompro,nosolu//'.InfoCham')
 599       call gmprsx (nompro,nosolu//'.InfoPaFo')
 600       call gmprsx (nompro,nosolu//'.InfoProf')
 601       call gmprsx (nompro,nosolu//'.InfoLoPG')
 602 #endif
 603 c
 604 #ifdef _DEBUG_HOMARD_
 605       write (ulsort,texte(langue,3)) 'UTCASO', nompro
 606 #endif
 607       call utcaso ( nosolu,
 608      >              nbcham, nbfonc, nbprof, nblopg,
 609      >              aninch, aninfo, aninpr, adinlg,
 610      >              ulsort, langue, codret )
 611 c
 612       endif
 613 c
 614 c====
 615 c 3. initialisations
 616 c====
 617 #ifdef _DEBUG_HOMARD_
 618       write (ulsort,90002) '3. initialisations ; codret', codret
 619 #endif
 620 c
 621       numfic = 0
 622 c
 623 c====
 624 c 4. questions - reponses pour les sorties
 625 c====
 626 #ifdef _DEBUG_HOMARD_
 627       write (ulsort,90002) '4. questions - reponses ; codret', codret
 628 #endif
 629 c
 630    40 continue
 631 c
 632 c 4.1. ==> choix de la sortie, des angles de vue, des couleurs, etc.
 633 c
 634       if ( codret.eq.0 ) then
 635 c
 636 #ifdef _DEBUG_HOMARD_
 637       write (ulsort,texte(langue,3)) 'INFVE1', nompro
 638 #endif
 639       call infve1 ( option,
 640      >              typcof, typcop, typbor, optnoe,
 641      >              porpay, triedr,
 642      >              anglex, angley, anglez,
 643      >              zoom, xyzmiz, xyzmaz,
 644      >              vafomi, vafoma,
 645      >              rmem(adcocs+1), rmem(adcocs+4), rmem(adcocs+7),
 646      >              nbcham, smem(aninch),
 647      >              nomcha, nomcmp, nrocha, nrocmp, nrotab,
 648      >              ulfido, ulenst, ulsost,
 649      >              ulsort, langue, codret )
 650 c
 651       endif
 652 c
 653 c 4.2. ==> traitement des options
 654 c
 655       if ( codret.eq.0 ) then
 656 c
 657       if ( option.eq.0 ) then
 658         codret = 0
 659         goto 80
 660       else
 661         if ( option.lt.0 ) then
 662           iaux = -option
 663         else
 664           iaux = mod(option,100)
 665         endif
 666         if ( iaux.le.7 ) then
 667           infsup = iaux - 1
 668         elseif ( iaux.eq.8 ) then
 669           infsup = 531
 670         else
 671           infsup = 462
 672         endif
 673       endif
 674 c
 675       endif
 676 c
 677 c====
 678 c 5. preparatifs
 679 c====
 680 #ifdef _DEBUG_HOMARD_
 681       write (ulsort,90002) '5. preparatifs ; codret', codret
 682       write (ulsort,90002) 'option', option
 683 #endif
 684 c
 685 c 5.1. ==> recherche des blocs connexes
 686 c
 687       if ( option.lt.0 ) then
 688 c
 689 c 5.1.1. ==> adresses
 690 c
 691         if ( codret.eq.0 ) then
 692 c
 693         iaux = nbquto + 1 + nbtrto
 694         call gmalot ( ntrac1, 'entier  ', iaux, ptrac1, codre1 )
 695 c
 696         iaux = nbteto + nbheto + nbpeto + nbpyto
 697         call gmalot ( ntrab1, 'entier  ', iaux, ptrab1, codre2 )
 698 c
 699         codre0 = min ( codre1, codre2 )
 700         codret = max ( abs(codre0), codret,
 701      >                 codre1, codre2 )
 702 c
 703         endif
 704 c
 705         if ( codret.eq.0 ) then
 706 c
 707         iaux = max ( nbtrac + nbquac,
 708      >               nbteac + nbheac + nbpyac + nbpeac )
 709         call gmalot ( ntrav1, 'entier  ', iaux, ptrav1, codre1 )
 710         call gmalot ( ntrav2, 'entier  ', nbnoto, ptrav2, codre2 )
 711         call gmalot ( ntrav3, 'entier  ', nbarto, ptrav3, codre3 )
 712         iaux = nbquto + nbtrto + 1
 713         call gmalot ( ntrav4, 'entier  ', iaux, ptrav4, codre4 )
 714         iaux = nbquto + nbtrto + 1
 715         call gmalot ( ntrav5, 'entier  ', iaux, ptrav5, codre5 )
 716 c
 717         codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 718         codret = max ( abs(codre0), codret,
 719      >                 codre1, codre2, codre3, codre4, codre5 )
 720 c
 721         jaux = nbquto + nbtrto + 1
 722         call gmalot ( ntra11, 'entier  ', jaux, ptra11, codre1 )
 723         call gmalot ( ntra12, 'entier  ', nbnoto, ptra12, codre2 )
 724         call gmalot ( ntra13, 'entier  ', nbarto, ptra13, codre3 )
 725         jaux = nbquto + nbtrto
 726         call gmalot ( ntra14, 'entier  ', jaux, ptra14, codre4 )
 727 c
 728         codre0 = min ( codre1, codre2, codre3, codre4 )
 729         codret = max ( abs(codre0), codret,
 730      >                 codre1, codre2, codre3, codre4 )
 731 c
 732         call gmalot ( ntra15, 'entier  ', nbarto, ptra15, codre1 )
 733         call gmalot ( ntra16, 'entier  ', nbarto, ptra16, codre2 )
 734 c
 735         codre0 = min ( codre1, codre2 )
 736         codret = max ( abs(codre0), codret,
 737      >                 codre1, codre2 )
 738 c
 739         endif
 740 c
 741 c 5.1.2. ==> traitement
 742 c
 743 #ifdef _DEBUG_HOMARD_
 744       write (ulsort,90002) '51.2. traitement ; codret', codret
 745 #endif
 746 c
 747         if ( codret.eq.0 ) then
 748 c
 749         if ( nbteto.gt.0 .or. nbheto.gt.0 .or.
 750      >       nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 751 c
 752           if ( codret.eq.0 ) then
 753 c
 754 #ifdef _DEBUG_HOMARD_
 755           jaux = ulsort
 756 #else
 757           jaux = 0
 758 #endif
 759 #ifdef _DEBUG_HOMARD_
 760       write (ulsort,texte(langue,3)) 'UTB11B', nompro
 761 #endif
 762           call utb11b ( nbblvo,
 763      >                  imem(phetar), imem(psomar),
 764      >                  imem(phettr), imem(paretr),
 765      >                  imem(phetqu), imem(parequ),
 766      >                  imem(phette), imem(ptrite),
 767      >                  imem(phethe), imem(pquahe),
 768      >                  imem(phetpy), imem(pfacpy),
 769      >                  imem(phetpe), imem(pfacpe),
 770      >                  imem(ppovos), imem(pvoiso),
 771      >                  imem(pposif), imem(pfacar),
 772      >                  imem(advotr), imem(adpptr),
 773      >                  imem(advoqu), imem(adppqu),
 774      >                  imem(pfamar), imem(pcfaar),
 775      >                  imem(pfamtr), imem(pcfatr),
 776      >                  imem(pfamqu), imem(pcfaqu),
 777      >                  imem(pfamte), imem(pcfate),
 778      >                  imem(pfamhe), imem(pcfahe),
 779      >                  imem(pfampy), imem(pcfapy),
 780      >                  imem(pfampe), imem(pcfape),
 781      >                  imem(ptrav1), imem(ptrav2),
 782      >                  imem(ptrav3), imem(ptrav5),
 783      >                  imem(ptra11), imem(ptra12),
 784      >                  imem(ptra13), imem(ptra14),
 785      >                  imem(ptra15), imem(ptra16),
 786      >                  imem(ptrab1),
 787      >                  jaux, ulsort, langue, codret )
 788 c
 789           endif
 790 c
 791         else
 792           nbblvo = 0
 793         endif
 794 c
 795         if ( codret.eq.0 ) then
 796 c
 797 c       on examine toutes les faces actives du calcul
 798 c
 799         jaux = nbquto + nbtrto
 800         do 51 ,iaux = 0, jaux
 801           imem(ptrav4+iaux) = 1
 802    51   continue
 803         imem(ptrav4+nbquto) = 0
 804         iaux = 2
 805 #ifdef _DEBUG_HOMARD_
 806         jaux = ulsort
 807 #else
 808         jaux = 0
 809 #endif
 810 #ifdef _DEBUG_HOMARD_
 811       write (ulsort,texte(langue,3)) 'UTB11C', nompro
 812 #endif
 813         call utb11c ( nbblfa, iaux, imem(ptrav4),
 814      >                imem(phetar), imem(psomar),
 815      >                imem(phettr), imem(paretr),
 816      >                imem(phetqu), imem(parequ),
 817      >                imem(ppovos), imem(pvoiso),
 818      >                imem(pposif), imem(pfacar),
 819      >                imem(pfamar), imem(pcfaar),
 820      >                imem(pfamtr), imem(pcfatr),
 821      >                imem(pfamqu), imem(pcfaqu),
 822      >                imem(ptrav1), imem(ptrav2), imem(ptrav3),
 823      >                imem(ptra15), imem(ptra16),
 824      >                imem(ptrac1),
 825      >                jaux, ulsort, langue, codret )
 826 c
 827         endif
 828 c
 829         if ( codret.eq.0 ) then
 830 c
 831         call gmlboj ( ntrav1, codre1 )
 832         call gmlboj ( ntrav2, codre2 )
 833         call gmlboj ( ntrav3, codre3 )
 834         call gmlboj ( ntrav4, codre4 )
 835         call gmlboj ( ntrav5, codre5 )
 836 c
 837         codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 838         codret = max ( abs(codre0), codret,
 839      >                 codre1, codre2, codre3, codre4, codre5 )
 840 c
 841         call gmlboj ( ntra11, codre1 )
 842         call gmlboj ( ntra12, codre2 )
 843         call gmlboj ( ntra13, codre3 )
 844         call gmlboj ( ntra14, codre4 )
 845 c
 846         codre0 = min ( codre1, codre2, codre3, codre4 )
 847         codret = max ( abs(codre0), codret,
 848      >                 codre1, codre2, codre3, codre4 )
 849 c
 850         call gmlboj ( ntra15, codre1 )
 851         call gmlboj ( ntra16, codre2 )
 852 c
 853         codre0 = min ( codre1, codre2 )
 854         codret = max ( abs(codre0), codret,
 855      >                 codre1, codre2 )
 856 c
 857         endif
 858 c
 859       endif
 860 cgn      call gmprsx (nompro,ntrac1)
 861 cgn      call gmprsx (nompro,ntrab1)
 862 c
 863       endif
 864 c
 865 c 5.2. ==> recherche des niveaux des volumes
 866 #ifdef _DEBUG_HOMARD_
 867       write (ulsort,90002) '5.2. niveaux des volumes ; codret', codret
 868 #endif
 869 c
 870       if ( option.gt.100 ) then
 871 c
 872         if ( codret.eq.0 ) then
 873 c
 874         iaux = nbteto + nbheto + nbpeto + nbpyto
 875         call gmalot ( ntrab1, 'entier  ', iaux, ptrab1, codre0 )
 876 c
 877         codret = max ( abs(codre0), codret )
 878 c
 879         endif
 880 c
 881         if ( codret.eq.0 ) then
 882 c
 883 #ifdef _DEBUG_HOMARD_
 884       write (ulsort,texte(langue,3)) 'INFVE7', nompro
 885 #endif
 886         call infve7 ( imem(ptrab1),
 887      >                imem(pnivtr), imem(pnivqu),
 888      >                imem(ptrite), imem(pquahe),
 889      >                imem(pfacpy), imem(pfacpe),
 890      >                ulsort, langue, codret )
 891 c
 892         endif
 893 cgn       call gmprsx(nompro,ntrab1)
 894 c
 895       endif
 896 c
 897 c 5.3. ==> allocation des tableaux :
 898 c
 899 c          Les aretes :
 900 c          . Les aretes isolees sont visualisables.
 901 c          . Si on a demande de tracer les bords, on les represente.
 902 c          "nbarvi" est le nombre d'aretes visualisables
 903 c          tableau nnarvi(6,nbarvi) :
 904 c             1 : niveau de l'arete a afficher
 905 c             2 : numero HOMARD de l'arete
 906 c             3, 4 : numero des 2 noeuds
 907 c             5 : 0, si isolee, 1 si bord
 908 c             6 : numero de l'eventuel noeud P2
 909 c
 910 c          Les faces :
 911 c          En dimension 2, toutes les faces actives sont visualisables.
 912 c          En dimension 3, seules les faces de bord d'elements 3D actifs
 913 c          ou les faces isolees sont visualisables.
 914 c          "nbtrvi" est le nombre de triangles visualisables
 915 c          tableau nntrvi(9,nbtrvi) :
 916 c             2 : numero HOMARD du triangle
 917 c             3, 4, 5 : numeros des noeuds p1
 918 c             6 : famille du triangle
 919 c             7, 8, 9 : numeros des noeuds p2
 920 c             10 : numero du noeud interne
 921 c
 922 c          "nbquvi" est le nombre de quadrangles visualisables
 923 c          tableau nnquvi(11,nbquvi) :
 924 c             2 : numero HOMARD du quadrangle
 925 c             3, 4, 5, 6 : numeros des noeuds p1
 926 c             7 : famille du quadrangle
 927 c             8, 9, 10, 11 : numeros des noeuds p2
 928 c             12 : numero du noeud interne
 929 c
 930 #ifdef _DEBUG_HOMARD_
 931       write (ulsort,90002) '5.3. allocation ; codret', codret
 932 #endif
 933 c
 934       if ( codret.eq.0 ) then
 935 c
 936 c     tableau auxiliaire tabaux pour infve2
 937       iaux = max(nbfare,nbftri,nbfqua)
 938       call gmalot ( ntrav1, 'entier  ', iaux, ptrav1, codre1 )
 939 c
 940 c     tableau auxiliaire tbaux2 pour infve2
 941       iaux = nbquto + 1 + max(nbarto,nbtrto)
 942       call gmalot ( ntrav2, 'entier  ', iaux, ptrav2, codre2 )
 943 c
 944       codre0 = min ( codre1, codre2 )
 945       codret = max ( abs(codre0), codret,
 946      >               codre1, codre2 )
 947 c
 948       endif
 949 c
 950 c====
 951 c 6. Trace pour tous les blocs ou tous les niveaux
 952 c====
 953 c
 954 #ifdef _DEBUG_HOMARD_
 955       write (ulsort,90002) '6. trace ; codret', codret
 956 #endif
 957 c
 958       if ( codret.eq.0 ) then
 959 c
 960       if ( option.lt.0 ) then
 961 c
 962         ideb = 1
 963         if ( nbteto.gt.0 .or. nbheto.gt.0 .or.
 964      >       nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 965           ifin = nbblvo
 966         else
 967           ifin = nbblfa
 968         endif
 969 c
 970       elseif ( option.gt.100 ) then
 971 c
 972         ideb = nivinf
 973         ifin = nivsup
 974 c
 975       else
 976 c
 977         ideb = 0
 978         ifin = 0
 979 c
 980       endif
 981 c
 982       do 61 , iaux = ideb , ifin
 983 c
 984         if ( codret.eq.0 ) then
 985 c
 986         if ( option.lt.0 ) then
 987           jaux = iaux
 988           kaux = -1
 989         elseif ( option.gt.100 ) then
 990           jaux = 0
 991           kaux = iaux
 992         else
 993           jaux = 0
 994           kaux = -1
 995         endif
 996 #ifdef _DEBUG_HOMARD_
 997         write (ulsort,texte(langue,6)) jaux
 998 #endif
 999 c
1000 #ifdef _DEBUG_HOMARD_
1001       write (ulsort,texte(langue,3)) 'INFVE0', nompro
1002 #endif
1003         call infve0 ( action, jaux, kaux, numfic,
1004      >                infsup, typcof, typcop, typbor, optnoe, porpay,
1005      >                zoom, triedr,
1006      >                nbcham, smem(aninch),
1007      >                nomcha, nomcmp, nrocha, nrocmp, nrotab,
1008      >                rmem(pcoono),
1009      >                imem(psomar), imem(pnp2ar),
1010      >                imem(phetar), imem(pmerar),
1011      >                imem(pposif), imem(pfacar),
1012      >                imem(paretr), imem(phettr), imem(pnivtr),
1013      >                imem(adnmtr),
1014      >                imem(advotr), imem(adpptr),
1015      >                imem(pfamtr),
1016      >                imem(parequ), imem(phetqu), imem(pnivqu),
1017      >                imem(adnmqu),
1018      >                imem(advoqu), imem(adppqu),
1019      >                imem(pfamqu),
1020      >                imem(adnocn),
1021      >                imem(adarcn), imem(adtrcn), imem(adqucn),
1022      >                imem(adnohn), imem(adtrhn), imem(adquhn),
1023      >                lgnoin, lgtrin, lgquin,
1024      >                imem(adnoin), imem(adtrin), imem(adquin),
1025      >                decanu,
1026      >                anglex, angley, anglez,
1027      >                xyzmiz, xyzmaz, vafomi, vafoma,
1028      >                imem(ptrav1), imem(ptrav2),
1029      >                imem(ptrac1), imem(ptrab1),
1030      >                ulsost,
1031      >                ulsort, langue, codret )
1032 c
1033         endif
1034 c
1035    61 continue
1036 c
1037       endif
1038 c
1039 c====
1040 c 7. menage
1041 c====
1042 c
1043 #ifdef _DEBUG_HOMARD_
1044       write (ulsort,90002) '7. menage ; codret', codret
1045 #endif
1046 c
1047 c 7.1. ==> suppression des tableaux temporaires
1048 c
1049       if ( codret.eq.0 ) then
1050 c
1051       call gmlboj ( ntrav1, codre1 )
1052       call gmlboj ( ntrav2, codre2 )
1053 c
1054       codre0 = min ( codre1, codre2 )
1055       codret = max ( abs(codre0), codret,
1056      >               codre1, codre2 )
1057 c
1058       if ( option.lt.0 ) then
1059 c
1060         call gmlboj ( ntrac1, codre0 )
1061 c
1062         codret = max ( abs(codre0), codret )
1063 c
1064       endif
1065 c
1066       if ( option.gt.100 ) then
1067 c
1068         call gmlboj ( ntrab1, codre0 )
1069 c
1070         codret = max ( abs(codre0), codret )
1071 c
1072       endif
1073 c
1074       endif
1075 c
1076 c 7.2. ==> nouveau trace
1077 c
1078       if ( codret.eq.0 ) then
1079 c
1080       goto 40
1081 c
1082       endif
1083 c
1084 c====
1085 c 8. la fin
1086 c====
1087 c
1088    80 continue
1089 c
1090       write (ulsort,*) ' '
1091 c
1092       if ( codret.ne.0 ) then
1093 c
1094 #include "envex2.h"
1095 c
1096       write (ulsort,texte(langue,1)) 'Sortie', nompro
1097       write (ulsort,texte(langue,2)) codret
1098 c
1099       endif
1100 c
1101 #ifdef _DEBUG_HOMARD_
1102       write (ulsort,texte(langue,1)) 'Sortie', nompro
1103       call dmflsh (iaux)
1104 #endif
1105 c
1106 c=======================================================================
1107       endif
1108 c=======================================================================
1109 c
1110       end