src/tool/AV_Conversion/vcfia0.F

   1       subroutine vcfia0 ( lgopti, taopti, lgoptr, taoptr,
   2      >                    lgopts, taopts,
   3      >                    option,
   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    aVant adaptation - FIltrage de l'ADaptation
  26 c     -                 --            --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . lgopti . e   .   1    . longueur du tableau des options entieres   .
  32 c . taopti . e   . lgopti . tableau des options entieres               .
  33 c . lgoptr . e   .   1    . longueur du tableau des options reelles    .
  34 c . taoptr . es  . lgoptr . tableau des options                        .
  35 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  36 c . taopts . e   . lgopts . tableau des options caracteres             .
  37 c . option . e   .   1    . option de filtrage                         .
  38 c .        .     .        . 1 : par des groupes                        .
  39 c .        .     .        . 2 : par un diametre minimal                .
  40 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c .        .     .        . 5 : mauvais type de code de calcul associe .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57       character*6 nompro
  58       parameter ( nompro = 'VCFIA0' )
  59 c
  60 #include "nblang.h"
  61 #include "motcle.h"
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envex1.h"
  66 c
  67 #include "gmenti.h"
  68 #include "gmreel.h"
  69 #include "gmstri.h"
  70 c
  71 #include "envca1.h"
  72 #include "impr02.h"
  73 #include "nombmp.h"
  74 #include "nombar.h"
  75 #include "nombtr.h"
  76 #include "nombqu.h"
  77 #include "nombno.h"
  78 #include "nombte.h"
  79 #include "nombhe.h"
  80 #include "nombpy.h"
  81 #include "nombpe.h"
  82 #include "dicfen.h"
  83 #include "nbfamm.h"
  84 c
  85 c 0.3. ==> arguments
  86 c
  87       integer lgopti
  88       integer taopti(lgopti)
  89 c
  90       integer lgoptr
  91       double precision taoptr(lgoptr)
  92 c
  93       integer lgopts
  94       character*8 taopts(lgopts)
  95 c
  96       integer option
  97 c
  98       integer ulsort, langue, codret
  99 c
 100 c 0.4. ==> variables locales
 101 c
 102       integer codava
 103 c
 104       integer ngrofi, adgfpt, adgftb
 105       integer nbfmed, pnumfa, pgrpo, pgrtab
 106       integer nbfamd
 107       integer pcoono, psomar
 108       integer paretr, parequ
 109       integer ptrite, pcotrt, parete
 110       integer pquahe, pcoquh, parehe
 111       integer pfacpy, pcofay, parepy
 112       integer pfacpe, pcofap, parepe
 113       integer adhist, adcode, adcoar
 114       integer adfami, adcofa
 115       integer adinsu
 116       integer advotr, advoqu
 117       integer pvolfa
 118       integer typenh, nbento, nbencf, nbenca, nctfen, nbfenm
 119       integer typend
 120       integer admemo, admema, admemt, admemq
 121       integer adtra1, adtra2
 122 c
 123       integer codre1, codre2
 124       integer codre0
 125       integer iaux, jaux, kaux
 126       integer ideb, ifin
 127 c
 128       logical afaire
 129 c
 130       double precision diammi
 131 c
 132       character*6 saux
 133       character*8 nhenti
 134       character*8 typobs, obfiad, nomail
 135       character*8 norenu
 136       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 137       character*8 nhtetr, nhhexa, nhpyra, nhpent
 138       character*8 nhelig
 139       character*8 nhvois, nhsupe, nhsups
 140       character*8 ntrav1, ntrav2
 141 c
 142       integer nbmess
 143       parameter ( nbmess = 10 )
 144       character*80 texte(nblang,nbmess)
 145 c
 146 c 0.5. ==> initialisations
 147 c ______________________________________________________________________
 148 c
 149       codava = codret
 150 c
 151 c=======================================================================
 152       if ( codava.eq.0 ) then
 153 c=======================================================================
 154 c
 155 c====
 156 c 1. messages
 157 c====
 158 c
 159 #include "impr01.h"
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162       write (ulsort,texte(langue,1)) 'Entree', nompro
 163       call dmflsh (iaux)
 164 #endif
 165 c
 166       texte(1,4) = '(''Filtrage par des groupes'',/,24(''-''))'
 167       texte(1,5) = '(''Filtrage par un diametre minimal'',/,32(''-''))'
 168       texte(1,6) = '(/,''Influence sur les'',i10,1x,a)'
 169       texte(1,7) = '('' Diametre minimal :'',g15.6)'
 170       texte(1,8) =
 171      > '(/,''Aucun groupe n''''est present dans le maillage.'')'
 172       texte(1,9) = '(''L''''adaptation est supprimee.'')'
 173       texte(1,10) = '(''Nombre de '',a,'' filtres :'',i10,'' sur'',i10)'
 174 c
 175       texte(2,4) = '(''Filtering among groups'',/,22(''-''))'
 176       texte(2,5) =
 177      > '(''Filtering with a minimal diameter'',/,33(''-''))'
 178       texte(2,6) = '(/,''Influence over the'',i10,1x,a)'
 179       texte(2,7) = '('' Minimal diameter:'',g15.6)'
 180       texte(2,8) = '(/,''No group is present in the mesh.'')'
 181       texte(2,9) = '(''Adaptation is cancelled.'')'
 182       texte(2,10) =
 183      > '(''Number of filtered '',a,'':'',i10,'' over'',i10)'
 184 c
 185       if ( option.ge.1 .and. option.le.2 ) then
 186         write (ulsort,texte(langue,3+option))
 187       else
 188         codret = 1
 189       endif
 190 c
 191 #include "impr03.h"
 192 c
 193 c====
 194 c 2. les structures de base
 195 c====
 196 c
 197 c 2.1. ==> le maillage homard a l'iteration n
 198 c
 199       if ( codret.eq.0 ) then
 200 c
 201       typobs = mchman
 202       iaux = 0
 203       call utosno ( typobs, nomail, iaux, ulsort, langue, codret )
 204 c
 205       endif
 206 c
 207 c 2.2. ==> structure generale
 208 c
 209       if ( codret.eq.0 ) then
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 213 #endif
 214       call utnomh ( nomail,
 215      >                sdim,   mdim,
 216      >               degre, maconf, homolo, hierar,
 217      >              rafdef, nbmane, typcca, typsfr, maextr,
 218      >              mailet,
 219      >              norenu,
 220      >              nhnoeu, nhmapo, nharet,
 221      >              nhtria, nhquad,
 222      >              nhtetr, nhhexa, nhpyra, nhpent,
 223      >              nhelig,
 224      >              nhvois, nhsupe, nhsups,
 225      >              ulsort, langue, codret)
 226 c
 227       endif
 228 c
 229 c 2.3. ==> voisinages
 230 c
 231       if ( codret.eq.0 ) then
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 235 #endif
 236       iaux = 1
 237       if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 238         iaux = iaux*5
 239       endif
 240       if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 241         iaux = iaux*7
 242       endif
 243 c
 244       call utad04 ( iaux, nhvois,
 245      >                jaux,   jaux,  jaux,   jaux,
 246      >              advotr, advoqu,
 247      >                jaux,   jaux,  jaux,   jaux,
 248      >                jaux,   jaux,   jaux,
 249      >                jaux,   jaux,   jaux,
 250      >                jaux,   jaux,   jaux,
 251      >                jaux,   jaux,   jaux,
 252      >              ulsort, langue, codret )
 253 c
 254       endif
 255 c
 256 cgn      call gmprsx (nompro,obfiad)
 257 cgn      call gmprsx (nompro,obfiad//'.Pointeur')
 258 cgn      call gmprsx (nompro,obfiad//'.Taille')
 259 cgn      call gmprsx (nompro,obfiad//'.Table')
 260 c
 261 c====
 262 c 3. Prealables
 263 c====
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,90002) '3. Prealables ; codret', codret
 266 #endif
 267 c
 268       if ( codret.eq.0 ) then
 269 c
 270       afaire = .true.
 271 c
 272 c 3.1. ==> Prealable pour le filtrage par des groupes
 273 c
 274       if ( option.eq.1 ) then
 275 c
 276 c 3.1. ==> Decodage des adresses des groupes de filtrage
 277 c
 278         if ( codret.eq.0 ) then
 279 c
 280         obfiad = taopts(15)
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,3)) 'VCFIA1', nompro
 284 #endif
 285         call vcfia1 ( obfiad, nhsupe, nhsups,
 286      >                ngrofi, adgfpt, adgftb,
 287      >                nbfmed, pnumfa, pgrpo, pgrtab,
 288      >                ntrav1, adtra1, ntrav2, adtra2,
 289      >                ulsort, langue, codret )
 290 c
 291         endif
 292 c
 293 c 3.2. ==> Reperage des numeros de familles MED concernees
 294 c
 295         if ( codret.eq.0 ) then
 296 c
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,3)) 'VCFIA2', nompro
 299 #endif
 300         call vcfia2 ( ngrofi, imem(adgfpt), smem(adgftb),
 301      >                nbfmed, imem(pnumfa),
 302      >                imem(pgrpo), smem(pgrtab),
 303      >                nbfamd,
 304      >                imem(adtra1), imem(adtra2),
 305      >                ulsort, langue, codret )
 306 c
 307         endif
 308 c
 309 c 3.3. ==> Si aucun groupe n'est present, on ne fait plus ni
 310 c          raffinement ni deraffinement car aucune entite n'appartient
 311 c          aux groupes voulus
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,90002) '3.3. Suppression ; codret', codret
 314 #endif
 315 c
 316         if ( codret.eq.0 ) then
 317 c
 318         if ( nbfamd.eq.0 ) then
 319           taopti(27) = 0
 320           taopti(31) = 0
 321           taopti(32) = 0
 322           write (ulsort,texte(langue,8))
 323           write (ulsort,texte(langue,9))
 324           afaire = .false.
 325         endif
 326 c
 327         endif
 328 c
 329 c 3.4. ==> Menage
 330 c
 331         if ( codret.eq.0 ) then
 332 c
 333         call gmsgoj ( obfiad, codre1 )
 334         call gmlboj ( ntrav1, codre2 )
 335 c
 336         codre0 = min ( codre1, codre2 )
 337         codret = max ( abs(codre0), codret,
 338      >                 codre1, codre2 )
 339 c
 340         endif
 341 c
 342 c 3.2. ==> Prealable pour le filtrage par le diametre minimal
 343 c
 344       elseif ( option.eq.2 ) then
 345 c
 346         diammi = taoptr(3)
 347         write (ulsort,texte(langue,7)) diammi
 348 c
 349       endif
 350 c
 351       endif
 352 c
 353 c====
 354 c 4. Allocation du tableau de memorisation
 355 c    Par defaut, il est vide.
 356 c====
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,90002) '4. Allocation ; codret', codret
 359 #endif
 360 c
 361       if ( afaire ) then
 362 c
 363         if ( codret.eq.0 ) then
 364 c
 365         call gmalot ( obfiad, '10TabEnt', 0, iaux, codret )
 366         iaux = 30 - option
 367         taopts(iaux) = obfiad
 368 cgn      write (ulsort,90002) nompro, ', obfiad = ', obfiad,', iaux =', iaux
 369 c
 370         endif
 371 c
 372         if ( codret.eq.0 ) then
 373 c
 374         jaux = 0
 375         do 41 , iaux = 1 , 10
 376           if ( codret.eq.0 ) then
 377           call gmecat ( obfiad, iaux, jaux, codret )
 378           endif
 379    41   continue
 380 c
 381         endif
 382 c
 383       endif
 384 c
 385 c====
 386 c 5. Boucle sur tous les types d'entites
 387 c====
 388 #ifdef _DEBUG_HOMARD_
 389       write (ulsort,90002) '5. Boucle ; codret', codret
 390 #endif
 391 c
 392       if ( afaire ) then
 393 c
 394 c 5.1. ==> Type d'entites concernees
 395 c          . Pour les groupes : toutes
 396 c          . Pour le diametres : au moins des aretes
 397 c
 398       if ( codret.eq.0 ) then
 399 c
 400       if ( option.eq.1 ) then
 401         typend = -1
 402       else
 403         typend = 1
 404       endif
 405 c
 406       do 51 , typenh = typend , 7
 407 #ifdef _DEBUG_HOMARD_
 408       write (ulsort,*) '6. Boucle pour les ', mess14(langue,3,typenh)
 409 #endif
 410 c
 411 c 5.2. ==> Nombre d'entites concernees
 412 c
 413         if ( codret.eq.0 ) then
 414 c
 415         nbencf = 0
 416         nbenca = 0
 417 c
 418         if ( typenh.eq.-1 ) then
 419           nbento = nbnoto
 420           nctfen = nctfno
 421           nbfenm = nbfnom
 422           nhenti = nhnoeu
 423         elseif ( typenh.eq.0 ) then
 424           nbento = nbmpto
 425           nctfen = nctfmp
 426           nbfenm = nbfmpm
 427           nhenti = nhmapo
 428         elseif ( typenh.eq.1 ) then
 429           nbento = nbarto
 430           nctfen = nctfar
 431           nbfenm = nbfarm
 432           nhenti = nharet
 433         elseif ( typenh.eq.2 ) then
 434           nbento = nbtrto
 435           nctfen = nctftr
 436           nbfenm = nbftrm
 437           nhenti = nhtria
 438         elseif ( typenh.eq.3 ) then
 439           nbento = nbteto
 440           nbencf = nbtecf
 441           nbenca = nbteca
 442           nctfen = nctfte
 443           nbfenm = nbftem
 444           nhenti = nhtetr
 445         elseif ( typenh.eq.4 ) then
 446           nbento = nbquto
 447           nctfen = nctfqu
 448           nbfenm = nbfqum
 449           nhenti = nhquad
 450         elseif ( typenh.eq.5 ) then
 451           nbento = nbpyto
 452           nbencf = nbpycf
 453           nbenca = nbpyca
 454           nctfen = nctfpy
 455           nbfenm = nbfpym
 456           nhenti = nhpyra
 457         elseif ( typenh.eq.6 ) then
 458           nbento = nbheto
 459           nbencf = nbhecf
 460           nbenca = nbheca
 461           nctfen = nctfhe
 462           nbfenm = nbfhem
 463           nhenti = nhhexa
 464         elseif ( typenh.eq.7 ) then
 465           nbento = nbpeto
 466           nbencf = nbpecf
 467           nbenca = nbpeca
 468           nctfen = nctfpe
 469           nbfenm = nbfpem
 470           nhenti = nhpent
 471         endif
 472 c
 473         if ( nbento.ne.0 ) then
 474 c
 475 c 5.3. ==> Allocation de la branche de memorisation
 476 c          Pour les aretes, triangles, quadrangles, on s'en souvient
 477 c
 478           if ( codret.eq.0 ) then
 479 c
 480 #ifdef _DEBUG_HOMARD_
 481           write (ulsort,texte(langue,6)) nbento, mess14(langue,3,typenh)
 482 #endif
 483 c
 484           iaux = typenh + 2
 485           call utench ( iaux, 'g', jaux, saux,
 486      >                  ulsort, langue, codret )
 487 c
 488           endif
 489 c
 490           if ( codret.eq.0 ) then
 491 c
 492           saux = '.Tab'//saux(1:1)
 493 c
 494           call gmecat ( obfiad, iaux, nbento, codre1 )
 495           call gmaloj ( obfiad//saux, ' ', nbento, admemo, codre2 )
 496 c
 497           codre0 = min ( codre1, codre2 )
 498           codret = max ( abs(codre0), codret,
 499      >                   codre1, codre2 )
 500 c
 501           if ( typenh.eq.1 ) then
 502             admema = admemo
 503           elseif ( typenh.eq.2 ) then
 504             admemt = admemo
 505           elseif ( typenh.eq.4 ) then
 506             admemq = admemo
 507           endif
 508 c
 509           endif
 510 c
 511 c 5.4. ==> Adresses des caracteristiques des entites
 512 c          On prend les adresses de l'entite courante et ce qu'il faut
 513 c          pour calculer le diametre dans l'option 2
 514 c
 515 c 5.4.1. ==> Les noeuds
 516 c
 517           if ( codret.eq.0 ) then
 518 c
 519           iaux = 1
 520           if ( typenh.eq.-1 ) then
 521 c           fami, cofa
 522             iaux = 7
 523           elseif ( option.eq.2 ) then
 524 c           coordonnnes
 525             iaux = 3
 526           endif
 527 c
 528           if ( iaux.ne.1 ) then
 529 c
 530 #ifdef _DEBUG_HOMARD_
 531           write (ulsort,90002) 'iaux', iaux
 532           write (ulsort,texte(langue,3)) 'UTAD01', nompro
 533 #endif
 534             call utad01 ( iaux, nhnoeu,
 535      >                      jaux,
 536      >                    adfami, adcofa,   jaux,
 537      >                    pcoono,   jaux,   jaux,   jaux,
 538      >                    ulsort, langue, codret )
 539 c
 540           endif
 541 c
 542           endif
 543 c
 544 c 5.4.2. ==> Entite courante, si ce n'est pas un noeud :
 545 c            . 2*7*37 : famille et l'historique
 546 c            . 13  : codes pour les volumes (182 au final)
 547 c            . 31  : eventuelle connectivite par aretes (5462 au final)
 548 c
 549           if ( typenh.ne.-1 ) then
 550 c
 551             if ( codret.eq.0 ) then
 552 c
 553             iaux = 518
 554             if ( typenh.eq.3 .or. typenh.ge.5 ) then
 555               iaux = 13*iaux
 556             endif
 557             if ( nbenca.gt.0 ) then
 558               iaux = iaux*31
 559             endif
 560 #ifdef _DEBUG_HOMARD_
 561           write (ulsort,90002) 'iaux', iaux
 562           write (ulsort,texte(langue,3)) 'UTAD02-courant', nompro
 563 #endif
 564             call utad02 ( iaux, nhenti,
 565      >                    adhist, adcode,   jaux,   jaux,
 566      >                    adfami, adcofa,   jaux,
 567      >                    jaux  , adinsu,   jaux,
 568      >                      jaux,   jaux, adcoar,
 569      >                    ulsort, langue, codret )
 570 c
 571             endif
 572 c
 573             if ( codret.eq.0 ) then
 574 c
 575             if ( typenh.eq.1 ) then
 576               psomar = adcode
 577             elseif ( typenh.eq.2 ) then
 578               paretr = adcode
 579             elseif ( typenh.eq.3 ) then
 580               ptrite = adcode
 581               pcotrt = adinsu
 582               parete = adcoar
 583             elseif ( typenh.eq.4 ) then
 584               parequ = adcode
 585             elseif ( typenh.eq.5 ) then
 586               pfacpy = adcode
 587               pcofay = adinsu
 588               parepy = adcoar
 589             elseif ( typenh.eq.6 ) then
 590               pquahe = adcode
 591               pcoquh = adinsu
 592               parehe = adcoar
 593             elseif ( typenh.eq.7 ) then
 594               pfacpe = adcode
 595               pcofap = adinsu
 596               parepe = adcoar
 597             endif
 598 c
 599             endif
 600 c
 601           endif
 602 c
 603 c 5.4.3. ==> Complements pour les diametres
 604 c
 605           if ( option.eq.2 ) then
 606 c
 607 c 5.4.3.1. ==> Les aretes : toujours
 608 c
 609             if ( codret.eq.0 ) then
 610 c
 611             if ( typenh.ne.1 ) then
 612 c
 613               iaux = 2
 614 #ifdef _DEBUG_HOMARD_
 615           write (ulsort,texte(langue,3)) 'UTAD02-arete', nompro
 616 #endif
 617               call utad02 ( iaux, nharet,
 618      >                      kaux  , psomar,   jaux,   jaux,
 619      >                      jaux  ,   jaux,   jaux,
 620      >                      jaux  ,   jaux,   jaux,
 621      >                      jaux  ,   jaux,   jaux,
 622      >                      ulsort, langue, codret )
 623 c
 624               endif
 625 c
 626             endif
 627 c
 628 c 5.4.3.2. ==> Les triangles : pour les tetraedres ou les pyramides
 629 c
 630             if ( typenh.eq.3 .or. typenh.eq.5 ) then
 631 c
 632               if ( codret.eq.0 ) then
 633 c
 634               iaux = 2
 635 #ifdef _DEBUG_HOMARD_
 636           write (ulsort,texte(langue,3)) 'UTAD02-triangles', nompro
 637 #endif
 638               call utad02 ( iaux, nhtria,
 639      >                      kaux  , paretr,   jaux,   jaux,
 640      >                      jaux  ,   jaux,   jaux,
 641      >                      jaux  ,   jaux,   jaux,
 642      >                      jaux  ,   jaux,   jaux,
 643      >                      ulsort, langue, codret )
 644 c
 645               endif
 646 c
 647               endif
 648 c
 649 c 5.4.3.3. ==> Les quadrangles : pour les hexaedres ou les pentaedres
 650 c
 651             if ( typenh.ge.6 ) then
 652 c
 653               if ( codret.eq.0 ) then
 654 c
 655               iaux = 2
 656 #ifdef _DEBUG_HOMARD_
 657           write (ulsort,texte(langue,3)) 'UTAD02-quadrangles', nompro
 658 #endif
 659               call utad02 ( iaux, nhquad,
 660      >                      kaux  , parequ,   jaux,   jaux,
 661      >                      jaux  ,   jaux,   jaux,
 662      >                      jaux  ,   jaux,   jaux,
 663      >                      jaux  ,   jaux,   jaux,
 664      >                      ulsort, langue, codret )
 665 c
 666               endif
 667 c
 668             endif
 669 c
 670 c 5.4.3.4. ==> Les voisinages : pour les faces ou les aretes
 671 c
 672             if ( codret.eq.0 ) then
 673 c
 674               if ( typenh.eq.2 ) then
 675 c
 676                 pvolfa = advotr
 677 c
 678               elseif ( typenh.eq.4 ) then
 679 c
 680                 pvolfa = advoqu
 681 c
 682               endif
 683 c
 684             endif
 685 c
 686           endif
 687 c
 688 c 5.5. ==> Traitement
 689 c 5.5.1. ==> Traitement pour le filtrage par des groupes
 690 c
 691           if ( option.eq.1 ) then
 692 c
 693             if ( codret.eq.0 ) then
 694 c
 695 #ifdef _DEBUG_HOMARD_
 696           write (ulsort,texte(langue,3)) 'VCFIA3', nompro
 697 #endif
 698             call vcfia3 ( nbfamd, imem(adtra2),
 699      >                    typenh, nbento, nctfen, nbfenm,
 700      >                    imem(adfami), imem(adcofa),
 701      >                    imem(admemo),
 702      >                    ulsort, langue, codret )
 703 c
 704             endif
 705 c
 706 c 5.5.2. ==> Traitement pour le diametre minimal
 707 c
 708           elseif ( option.eq.2 ) then
 709 c
 710             if ( codret.eq.0 ) then
 711 c
 712 #ifdef _DEBUG_HOMARD_
 713           write (ulsort,texte(langue,3)) 'VCFIA4', nompro
 714 #endif
 715             call vcfia4 ( diammi,
 716      >                    typenh, nbento, nctfen, nbfenm,
 717      >                    imem(adfami), imem(adcofa),
 718      >                    rmem(pcoono), imem(psomar),
 719      >                    imem(paretr), imem(parequ),
 720      >                    imem(ptrite), imem(pcotrt), imem(parete),
 721      >                    imem(pquahe), imem(pcoquh), imem(parehe),
 722      >                    imem(pfacpy), imem(pcofay), imem(parepy),
 723      >                    imem(pfacpe), imem(pcofap), imem(parepe),
 724      >                    imem(pvolfa),
 725      >                    imem(admemo),
 726      >                    imem(admema), imem(admemt), imem(admemq),
 727      >                    ulsort, langue, codret )
 728 c
 729             endif
 730 c
 731           endif
 732 c
 733         endif
 734 c
 735         endif
 736 c
 737    51 continue
 738 c
 739       endif
 740 c
 741 cgn      if ( codret.eq.0 ) then
 742 cgn      if ( option.eq.2 ) then
 743 cgn      call gmprsx (nompro,obfiad)
 744 cgn      call gmprot (nompro,obfiad//'.Tab3', 1, nbarto)
 745 cgn      call gmprot (nompro,obfiad//'.Tab4', 1, nbtrto)
 746 cgn      call gmprot (nompro,obfiad//'.Tab5', 1, nbteto)
 747 cgn      endif
 748 cgn      endif
 749 c
 750       endif
 751 c
 752       if ( option.eq.1 ) then
 753 c
 754         if ( codret.eq.0 ) then
 755 c
 756         call gmlboj ( ntrav2, codre0 )
 757 c
 758         codret = max ( abs(codre0), codret )
 759 c
 760         endif
 761 c
 762       endif
 763 c
 764 c====
 765 c 6. Si toutes les entites sont retenues, on inhibe le filtrage
 766 c====
 767 c
 768       do 61 , typenh = -1 , 7
 769 c
 770 c 6.1. ==> Nombre de valeurs
 771 c
 772         if ( codret.eq.0 ) then
 773 c
 774         iaux = typenh + 2
 775         call gmliat ( obfiad, iaux, nbento, codret )
 776 c
 777         endif
 778 c
 779 c 6.2. ==> Adresse des valeurs s'il y en a
 780 c
 781         if ( codret.eq.0 ) then
 782 c
 783         if ( nbento.gt.0 ) then
 784 c
 785 #ifdef _DEBUG_HOMARD_
 786           write (ulsort,texte(langue,6)) nbento, mess14(langue,3,typenh)
 787 #endif
 788 c
 789           if ( codret.eq.0 ) then
 790 c
 791           iaux = typenh + 2
 792           call utench ( iaux, 'g', jaux, saux,
 793      >                  ulsort, langue, codret )
 794 c
 795           endif
 796 c
 797           if ( codret.eq.0 ) then
 798 c
 799           saux = '.Tab'//saux(1:1)
 800           call gmadoj ( obfiad//saux, admemo, iaux, codret )
 801 c
 802           endif
 803 c
 804 c 6.3. ==> Si toutes les entites sont retenues, on inhibe le filtrage
 805 c
 806           if ( codret.eq.0 ) then
 807 c
 808           ideb = admemo
 809           ifin = ideb + nbento - 1
 810           jaux = 0
 811           do 63 , iaux = ideb, ifin
 812             if ( imem(iaux).ne.0 ) then
 813               jaux = jaux + 1
 814             endif
 815    63     continue
 816 cc
 817 #ifdef _DEBUG_HOMARD_
 818           write (ulsort,texte(langue,10)) mess14(langue,3,typenh),
 819      >                                    jaux, nbento
 820 #endif
 821 c
 822           if ( jaux.eq.0 ) then
 823 c
 824             iaux = typenh + 2
 825             jaux = 0
 826             call gmecat ( obfiad, iaux, jaux, codre0 )
 827             codret = max ( abs(codre0), codret )
 828 c
 829           endif
 830 c
 831           endif
 832
 833         endif
 834 c
 835         endif
 836 c
 837    61 continue
 838 c
 839 c====
 840 c 7. la fin
 841 c====
 842 c
 843       if ( codret.ne.0 ) then
 844 c
 845 #include "envex2.h"
 846 c
 847       write (ulsort,texte(langue,1)) 'Sortie', nompro
 848       write (ulsort,texte(langue,2)) codret
 849 c
 850       endif
 851 c
 852 #ifdef _DEBUG_HOMARD_
 853       write (ulsort,texte(langue,1)) 'Sortie', nompro
 854       call dmflsh (iaux)
 855 #endif
 856 c
 857 c=======================================================================
 858       endif
 859 c=======================================================================
 860 c
 861       end