src/tool/AV_Conversion/vcindi.F

   1       subroutine vcindi ( lgopti, taopti, lgopts, taopts,
   2      >                    lgetco, taetco,
   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    aVant adaptation - Conversion d'INDIcateur
  25 c     -                 -            ----
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . lgopti . e   .   1    . longueur du tableau des options entieres   .
  31 c . taopti . e   . lgopti . tableau des options entieres               .
  32 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  33 c . taopts . e   . lgopts . tableau des options caracteres             .
  34 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  35 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  36 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  37 c . langue . e   .    1   . langue des messages                        .
  38 c .        .     .        . 1 : francais, 2 : anglais                  .
  39 c . codret . es  .    1   . code de retour des modules                 .
  40 c .        .     .        . 0 : pas de probleme                        .
  41 c .        .     .        . 5 : mauvais type de code de calcul associe .
  42 c ______________________________________________________________________
  43 c
  44 c====
  45 c 0. declarations et dimensionnement
  46 c====
  47 c
  48 c 0.1. ==> generalites
  49 c
  50       implicit none
  51       save
  52 c
  53       character*6 nompro
  54       parameter ( nompro = 'VCINDI' )
  55 c
  56 #include "nblang.h"
  57 #include "motcle.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "envex1.h"
  62 c
  63 #include "gmreel.h"
  64 #include "gmenti.h"
  65 #include "gmstri.h"
  66 c
  67 #include "envca1.h"
  68 #include "nombno.h"
  69 #include "nombar.h"
  70 #include "nombtr.h"
  71 #include "nombqu.h"
  72 #include "nombte.h"
  73 #include "nombpy.h"
  74 #include "nombhe.h"
  75 #include "nombpe.h"
  76 #include "refert.h"
  77 #include "impr02.h"
  78 c
  79 c 0.3. ==> arguments
  80 c
  81       integer lgopti
  82       integer taopti(lgopti)
  83 c
  84       integer lgopts
  85       character*8 taopts(lgopts)
  86 c
  87       integer lgetco
  88       integer taetco(lgetco)
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer codava
  95 c
  96       integer rvnoac, adnohn, adnoin, adnosu
  97       integer rvarac, adarhn, adarin, adarsu
  98       integer rvtrac, adtrhn, adtrin, adtrsu
  99       integer rvquac, adquhn, adquin, adqusu
 100       integer rvteac, adtehn, adtein, adtesu
 101       integer rvheac, adhehn, adhein, adhesu
 102       integer rvpyac, adpyhn, adpyin, adpysu
 103       integer rvpeac, adpehn, adpein, adpesu
 104       integer typenh
 105       integer adinca, adindi, nbtafo, nbenmx, nbpg, tyelho
 106       integer ncmpin, nucomp(100)
 107       integer adlipr, nbvapr
 108       integer nrpass
 109       integer nbcomp, nbtvch
 110       integer adnocp, adcaca
 111       integer nrotv
 112       integer nbelig
 113 c
 114       integer codre1, codre2
 115       integer codre0
 116       integer nretap, nrsset
 117       integer iaux, jaux, kaux
 118       integer nbvent(-1:7)
 119       integer nbvpen, nbvpyr, nbvhex, nbvtet
 120       integer nbvqua, nbvtri, nbvare, nbvnoe
 121       integer adpoin, adtail, adtabl
 122 c
 123       character*6 saux
 124       character*8 typobs, nocind, nohind, nomail
 125       character*8 oblist
 126       character*8 norenu
 127       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 128       character*8 nhtetr, nhhexa, nhpyra, nhpent
 129       character*8 nhelig
 130       character*8 nhvois, nhsupe, nhsups
 131       character*8 motaux
 132       character*8 nocham
 133       character*8 ntrava
 134 c
 135       logical nomaut, afaire
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 20 )
 139       character*80 texte(nblang,nbmess)
 140 c
 141 c 0.5. ==> initialisations
 142 c
 143       data motaux / 'ValeursR' /
 144 c ______________________________________________________________________
 145 c
 146       codava = codret
 147 c
 148 c=======================================================================
 149       if ( codava.eq.0 ) then
 150 c=======================================================================
 151 c
 152 c====
 153 c 1. messages
 154 c====
 155 c
 156 #include "impr01.h"
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,1)) 'Entree', nompro
 160       call dmflsh (iaux)
 161 #endif
 162 c
 163       texte(1,4) = '(/,a6,'' CONVERSION DE L''''INDICATEUR'')'
 164       texte(1,5) = '(33(''=''),/)'
 165       texte(1,6) = '(''Impossible de trouver le nom de la composante'')'
 166       texte(1,7) = '(''Nombre de composantes dans le champ :'',i4)'
 167       texte(1,8) = '(''Nombre de tableaux dans le champ    :'',i4)'
 168       texte(1,9) = '(/,''Examen du tableau numero'',i4)'
 169       texte(1,10) = '(''. Norme L2 des composantes.'')'
 170       texte(1,11) = '(''. Norme infinie des composantes.'')'
 171       texte(1,12) = '(''. Valeur relative de la composante.'')'
 172       texte(1,13) = '(''. Valeur absolue de la composante.'')'
 173       texte(1,15) = '(''Cette combinaison est impossible.'')'
 174       texte(1,17) = '(''Plusieurs champs sont presents pour les '',a)'
 175       texte(1,18) = '(''Il faut choisir un instant unique.'')'
 176 c
 177       texte(2,4) = '(/,a6,'' INDICATOR CONVERSION'')'
 178       texte(2,5) = '(27(''=''),/)'
 179       texte(2,6) = '(''The name of the component cannot be found.'')'
 180       texte(2,7) = '(''Number of components in the field:'',i4)'
 181       texte(2,8) = '(''Number of arrays in the field    :'',i4)'
 182       texte(2,9) = '(/,''Exam of array #'',i4)'
 183       texte(2,10) = '(''. L2 norm of components.'')'
 184       texte(2,11) = '(''. Infinite norm of components.'')'
 185       texte(2,12) = '(''. Relative value for the component.'')'
 186       texte(2,13) = '(''. Absolute value for the component.'')'
 187       texte(2,15) = '(''This situation cannot be solved.'')'
 188       texte(2,17) = '(''More than one field are defined over the '',a)'
 189       texte(2,18) = '(''A single time-step should be selected.'')'
 190 c
 191 #include "impr03.h"
 192 c
 193 c 1.4. ==> le numero de sous-etape
 194 c
 195       nretap = taetco(1)
 196       nrsset = taetco(2) + 1
 197       taetco(2) = nrsset
 198 c
 199       call utcvne ( nretap, nrsset, saux, iaux, codret )
 200 c
 201 c 1.5 ==> le titre
 202 c
 203       write (ulsort,texte(langue,4)) saux
 204       write (ulsort,texte(langue,5))
 205 c
 206 c====
 207 c 2. les structures de base
 208 c====
 209 c
 210 c 2.1. ==> le maillage homard a l'iteration n
 211 c
 212       if ( codret.eq.0 ) then
 213 c
 214       typobs = mchman
 215       iaux = 0
 216       call utosno ( typobs, nomail, iaux, ulsort, langue, codret )
 217 c
 218       endif
 219 c
 220 c 2.2. ==> structure generale
 221 c
 222       if ( codret.eq.0 ) then
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 226 #endif
 227       call utnomh ( nomail,
 228      >                sdim,   mdim,
 229      >               degre, maconf, homolo, hierar,
 230      >              rafdef, nbmane, typcca, typsfr, maextr,
 231      >              mailet,
 232      >              norenu,
 233      >              nhnoeu, nhmapo, nharet,
 234      >              nhtria, nhquad,
 235      >              nhtetr, nhhexa, nhpyra, nhpent,
 236      >              nhelig,
 237      >              nhvois, nhsupe, nhsups,
 238      >              ulsort, langue, codret)
 239 cgn      call gmprsx ( nompro, nhtria//'.InfoSupp' )
 240 cgn      call gmprsx ( nompro, norenu//'.PeCalcul' )
 241 cgn      call gmprsx ( nompro, nhquad//'.InfoSupp' )
 242 cgn      call gmprsx ( nompro, norenu//'.HeCalcul' )
 243 c
 244       endif
 245 c
 246 c 2.3. ==> l'indicateur du code de calcul
 247 c
 248       nocind = taopts(7)
 249 c
 250 c 2.4. ==> l'indicateur au format homard
 251 c          le nom est donne par l'utilisateur ou il est construit
 252 c          en tant qu'objet temporaire
 253 c
 254       if ( codret.eq.0 ) then
 255 c
 256       typobs = mchind
 257       iaux = 0
 258       call utosno ( typobs, nohind, iaux, ulsort, langue, codre1 )
 259 c
 260       if ( codre1.eq.0 ) then
 261         nomaut = .false.
 262       elseif ( codre1.eq.2 ) then
 263         nomaut = .true.
 264       else
 265         write (ulsort,texte(langue,6))
 266       endif
 267 c
 268       endif
 269 C
 270 c 2.5. ==> les eventuels elements elimines
 271 c
 272       if ( codret.eq.0 ) then
 273 c
 274       call gmliat ( nhelig, 1, nbelig, codret )
 275 c
 276       endif
 277 c
 278 c====
 279 c 3. recuperation des pointeurs associes a l'indicateur en entree
 280 c    et aux renumerotations
 281 c====
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,90002) '3. recuperation ; codret', codret
 284 #endif
 285 c
 286 c 3.1. ==> renumerotation
 287 c
 288       if ( codret.eq.0 ) then
 289 c
 290       iaux = -1
 291       jaux = 10
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,3)) 'UTRE03_no', nompro
 294 #endif
 295       call utre03 ( iaux, jaux, norenu,
 296      >              rvnoac,   kaux, adnohn,   kaux,
 297      >              ulsort, langue, codret)
 298 c
 299       endif
 300 c
 301       if ( codret.eq.0 ) then
 302 c
 303       iaux = 1
 304       jaux = -10
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro
 307 #endif
 308       call utre03 ( iaux, jaux, norenu,
 309      >              rvarac,   kaux, adarhn,   kaux,
 310      >              ulsort, langue, codret)
 311 c
 312       endif
 313 c
 314       if ( nbtrto.gt.0 ) then
 315 c
 316         if ( codret.eq.0 ) then
 317 c
 318         iaux = 2
 319         jaux = -10
 320 #ifdef _DEBUG_HOMARD_
 321         write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro
 322 #endif
 323         call utre03 ( iaux, jaux, norenu,
 324      >                rvtrac,   kaux, adtrhn,   kaux,
 325      >                ulsort, langue, codret)
 326 c
 327         endif
 328 c
 329       endif
 330 c
 331       if ( nbteto.gt.0 ) then
 332 c
 333       if ( codret.eq.0 ) then
 334 c
 335         iaux = 3
 336         jaux = -10
 337 #ifdef _DEBUG_HOMARD_
 338         write (ulsort,texte(langue,3)) 'UTRE03_te', nompro
 339 #endif
 340         call utre03 ( iaux, jaux, norenu,
 341      >                rvteac,   kaux, adtehn,   kaux,
 342      >                ulsort, langue, codret)
 343 c
 344         endif
 345 c
 346       endif
 347 c
 348       if ( nbquto.gt.0 ) then
 349 c
 350       if ( codret.eq.0 ) then
 351 c
 352         iaux = 4
 353         jaux = -10
 354 #ifdef _DEBUG_HOMARD_
 355       write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro
 356 #endif
 357         call utre03 ( iaux, jaux, norenu,
 358      >                rvquac,   kaux, adquhn,   kaux,
 359      >                ulsort, langue, codret)
 360 c
 361         endif
 362 c
 363       endif
 364 c
 365       if ( nbpyto.gt.0 ) then
 366 c
 367       if ( codret.eq.0 ) then
 368 c
 369         iaux = 5
 370         jaux = -10
 371 #ifdef _DEBUG_HOMARD_
 372       write (ulsort,texte(langue,3)) 'UTRE03_py', nompro
 373 #endif
 374         call utre03 ( iaux, jaux, norenu,
 375      >                rvpyac,   kaux, adpyhn,   kaux,
 376      >                ulsort, langue, codret)
 377 c
 378         endif
 379 c
 380       endif
 381 c
 382       if ( nbheto.gt.0 ) then
 383 c
 384       if ( codret.eq.0 ) then
 385 c
 386         iaux = 6
 387         jaux = -10
 388 #ifdef _DEBUG_HOMARD_
 389       write (ulsort,texte(langue,3)) 'UTRE03_he', nompro
 390 #endif
 391         call utre03 ( iaux, jaux, norenu,
 392      >                rvheac,   kaux, adhehn,   kaux,
 393      >                ulsort, langue, codret)
 394 c
 395         endif
 396 c
 397       endif
 398 c
 399       if ( nbpeto.gt.0 ) then
 400 c
 401       if ( codret.eq.0 ) then
 402 c
 403         iaux = 7
 404         jaux = -10
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro
 407 #endif
 408         call utre03 ( iaux, jaux, norenu,
 409      >                rvpeac,   kaux, adpehn,   kaux,
 410      >                ulsort, langue, codret)
 411 c
 412         endif
 413 c
 414       endif
 415 c
 416 #ifdef _DEBUG_HOMARD_
 417       write (ulsort,90002) 'rvnoac', rvnoac
 418       write (ulsort,90002) 'rvarac', rvarac
 419       write (ulsort,90002) 'rvtrac', rvtrac
 420       write (ulsort,90002) 'rvquac', rvquac
 421       write (ulsort,90002) 'rvteac', rvteac
 422       write (ulsort,90002) 'rvheac', rvheac
 423       write (ulsort,90002) 'rvpeac', rvpeac
 424       write (ulsort,90002) 'rvpyac', rvpyac
 425 #endif
 426 c
 427 #ifdef _DEBUG_HOMARD_
 428       call gmprsx (nompro, norenu )
 429       call gmprot (nompro, norenu//'.NoHOMARD', 1, 30 )
 430       call gmprot (nompro, norenu//'.ArHOMARD', 1, min(100,rvarac) )
 431       if ( rvtrac.ne.0 ) then
 432         call gmprot (nompro, norenu//'.TrHOMARD', 1, min(100,rvtrac) )
 433       endif
 434       if ( rvquac.ne.0 ) then
 435         call gmprot (nompro, norenu//'.QuHOMARD', 1, min(100,rvquac) )
 436       endif
 437       if ( rvteac.ne.0 ) then
 438         call gmprot (nompro, norenu//'.TeHOMARD', 1, min(100,rvteac) )
 439       endif
 440       if ( rvpyac.ne.0 ) then
 441         call gmprot (nompro, norenu//'.PYHOMARD', 1, min(100,rvpyac) )
 442       endif
 443       if ( rvheac.ne.0 ) then
 444         call gmprot (nompro, norenu//'.HeHOMARD', 1, min(100,rvheac) )
 445       endif
 446       if ( rvpeac.ne.0 ) then
 447         call gmprot (nompro, norenu//'.PeHOMARD', 1, min(100,rvpeac) )
 448       endif
 449       call gmprsx (nompro, norenu//'.HeHOMARD' )
 450       call gmprsx (nompro, norenu//'.PeHOMARD' )
 451       call gmprsx (nompro, norenu//'.InfoSupE' )
 452       call gmprsx (nompro, norenu//'.InfoSupE.Tab1' )
 453       call gmprsx (nompro, norenu//'.InfoSupE.Tab3' )
 454       call gmprsx (nompro, norenu//'.InfoSupE.Tab9' )
 455 #endif
 456 c
 457 c 3.2. ==> les caracteristiques de l'indicateur
 458 #ifdef _DEBUG_HOMARD_
 459       write (ulsort,90002) '3.2. caract. indic ; codret', codret
 460 #endif
 461 c
 462       if ( codret.eq.0 ) then
 463 c
 464 #ifdef _DEBUG_HOMARD_
 465       call gmprsx (nompro, nocind )
 466       call gmprsx (nompro, nocind//'.InfoCham' )
 467       call gmprsx (nompro, nocind//'.InfoPaFo' )
 468       call gmprsx (nompro, nocind//'.InfoProf' )
 469       call gmprsx (nompro, nocind//'.InfoLoPG' )
 470       call gmprsx (nompro, '%%%%%%11' )
 471       call gmprsx (nompro, '%%%%%%11.Nom_Comp' )
 472       call gmprsx (nompro, '%%%%%%11.Cham_Ent' )
 473       call gmprsx (nompro, '%%%%%%11.Cham_Ree' )
 474       call gmprsx (nompro, '%%%%%%11.Cham_Car' )
 475       call gmprsx (nompro, '%%%%%%13' )
 476       call gmprsx (nompro, '%%%%%%13.ValeursR' )
 477       call gmprsx (nompro, '%%%%%%14' )
 478       call gmprsx (nompro, '%%%%%%14.ValeursR' )
 479 #endif
 480 c
 481 #ifdef _DEBUG_HOMARD_
 482       write (ulsort,texte(langue,3)) 'VCIND0', nompro
 483 #endif
 484 c
 485       call vcind0 ( nocind,
 486      >              nocham, nbcomp, nbtvch, adnocp, adcaca,
 487      >              ulsort, langue, codret )
 488 c
 489 #ifdef _DEBUG_HOMARD_
 490       write (ulsort,texte(langue,7)) nbcomp
 491       write (ulsort,texte(langue,8)) nbtvch
 492 #endif
 493 c
 494       endif
 495 c
 496 c 3.3. ==> allocation de l'objet
 497 #ifdef _DEBUG_HOMARD_
 498       write (ulsort,90002) '3.3. allocation ; codret', codret
 499       write (ulsort,*) 'nomaut =', nomaut
 500 #endif
 501 c
 502       if ( codret.eq.0 ) then
 503 c
 504       if ( nomaut ) then
 505         call gmalot ( nohind, 'HOM_Indi', 0, iaux, codret )
 506       else
 507         call gmaloj ( nohind, 'HOM_Indi', 0, iaux, codret )
 508       endif
 509 c
 510       endif
 511 c
 512       if ( codret.eq.0 ) then
 513         taopts(8) = nohind
 514       endif
 515 c
 516 c 3.4. ==> noms des composantes retenues, si le champ contient
 517 c          plus d'une composante
 518 #ifdef _DEBUG_HOMARD_
 519       write (ulsort,90002) '3.4. nom des composantes ; codret', codret
 520 #endif
 521 c
 522       if ( nbcomp.gt.1 ) then
 523 c
 524         if ( codret.eq.0 ) then
 525 c
 526         typobs = mcccin
 527         iaux = 1
 528 #ifdef _DEBUG_HOMARD_
 529         write (ulsort,texte(langue,3)) 'UTMCLS', nompro
 530 #endif
 531         call utmcls ( typobs, iaux, oblist, jaux,
 532      >                ulsort, langue, codre0 )
 533 c
 534         endif
 535 c
 536 #ifdef _DEBUG_HOMARD_
 537       if ( codret.eq.0 ) then
 538       call gmprsx (nompro, oblist )
 539       call gmprsx (nompro, oblist//'.Pointeur' )
 540       call gmprsx (nompro, oblist//'.Taille' )
 541       call gmprsx (nompro, oblist//'.Table' )
 542       endif
 543 #endif
 544 c
 545         if ( codret.eq.0 ) then
 546 c
 547         iaux = 6
 548 #ifdef _DEBUG_HOMARD_
 549         write (ulsort,texte(langue,3)) 'UTADPT', nompro
 550 #endif
 551         call utadpt ( oblist, iaux,
 552      >                ncmpin, jaux,
 553      >                adpoin, adtail, adtabl,
 554      >                ulsort, langue, codret )
 555 c
 556         endif
 557 c
 558       endif
 559 c
 560 c 3.5. ==> Controle des composantes dans le champ
 561 #ifdef _DEBUG_HOMARD_
 562       write (ulsort,90002) '3.5. Controle ; codret', codret
 563 #endif
 564 c
 565       if ( codret.eq.0 ) then
 566 c
 567 #ifdef _DEBUG_HOMARD_
 568       write (ulsort,texte(langue,3)) 'VCIND1', nompro
 569 #endif
 570       call vcind1 ( nbcomp, smem(adnocp+8),
 571      >              ncmpin, imem(adpoin), imem(adtail), smem(adtabl),
 572      >              nucomp,
 573      >              ulsort, langue, codret )
 574 c
 575       endif
 576 c
 577       if ( codret.eq.0 ) then
 578 c
 579       if ( ncmpin.gt.1 ) then
 580         write (ulsort,texte(langue,10+taopti(8)))
 581         if ( taopti(8).eq.2 ) then
 582           write (ulsort,texte(langue,7)) ncmpin
 583           write (ulsort,texte(langue,10+taopti(8)))
 584           write (ulsort,texte(langue,15))
 585           codret = 35
 586         endif
 587       else
 588         if ( taopti(8).eq.2 ) then
 589           write (ulsort,texte(langue,12))
 590         else
 591           write (ulsort,texte(langue,13))
 592         endif
 593       endif
 594 c
 595       endif
 596 c
 597 c====
 598 c 4. conversion
 599 c====
 600 #ifdef _DEBUG_HOMARD_
 601       write (ulsort,90002) '4. conversion ; codret', codret
 602 #endif
 603 c 4.0. ==> Au depart, on fait comme si aucune indicateur n'etait present
 604 c          a priori, on met des adresses valant 1 pour que quand il n'y
 605 c          a pas de tableaux on garde la coherence de passage
 606 c          d'arguments avec imem
 607
 608       nbvnoe = 0
 609       nbvare = 0
 610       nbvtri = 0
 611       nbvqua = 0
 612       nbvtet = 0
 613       nbvpyr = 0
 614       nbvhex = 0
 615       nbvpen = 0
 616 c
 617       adnosu = 1
 618       adnoin = 1
 619       adarsu = 1
 620       adarin = 1
 621       adtrsu = 1
 622       adtrin = 1
 623       adqusu = 1
 624       adquin = 1
 625       adtesu = 1
 626       adtein = 1
 627       adpysu = 1
 628       adpyin = 1
 629       adhesu = 1
 630       adhein = 1
 631       adpesu = 1
 632       adpein = 1
 633 c
 634       do 40 , nrotv = 1 , nbtvch
 635 c
 636         afaire = .false.
 637 c
 638 #ifdef _DEBUG_HOMARD_
 639         write (ulsort,texte(langue,9)) nrotv
 640 #endif
 641 c
 642 c 4.1 ==> adresse de l'indicateur du code de calcul
 643 c         type de l'element au sens HOMARD
 644 c
 645         if ( codret.eq.0 ) then
 646 c
 647 #ifdef _DEBUG_HOMARD_
 648         write (ulsort,texte(langue,3)) 'VCIND2', nompro
 649 #endif
 650         nrpass = nrotv
 651         call vcind2 ( nrpass,
 652      >                smem(adcaca),
 653      >                adinca, nbtafo, nbenmx, nbpg, tyelho,
 654      >                adlipr, nbvapr,
 655      >                ulsort, langue, codret )
 656 c
 657         endif
 658 c
 659 #ifdef _DEBUG_HOMARD_
 660         write (ulsort,90002) 'tyelho', tyelho
 661 #endif
 662 c
 663 c 4.2. ==> allocation de l'objet
 664 c          remarque : on ne traite que les reels
 665 #ifdef _DEBUG_HOMARD_
 666       write (ulsort,90002) '4.2. Allocation ; codret', codret
 667 #endif
 668 c
 669 c 4.2.0. ==> prealable
 670 c
 671         if ( codret.eq.0 ) then
 672 c
 673         do 420 , iaux = -1 , 7
 674           nbvent(iaux) = 0
 675   420   continue
 676 c
 677         endif
 678 c
 679 c 4.2.1. ==> noeuds
 680 c
 681         if ( codret.eq.0 ) then
 682         if ( rvnoac.ne.0 .and.
 683      >       tyelho.eq.tyhnoe ) then
 684 c
 685           typenh = -1
 686           if ( nbvnoe.ne.0 ) then
 687             codret = 1000 + typenh
 688           else
 689 c
 690 #ifdef _DEBUG_HOMARD_
 691       write (ulsort,texte(langue,3)) 'UTALIH_no', nompro
 692 #endif
 693             call utalih ( nohind, typenh, nbnoto, ncmpin, motaux,
 694      >                    adnoin, adnosu,
 695      >                    ulsort, langue, codret)
 696             nbvent(typenh) = rvnoac
 697             afaire = .true.
 698 c
 699           endif
 700 c
 701         endif
 702         endif
 703 c
 704 c 4.2.2. ==> aretes
 705 c
 706         if ( codret.eq.0 ) then
 707         if ( rvarac.ne.0 .and.
 708      >       ( tyelho.eq.tyhse1 .or. tyelho.eq.tyhse2 ) ) then
 709 c
 710           typenh = 1
 711           if ( nbvare.ne.0 ) then
 712             codret = 1000 + typenh
 713           else
 714 c
 715 #ifdef _DEBUG_HOMARD_
 716       write (ulsort,texte(langue,3)) 'UTALIH_ar', nompro
 717 #endif
 718             call utalih ( nohind, typenh, nbarto, ncmpin, motaux,
 719      >                    adarin, adarsu,
 720      >                    ulsort, langue, codret)
 721             nbvent(typenh) = rvarac
 722             afaire = .true.
 723 c
 724         endif
 725 c
 726         endif
 727         endif
 728 c
 729 c 4.2.3. ==> triangles
 730 c
 731         if ( codret.eq.0 ) then
 732         if ( rvtrac.ne.0 .and.
 733      >       ( tyelho.eq.tyhtr1 .or. tyelho.eq.tyhtr2 .or.
 734      >         tyelho.eq.tyhtr3 ) ) then
 735 c
 736           typenh = 2
 737           if ( nbvtri.ne.0 ) then
 738             codret = 1000 + typenh
 739           else
 740 c
 741 #ifdef _DEBUG_HOMARD_
 742       write (ulsort,texte(langue,3)) 'UTALIH_tr', nompro
 743 #endif
 744             call utalih ( nohind, typenh, nbtrto, ncmpin, motaux,
 745      >                    adtrin, adtrsu,
 746      >                    ulsort, langue, codret)
 747             nbvent(typenh) = rvtrac
 748             afaire = .true.
 749 c
 750           endif
 751 c
 752         endif
 753         endif
 754 c
 755 c 4.2.4. ==> quadrangles
 756 c
 757         if ( codret.eq.0 ) then
 758         if ( rvquac.ne.0 .and.
 759      >       ( tyelho.eq.tyhqu1 .or. tyelho.eq.tyhqu2 .or.
 760      >         tyelho.eq.tyhqu3 ) ) then
 761 c
 762           typenh = 4
 763           if ( nbvqua.ne.0 ) then
 764             codret = 1000 + typenh
 765           else
 766 c
 767 #ifdef _DEBUG_HOMARD_
 768       write (ulsort,texte(langue,3)) 'UTALIH_qu', nompro
 769 #endif
 770             call utalih ( nohind, typenh, nbquto, ncmpin, motaux,
 771      >                    adquin, adqusu,
 772      >                    ulsort, langue, codret)
 773             nbvent(typenh) = rvquac
 774             afaire = .true.
 775 c
 776           endif
 777 c
 778         endif
 779         endif
 780 c
 781 c 4.2.5. ==> tetraedres
 782 c
 783         if ( codret.eq.0 ) then
 784         if ( rvteac.ne.0 .and.
 785      >       ( tyelho.eq.tyhte1 .or. tyelho.eq.tyhte2 ) ) then
 786 c
 787           typenh = 3
 788           if ( nbvtet.ne.0 ) then
 789             codret = 1000 + typenh
 790           else
 791 c
 792 #ifdef _DEBUG_HOMARD_
 793       write (ulsort,texte(langue,3)) 'UTALIH_te', nompro
 794 #endif
 795             call utalih ( nohind, typenh, nbteto, ncmpin, motaux,
 796      >                    adtein, adtesu,
 797      >                    ulsort, langue, codret)
 798             nbvent(typenh) = rvteac
 799             afaire = .true.
 800 c
 801           endif
 802 c
 803         endif
 804         endif
 805 c
 806 c 4.2.6. ==> pyramides
 807 c
 808         if ( codret.eq.0 ) then
 809         if ( rvpyac.ne.0 .and. nbelig.eq.0 .and.
 810      >       ( tyelho.eq.tyhpy1 .or. tyelho.eq.tyhpy2 ) ) then
 811 c
 812           typenh = 5
 813           if ( nbvpyr.ne.0 ) then
 814             codret = 1000 + typenh
 815           else
 816 c
 817 #ifdef _DEBUG_HOMARD_
 818       write (ulsort,texte(langue,3)) 'UTALIH_py', nompro
 819 #endif
 820             call utalih ( nohind, typenh, nbpyto, ncmpin, motaux,
 821      >                    adpyin, adpysu,
 822      >                    ulsort, langue, codret)
 823 c
 824             nbvent(typenh) = rvpyac
 825             afaire = .true.
 826 c
 827           endif
 828 c
 829         endif
 830         endif
 831 c
 832 c 4.2.7. ==> hexaedres
 833 c
 834         if ( codret.eq.0 ) then
 835         if ( rvheac.ne.0 .and.
 836      >       ( tyelho.eq.tyhhe1 .or. tyelho.eq.tyhhe2 .or.
 837      >         tyelho.eq.tyhhe3 ) ) then
 838 c
 839           typenh = 6
 840           if ( nbvhex.ne.0 ) then
 841             codret = 1000 + typenh
 842           else
 843 c
 844 #ifdef _DEBUG_HOMARD_
 845       write (ulsort,texte(langue,3)) 'UTALIH_he', nompro
 846 #endif
 847             call utalih ( nohind, typenh, nbheto, ncmpin, motaux,
 848      >                    adhein, adhesu,
 849      >                    ulsort, langue, codret)
 850 c
 851             nbvent(typenh) = rvheac
 852             afaire = .true.
 853 c
 854           endif
 855 c
 856         endif
 857         endif
 858 c
 859 c 4.2.8. ==> pentaedres
 860 c
 861         if ( codret.eq.0 ) then
 862         if ( rvpeac.ne.0 .and.
 863      >       ( tyelho.eq.tyhpe1 .or. tyelho.eq.tyhpe2 ) ) then
 864 c
 865           typenh = 7
 866           if ( nbvpen.ne.0 ) then
 867             codret = 1000 + typenh
 868           else
 869 c
 870 #ifdef _DEBUG_HOMARD_
 871       write (ulsort,texte(langue,3)) 'UTALIH_pe', nompro
 872 #endif
 873             call utalih ( nohind, typenh, nbpeto, ncmpin, motaux,
 874      >                    adpein, adpesu,
 875      >                    ulsort, langue, codret)
 876 c
 877             nbvent(typenh) = rvpeac
 878             afaire = .true.
 879 c
 880           endif
 881 c
 882         endif
 883         endif
 884 c
 885 c 4.3. ==> Si l'indicateur est exprime par points de Gauss, on le
 886 c          rapporte par maille
 887 #ifdef _DEBUG_HOMARD_
 888       write (ulsort,90002) '4.3. points de Gauss ; codret', codret
 889 #endif
 890 c
 891         if ( codret.eq.0 ) then
 892 c
 893         if ( nbpg.gt.1 ) then
 894 c
 895           if ( afaire ) then
 896 c
 897 #ifdef _DEBUG_HOMARD_
 898         write (ulsort,texte(langue,3)) 'VCIND3', nompro
 899 #endif
 900             call vcind3 ( nbtafo, nbenmx, rmem(adinca), nbpg,
 901      >                    ncmpin, nucomp,
 902      >                    adindi, ntrava,
 903      >                    ulsort, langue, codret)
 904 c
 905           endif
 906 c
 907         else
 908 c
 909           adindi = adinca
 910 c
 911         endif
 912 c
 913         endif
 914 c
 915 c 4.4. ==> conversion de l'indicateur en fonction de son type
 916 #ifdef _DEBUG_HOMARD_
 917       write (ulsort,90002) '4.4. en fct du type ; codret', codret
 918       write (ulsort,99001) 'afaire', afaire
 919 #endif
 920 c
 921         if ( codret.eq.0 ) then
 922 c
 923         if ( afaire ) then
 924 c
 925 #ifdef _DEBUG_HOMARD_
 926       write (ulsort,texte(langue,3)) 'VCINRR', nompro
 927 #endif
 928           call vcinrr ( nbvent,
 929      >                  imem(adnosu), rmem(adnoin),
 930      >                  imem(adarsu), rmem(adarin),
 931      >                  imem(adtrsu), rmem(adtrin),
 932      >                  imem(adqusu), rmem(adquin),
 933      >                  imem(adtesu), rmem(adtein),
 934      >                  imem(adhesu), rmem(adhein),
 935      >                  imem(adpysu), rmem(adpyin),
 936      >                  imem(adpesu), rmem(adpein),
 937      >                  nbvapr, imem(adlipr),
 938      >                  nbtafo, nbenmx, rmem(adindi),
 939      >                  ncmpin, nucomp,
 940      >                  imem(adnohn),
 941      >                  imem(adarhn),
 942      >                  imem(adtrhn),
 943      >                  imem(adquhn),
 944      >                  imem(adtehn),
 945      >                  imem(adhehn),
 946      >                  imem(adpyhn),
 947      >                  imem(adpehn),
 948      >                  ulsort, langue, codret)
 949 c
 950         endif
 951 c
 952         endif
 953 c
 954 c 4.5. ==> menage eventuel
 955 #ifdef _DEBUG_HOMARD_
 956       write (ulsort,90002) '4.5. Menage ; codret', codret
 957 #endif
 958 c
 959         if ( codret.eq.0 ) then
 960 c
 961         if ( nbpg.gt.1 .and. afaire ) then
 962 c
 963         call gmlboj ( ntrava , codret )
 964 c
 965         endif
 966 c
 967         endif
 968 c
 969         nbvnoe = nbvnoe + nbvent(-1)
 970         nbvare = nbvare + nbvent(1)
 971         nbvtri = nbvtri + nbvent(2)
 972         nbvqua = nbvqua + nbvent(4)
 973         nbvtet = nbvtet + nbvent(3)
 974         nbvpyr = nbvpyr + nbvent(5)
 975         nbvhex = nbvhex + nbvent(6)
 976         nbvpen = nbvpen + nbvent(7)
 977 c
 978    40 continue
 979 c
 980 c====
 981 c 5. menage
 982 c====
 983 #ifdef _DEBUG_HOMARD_
 984       write (ulsort,90002) '5. menage ; codret', codret
 985 #endif
 986 c
 987       if ( codret.eq.0 ) then
 988 c
 989       call gmsgoj ( nocind, codre1 )
 990       if ( nbcomp.gt.1 ) then
 991         call gmsgoj ( oblist, codre2 )
 992       else
 993         codre2 = 0
 994       endif
 995 c
 996       codre0 = min ( codre1, codre2 )
 997       codret = max ( abs(codre0), codret,
 998      >               codre1, codre2 )
 999 c
1000       endif
1001 c
1002 #ifdef _DEBUG_HOMARD_
1003       if ( codret.eq.0 ) then
1004 c
1005       call gmprsx(nompro, nohind)
1006 c
1007       call gmprsx(nompro, nohind//'.Noeud')
1008       call gmprot (nompro, nohind//'.Noeud.Support' , 1, 10 )
1009       call gmprot (nompro, nohind//'.Noeud.'//motaux , 1, 10 )
1010       if ( nbnoto.gt.10 ) then
1011         call gmprot (nompro, nohind//'.Noeud.Support',nbnoto-9,nbnoto)
1012         call gmprot (nompro, nohind//'.Noeud.'//motaux,nbnoto-9,nbnoto)
1013       endif
1014 c
1015       call gmprot (nompro, nohind//'.Arete.'//motaux , 1, 10 )
1016       if ( nbarto.gt.10 ) then
1017         call gmprot (nompro, nohind//'.Arete.'//motaux,nbarto-9,nbarto)
1018       endif
1019 c
1020       if ( nbtrto.gt.0 ) then
1021         call gmprot (nompro, nohind//'.Trian.'//motaux , 1, 10 )
1022         if ( nbtrto.gt.10 ) then
1023          call gmprot (nompro, nohind//'.Trian.'//motaux,nbtrto-9,nbtrto)
1024         endif
1025       endif
1026 c
1027       if ( nbquto.gt.0 ) then
1028         if ( nbquto.gt.50 ) then
1029         call gmprot (nompro, nohind//'.Quadr.'//motaux , 1, 50 )
1030         call gmprot (nompro, nohind//'.Quadr.'//motaux,nbquto-49,nbquto)
1031         else
1032           call gmprsx (nompro, nohind//'.Quadr.Support' )
1033           call gmprsx (nompro, nohind//'.Quadr.'//motaux )
1034         endif
1035       endif
1036 c
1037       if ( nbteto.gt.0 ) then
1038         call gmprot (nompro, nohind//'.Tetra.'//motaux , 1, 10 )
1039         if ( nbteto.gt.10 ) then
1040         call gmprot (nompro, nohind//'.Tetra.'//motaux,nbteto-9,nbteto)
1041         endif
1042       endif
1043 c
1044       if ( nbelig.eq.0 .and. nbpyto.gt.0 ) then
1045         call gmprot (nompro, nohind//'.Pyram.'//motaux , 1, 10 )
1046         if ( nbpyto.gt.10 ) then
1047         call gmprot (nompro, nohind//'.Pyram.'//motaux,nbpyto-9,nbpyto)
1048         endif
1049       endif
1050 c
1051       if ( nbheto.gt.0 ) then
1052         call gmprot (nompro, nohind//'.Hexae.'//motaux , 1, 10 )
1053         if ( nbheto.gt.10 ) then
1054         call gmprot (nompro, nohind//'.Hexae.'//motaux,nbheto-9,nbheto)
1055         endif
1056       endif
1057 c
1058       if ( nbpeto.gt.0 ) then
1059         call gmprot (nompro, nohind//'.Penta.'//motaux , 1, 10 )
1060         if ( nbpeto.gt.10 ) then
1061         call gmprot (nompro, nohind//'.Penta.'//motaux,nbpeto-9,nbpeto)
1062         endif
1063       endif
1064 c
1065       endif
1066 #endif
1067 c
1068 c====
1069 c 6. la fin
1070 c====
1071 c
1072       if ( codret.ne.0 ) then
1073 c
1074 #include "envex2.h"
1075 c
1076       write (ulsort,texte(langue,1)) 'Sortie', nompro
1077       write (ulsort,texte(langue,2)) codret
1078       if ( codret.ge.999 ) then
1079         typenh = codret - 1000
1080         write (ulsort,texte(langue,17)) mess14(langue,3,typenh)
1081         write (ulsort,texte(langue,18))
1082       endif
1083 c
1084       endif
1085 c
1086 #ifdef _DEBUG_HOMARD_
1087       write (ulsort,texte(langue,1)) 'Sortie', nompro
1088       call dmflsh (iaux)
1089 #endif
1090 c
1091 c=======================================================================
1092       endif
1093 c=======================================================================
1094 c
1095       end