src/tool/AP_Conversion/pcfore.F

   1       subroutine pcfore ( option, extrus,
   2      >                    nnfopa, anobfo,
   3      >                    npfopa, nppafo,
   4      >                    nbpara, carenf, carchf,
   5      >                    nbtrav, litrav,
   6      >                    adpetr, adhequ,
   7      >                    adnohn, admphn, adarhn, adtrhn, adquhn,
   8      >                    adtehn, adpyhn, adhehn, adpehn,
   9      >                    adnocn, admpcn, adarcn, adtrcn, adqucn,
  10      >                    adtecn, adpycn, adhecn, adpecn,
  11      >                    adnoin, admpin, adarin, adtrin, adquin,
  12      >                    adtein, adpyin, adhein, adpein,
  13      >                    lgnoin, lgmpin, lgarin, lgtrin, lgquin,
  14      >                    lgtein, lgpyin, lghein, lgpein,
  15      >                    decanu,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  24 c aupres des huissiers de justice Simart et Lavoir a Clamart
  25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  26 c aupres des huissiers de justice
  27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c    aPres adaptation - Fonctions - REcuperation
  38 c     -                 --          --
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . option . e   .    1   . option du traitement                       .
  44 c .        .     .        . -1 : Pas de changement dans le maillage    .
  45 c .        .     .        .  0 : Adaptation complete                   .
  46 c .        .     .        .  1 : Modification de degre                 .
  47 c . extrus . e   .    1   . prise en compte d'extrusion                .
  48 c . nnfopa . e   .   1    . nombre de fonctions du paquet iteration n  .
  49 c . anobfo . e   .   1    . adresse des noms des fonctions n           .
  50 c . npfopa .  s  .   1    . nombre de fonctions du paquet iteration p  .
  51 c . nppafo . es  .    1   . nom du paquet de fonctions iteration p     .
  52 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  53 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  54 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  55 c .        .     .        .      1, pour une ancienne associee a une   .
  56 c .        .     .        .         autre fonction                     .
  57 c .        .     .        .      -1, pour une nouvelle fonction        .
  58 c .        .     .        .  2 : typcha                                .
  59 c .        .     .        .  3 : typgeo                                .
  60 c .        .     .        .  4 : nbtyas                                .
  61 c .        .     .        .  5 : ngauss                                .
  62 c .        .     .        .  6 : nnenmx                                .
  63 c .        .     .        .  7 : nnvapr                                .
  64 c .        .     .        .  8 : carsup                                .
  65 c .        .     .        .  9 : nbtafo                                .
  66 c .        .     .        . 10 : anvale                                .
  67 c .        .     .        . 11 : anvalr                                .
  68 c .        .     .        . 12 : anobch                                .
  69 c .        .     .        . 13 : anprpg                                .
  70 c .        .     .        . 14 : anlipr                                .
  71 c .        .     .        . 15 : npenmx                                .
  72 c .        .     .        . 16 : npvapr                                .
  73 c .        .     .        . 17 : apvale                                .
  74 c .        .     .        . 18 : apvalr                                .
  75 c .        .     .        . 19 : apobch                                .
  76 c .        .     .        . 20 : apprpg                                .
  77 c .        .     .        . 21 : apvatt                                .
  78 c .        .     .        . 22 : apvane                                .
  79 c .        .     .        . 23 : antyas                                .
  80 c .        .     .        . 24 : aptyas                                .
  81 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  82 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  83 c . carchf . es  .nbpara* . caracteristiques caracteres des fonctions :.
  84 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  85 c .        .     .        .  2 : nom de la fonction n associee         .
  86 c .        .     .        .  3 : nom de la fonction p associee         .
  87 c .        .     .        .  4 : obpcan                                .
  88 c .        .     .        .  5 : obpcap                                .
  89 c .        .     .        .  6 : obprof                                .
  90 c .        .     .        .  7 : oblopg                                .
  91 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  92 c .        .     .        .      fonction n ELNO correspondante        .
  93 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  94 c .        .     .        .      fonction p ELNO correspondante        .
  95 c . nbtrav . es  .   1    . nombre de tableaux de travail crees        .
  96 c . litrav . es  .   *    . liste des noms de tableaux de travail crees.
  97 c . adnohn . e   .   1    . adresse de la renum. des noeuds en entree  .
  98 c . admphn . e   .   1    . adresse de la renum. des m.poi. en entree  .
  99 c . adarhn . e   .   1    . adresse de la renum. des aretes en entree  .
 100 c . adtrhn . e   .   1    . adresse de la renum. des tria. en entree   .
 101 c . adquhn . e   .   1    . adresse de la renum. des quad. en entree   .
 102 c . adtehn . e   .   1    . adresse de la renum. des tetras. en entree .
 103 c . adpyhn . e   .   1    . adresse de la renum. des pyras. en entree  .
 104 c . adhehn . e   .   1    . adresse de la renum. des hexas. en entree  .
 105 c . adpehn . e   .   1    . adresse de la renum. des pentas. en entree .
 106 c . decanu . e   .  -1:7  . decalage des numerotations selon le type   .
 107 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 108 c . langue . e   .    1   . langue des messages                        .
 109 c .        .     .        . 1 : francais, 2 : anglais                  .
 110 c . codret . es  .    1   . code de retour des modules                 .
 111 c .        .     .        . 0 : pas de probleme                        .
 112 c .        .     .        . 1 : probleme                               .
 113 c ______________________________________________________________________
 114 c
 115 c====
 116 c 0. declarations et dimensionnement
 117 c====
 118 c
 119 c 0.1. ==> generalites
 120 c
 121       implicit none
 122       save
 123 c
 124       character*6 nompro
 125       parameter ( nompro = 'PCFORE' )
 126 c
 127 #include "nblang.h"
 128 #include "consts.h"
 129 #include "meddc0.h"
 130 c
 131 c 0.2. ==> communs
 132 c
 133 #include "envex1.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136 #include "gmreel.h"
 137 #endif
 138 #include "gmenti.h"
 139 #include "gmstri.h"
 140 c
 141 #include "nombtr.h"
 142 #include "nombhe.h"
 143 #include "nombpe.h"
 144 #include "nbutil.h"
 145 #include "nomber.h"
 146 #include "nombsr.h"
 147 #include "esutil.h"
 148 c
 149 c 0.3. ==> arguments
 150 c
 151       integer option
 152       integer nbpara
 153       integer nnfopa, anobfo
 154       integer npfopa
 155       integer nbtrav
 156       integer adpetr, adhequ
 157       integer carenf(nbpara,*)
 158       integer adnohn, admphn, adarhn, adtrhn, adquhn
 159       integer adtehn, adpyhn, adhehn, adpehn
 160       integer adnocn, admpcn, adarcn, adtrcn, adqucn
 161       integer adtecn, adpycn, adhecn, adpecn
 162       integer adnoin, admpin, adarin, adtrin, adquin
 163       integer adtein, adpyin, adhein, adpein
 164       integer lgnoin, lgmpin, lgarin, lgtrin, lgquin
 165       integer lgtein, lgpyin, lghein, lgpein
 166       integer decanu(-1:7)
 167 c
 168       character*8 nppafo
 169       character*8 carchf(nbpara,*)
 170       character*8 litrav(*)
 171 c
 172       logical extrus
 173 c
 174       integer ulsort, langue, codret
 175 c
 176 c 0.4. ==> variables locales
 177 c
 178       integer iaux, jaux, kaux, laux, maux, naux
 179       integer nrfonc, nrfonm
 180       integer nbent2, ngaus2, dimcp2, typge2, nrfon2
 181       integer nbent3, ngaus3, dimcp3, typge3, nrfon3
 182 c
 183       integer typfon, typcha, typgeo, nbtyas
 184       integer ngauss, nnenmx, nnvapr
 185       integer carsup, nbtafo, typint
 186       integer anvale, anvalr, anobch, anprpg, antyas
 187       integer apvale, apvalr, apobch, apprpg, aptyas
 188       integer nbpg, nbsufo
 189       integer anlipr
 190       integer apvatt
 191       integer apobfo, aptyge
 192       integer apobfa, aptyga
 193       integer adtra1
 194 c
 195       integer reenac, rsenac
 196       integer advofa, advohn, advocn
 197       integer adenhn, adencn
 198       integer lgenin, adenin
 199       integer adpcan, adpcap
 200       integer tbiaux(nbinec), lgtbix
 201       integer decala
 202 c
 203       character*8 nnfonc
 204       character*8 obpcan, obpcap, oblopg
 205       character*8 oblop2
 206       character*8 oblop3
 207       character*8 nppafa
 208       character*8 saux08
 209       character*8 tbsaux(1)
 210       character*8 ntrav1
 211       character*64 noprof
 212       character*64 nolop2
 213       character*64 nolop3
 214 c
 215       logical afair2, afair3
 216       logical extrul
 217 c
 218       integer nbmess
 219       parameter ( nbmess = 120 )
 220       character*80 texte(nblang,nbmess)
 221 c
 222 c 0.5. ==> initialisations
 223 c ______________________________________________________________________
 224 c
 225 c====
 226 c 1. initialisations
 227 c====
 228 c
 229 #include "impr01.h"
 230 c
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,texte(langue,1)) 'Entree', nompro
 233       call dmflsh (iaux)
 234 #endif
 235 c
 236 #include "esimpr.h"
 237 c
 238       texte(1,4) = '(/,60(''-''),/,''Fonction '',i3,'', objet = '',a)'
 239       texte(1,5) = '(''Type de support geometrique :'',i5)'
 240       texte(1,6) = '(''On ne sait pas faire aujourd''''hui.'',/)'
 241       texte(1,7) = '(/,''Creation de la fonction a l''''iteration p'')'
 242       texte(1,8) = '(/,''Probleme de conformite ?'')'
 243       texte(1,9) =
 244      > '(/,''Creation d''''une fonction pour la conformite'')'
 245       texte(1,10) = '(''En retour de '',a,'', codret ='',i13)'
 246       texte(1,13) = '(''... Premiere valeur : '',g14.7)'
 247       texte(1,14) = '(''... Derniere valeur : '',g14.7)'
 248       texte(1,15) = '(''... Profil : '',a32)'
 249       texte(1,16) = '(''... Premiere(s) valeur(s) : '',5i10)'
 250       texte(1,17) = '(''... Derniere(s) valeur(s) : '',5i10)'
 251       texte(1,18) =
 252      > '(''Les deux longueurs de profil sont differentes !'')'
 253       texte(1,19) = '(''Caracteristiques du support :'',i5)'
 254 c
 255       texte(2,4) = '(/,60(''-''),/,''Function '',i3,'', objet = '',a)'
 256       texte(2,5) = '(''Geometric support type :'',i5)'
 257       texte(2,6) = '(''It cannot be solved.'',/)'
 258       texte(2,7) = '(/,''Creation of a function for iteration # p'')'
 259       texte(2,8) = '(/,''Pending nodes ?'')'
 260       texte(2,9) = '(/,''Creation of a function for pending nodes'')'
 261       texte(2,10) = '(''Back from '',a,'', codret ='',i13)'
 262       texte(2,13) = '(''... First value : '',g14.7)'
 263       texte(2,14) = '(''... Last value  : '',g14.7)'
 264       texte(2,15) = '(''... Profile : '',a32)'
 265       texte(2,16) = '(''... First value(s) : '',5i10)'
 266       texte(2,17) = '(''... Last value(s)  : '',5i10)'
 267       texte(2,18) =
 268      > '(''The two lengths of profile are not the same !'')'
 269       texte(2,19) = '(''Characteristics of the support:'',i5)'
 270 c
 271 #include "impr03.h"
 272 c
 273       npfopa = 0
 274       nrfonm = nnfopa
 275 c
 276 c====
 277 c 2. prealable pour les couples (aux noeuds par element/aux points
 278 c    de Gauss)
 279 c====
 280 c
 281 c 2.1. ==> decodage de nppafo, paquet a l'iteration p
 282 c
 283 #ifdef _DEBUG_HOMARD_
 284 cgn      call gmprsx (nompro,nppafo)
 285 cgn      call gmprsx (nompro,nppafo//'.Fonction')
 286 cgn      call gmprsx (nompro,nppafo//'.TypeSuAs')
 287       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 288 #endif
 289       call utcapf ( nppafo,
 290      >              iaux, jaux, kaux, laux, maux,
 291      >              apobfo, aptyge,
 292      >              ulsort, langue, codret )
 293 c
 294 c 2.2. ==> si c'est un champ aux points de Gauss, on repere nppafa,
 295 c          paquet correspondant, a l'iteration p.
 296 c
 297       if ( laux.eq.2 ) then
 298 c
 299         if ( codret.eq.0 ) then
 300 c
 301         nppafa = smem(apobfo+npfopa)
 302 cgn        write (ulsort,*) 'Paquet correspondant ==> ',nppafa
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 306       call gmprsx (nompro,nppafa)
 307       call gmprsx (nompro,nppafa//'.Fonction')
 308 #endif
 309         call utcapf ( nppafa,
 310      >                iaux, jaux, kaux, laux, maux,
 311      >                apobfa, aptyga,
 312      >                ulsort, langue, codret )
 313 c
 314         endif
 315 c
 316         endif
 317 c
 318 c====
 319 c 3. parcours des fonctions du paquet a l'iteration n
 320 c====
 321 c
 322       do 30 , nrfonc = 1 , nnfopa
 323 c
 324         nnfonc = smem(anobfo+nrfonc-1)
 325 c
 326 #ifdef _DEBUG_HOMARD_
 327         write (ulsort,texte(langue,4)) nrfonc, nnfonc
 328         call gmprsx (nompro,nnfonc)
 329         call gmprsx (nompro,nnfonc//'.InfoPrPG')
 330         call gmprsx (nompro,nnfonc//'.TypeSuAs')
 331 #endif
 332 c
 333 c 3.1. ==> caracteristiques de la fonction a l'iteration n
 334 c
 335         if ( codret.eq.0 ) then
 336 c
 337 #ifdef _DEBUG_HOMARD_
 338         write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 339 #endif
 340         call utcafo ( nnfonc,
 341      >                typcha,
 342      >                typgeo, ngauss, nnenmx, nnvapr, nbtyas,
 343      >                carsup, nbtafo, typint,
 344      >                anvale, anvalr, anobch, anprpg, antyas,
 345      >                ulsort, langue, codret )
 346 c
 347 #ifdef _DEBUG_HOMARD_
 348         write (ulsort,texte(langue,10)) 'utcafo', codret
 349 #endif
 350 c
 351         nbpg = ngauss
 352         oblopg = smem(anprpg+1)
 353 c
 354         endif
 355 c
 356         if ( codret.eq.0 ) then
 357 c
 358 #ifdef _DEBUG_HOMARD_
 359         write (ulsort,90002) 'typgeo', typgeo
 360         write (ulsort,90002) 'ngauss', ngauss
 361         write (ulsort,90002) 'nnenmx', nnenmx
 362         write (ulsort,90002) 'nnvapr', nnvapr
 363         write (ulsort,90002) 'nbtyas', nbtyas
 364         if ( nbtyas.gt.0 ) then
 365         write (ulsort,90002)
 366      >  '==> typass', (imem(antyas+iaux-1),iaux=1,nbtyas)
 367         endif
 368         write (ulsort,90002) 'carsup', carsup
 369         write (ulsort,90002) 'nbtafo', nbtafo
 370         write (ulsort,*) '.. oblopg : ', oblopg
 371 cgn        write (ulsort,texte(langue,13)) rmem(anvalr)
 372 cgn        write (ulsort,texte(langue,14))
 373 cgn     >  rmem(anvalr+nnenmx*nbtafo*nbpg-1)
 374 #endif
 375 c
 376         if ( nbtyas.ge.1 ) then
 377           typfon = 1
 378         else
 379           typfon = 0
 380         endif
 381         carenf( 1,nrfonc) = typfon
 382         carenf( 2,nrfonc) = typcha
 383         carenf( 3,nrfonc) = typgeo
 384         carenf( 4,nrfonc) = nbtyas
 385         carenf( 5,nrfonc) = nbpg
 386         carenf( 6,nrfonc) = nnenmx
 387         carenf( 7,nrfonc) = nnvapr
 388         carenf( 8,nrfonc) = carsup
 389         carenf( 9,nrfonc) = nbtafo
 390         carenf(10,nrfonc) = anvale
 391         carenf(11,nrfonc) = anvalr
 392         carenf(12,nrfonc) = anobch
 393         carenf(13,nrfonc) = anprpg
 394         carenf(23,nrfonc) = antyas
 395 c
 396         carchf( 2,nrfonc) = nnfonc
 397         carchf( 7,nrfonc) = oblopg
 398 c
 399         endif
 400 c
 401 c 3.2. ==> pour une fonction aux points de Gausss avec un champ aux
 402 c          noeuds par elements associe, la fonction associee
 403 c
 404         if ( carsup.eq.2 ) then
 405 c
 406         if ( codret.eq.0 ) then
 407 c
 408         carchf(8,nrfonc) = smem(anprpg+2)
 409         carchf(9,nrfonc) = smem(apobfa+nrfonc-1)
 410 cgn        call gmprsx (nompro,carchf(9,nrfonc))
 411 c
 412         endif
 413 c
 414         endif
 415 c
 416 c 3.3. ==> le profil eventuel
 417 c
 418         if ( nnvapr.gt.0 ) then
 419 c
 420 c 3.3.1. ==> les caracteristiques du profil
 421 c
 422           if ( codret.eq.0 ) then
 423 c
 424 #ifdef _DEBUG_HOMARD_
 425         write (ulsort,texte(langue,3)) 'UTCAPR', nompro
 426 #endif
 427           call utcapr ( smem(anprpg),
 428      >                  jaux, noprof, anlipr,
 429      >                  ulsort, langue, codret )
 430 c
 431           endif
 432 c
 433           if ( codret.eq.0 ) then
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436           write (ulsort,texte(langue,10)) 'utcapr', codret
 437           write (ulsort,texte(langue,13)) 'jaux', jaux
 438           write (ulsort,texte(langue,15)) noprof
 439           write (ulsort,texte(langue,16))
 440      >                    (imem(anlipr+iaux),iaux=0,min(4,jaux-1))
 441           if ( nnvapr.gt.5 ) then
 442             write (ulsort,texte(langue,17))
 443      >                    (imem(anlipr+iaux),iaux=jaux-5,jaux-1)
 444           endif
 445 #endif
 446 c
 447 c 3.3.2. ==> on verifie que les longueurs sont bien les memes : celle
 448 c            enregistree dans le profil, jaux, et celle enregistree
 449 c            dans la fonction, nnvapr.
 450 c
 451           if ( jaux.ne.nnvapr ) then
 452             write (ulsort,90002) 'nnvapr', nnvapr
 453             write (ulsort,90002) 'jaux  ', jaux
 454             write (ulsort,texte(langue,18))
 455             codret = 3
 456           endif
 457 c
 458           carenf(14,nrfonc) = anlipr
 459 c
 460           endif
 461 c
 462         endif
 463 c
 464 c 3.4. ==> creation de fonctions associees pour la conformite :
 465 c    . quand la fonction courante est definie sur des quadrangles,
 466 c      des hexaedres ou des pentaedres
 467 c    . que des mailles de conformite sont presentes
 468 c    . qu'il n'a pas de fonction associee sur ces mailles de conformite
 469 c
 470 #ifdef _DEBUG_HOMARD_
 471       write (ulsort,90002) '3.4. creer une fonction ; codret', codret
 472 #endif
 473 c
 474         if ( codret.eq.0 ) then
 475 c
 476 #ifdef _DEBUG_HOMARD_
 477         write (ulsort,texte(langue,8))
 478         write (ulsort,90002) 'typgeo', typgeo
 479         write (ulsort,90002) 'nbtyas', nbtyas
 480         write (ulsort,90002) 'ngauss', ngauss
 481         write (ulsort,90002) 'nbtafo', nbtafo
 482         write (ulsort,90002) 'nbtrq3', nbtrq3
 483         write (ulsort,90002) 'nbheco', nbheco
 484         write (ulsort,90002) 'nbpeco', nbpeco
 485         write (ulsort,90002) 'nbtyas', nbtyas
 486 #endif
 487 c
 488         nrfon2 = -1
 489         afair2 = .false.
 490         ngaus2 = ngauss
 491         nrfon3 = -1
 492         afair3 = .false.
 493         ngaus3 = ngauss
 494         typge3 = 0
 495 c
 496         if ( ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) .and.
 497      >        nbtrq3.gt.0 ) then
 498           if ( typgeo.eq.edqua4 ) then
 499             nbent2 = nbtria
 500             typge2 = edtri3
 501             if ( carsup.eq.1 ) then
 502               ngaus2 = 3
 503               dimcp2 = 2
 504             elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
 505               codret = 341
 506             endif
 507           else
 508             nbent2 = nbtria
 509             typge2 = edtri6
 510             if ( carsup.eq.1 ) then
 511               ngaus2 = 6
 512               dimcp2 = 2
 513             elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
 514               codret = 342
 515             endif
 516           endif
 517           afair2 = .true.
 518           do 341 , iaux = 1 , nbtyas
 519             if ( imem(antyas+iaux-1).eq.typge2 ) then
 520               nrfon2 = iaux
 521               afair2 = .false.
 522             endif
 523   341     continue
 524 c
 525         elseif ( ( ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) .and.
 526      >             nbheco.ne.0 ) .or.
 527      >            ( ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) .and.
 528      >             nbpeco.ne.0 ) ) then
 529           if ( typgeo.eq.edhex8 .or. typgeo.eq.edpen6 ) then
 530             nbent2 = nbtetr
 531             typge2 = edtet4
 532             nbent3 = nbpyra
 533             typge3 = edpyr5
 534             if ( carsup.eq.1 ) then
 535               ngaus2 = 4
 536               ngaus3 = 5
 537               dimcp2 = 3
 538               dimcp3 = 3
 539             elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
 540               codret = 343
 541             endif
 542           elseif ( typgeo.eq.edhe20 .or. typgeo.eq.edpe15  ) then
 543             nbent2 = nbtetr
 544             typge2 = edte10
 545             nbent3 = nbpyra
 546             typge3 = edpy13
 547             if ( carsup.eq.1 ) then
 548               ngaus2 = 10
 549               ngaus3 = 13
 550               dimcp2 = 3
 551               dimcp3 = 3
 552             elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
 553               codret = 344
 554             endif
 555           else
 556             codret = 340
 557           endif
 558           afair2 = .true.
 559           afair3 = .true.
 560           do 342 , iaux = 1 , nbtyas
 561             if ( imem(antyas+iaux-1).eq.typge2 ) then
 562               nrfon2 = iaux
 563               afair2 = .false.
 564             endif
 565             if ( imem(antyas+iaux-1).eq.typge3 ) then
 566               nrfon3 = iaux
 567               afair3 = .false.
 568             endif
 569   342     continue
 570 c
 571         endif
 572 c
 573         if ( codret.ne.0 ) then
 574 c
 575         write (ulsort,texte(langue,5)) typgeo
 576         write (ulsort,texte(langue,19)) carsup
 577         write (ulsort,texte(langue,68))
 578         write (ulsort,texte(langue,6))
 579 c
 580         endif
 581 c
 582         endif
 583 c
 584 #ifdef _DEBUG_HOMARD_
 585         write (ulsort,99001) 'afair2', afair2
 586         write (ulsort,99001) 'afair3', afair3
 587 #endif
 588 c
 589 c 3.5. ==> bilan sur les types
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,90002) '3.5. bilan type ; codret', codret
 592 #endif
 593 c
 594         if ( codret.eq.0 ) then
 595 c
 596 c       memorisation des eventuels types associes deja presents
 597 c
 598         lgtbix = 0
 599         do 35 , iaux = 1 , nbtyas
 600           lgtbix = lgtbix + 1
 601           tbiaux(lgtbix) = imem(antyas+iaux-1)
 602    35   continue
 603 c
 604 c       si conformite, ajout du type courant et du/des types associes
 605 c
 606         if ( afair2 .or. afair3 ) then
 607 c
 608           lgtbix = lgtbix + 1
 609           tbiaux(lgtbix) = typgeo
 610           if ( afair2 ) then
 611             lgtbix = lgtbix + 1
 612             tbiaux(lgtbix) = typge2
 613           endif
 614           if ( afair3 ) then
 615             lgtbix = lgtbix + 1
 616             tbiaux(lgtbix) = typge3
 617           endif
 618 c
 619         endif
 620 c
 621 #ifdef _DEBUG_HOMARD_
 622         write (ulsort,90002) 'tbiaux = ', (tbiaux(iaux),iaux=1,lgtbix)
 623 #endif
 624         endif
 625 c
 626 c 3.6. ==> la fonction similaire a l'iteration p
 627 #ifdef _DEBUG_HOMARD_
 628       write (ulsort,90002) '3.6. similaire ; codret', codret
 629 #endif
 630 c
 631         if ( codret.eq.0 ) then
 632 c
 633 #ifdef _DEBUG_HOMARD_
 634         write (ulsort,texte(langue,7))
 635 #endif
 636 c
 637         if ( typgeo.eq.0 ) then
 638           nbsufo = rsnoto
 639         elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
 640           nbsufo = nbsegm
 641         elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
 642           nbsufo = nbtria
 643         elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
 644           nbsufo = nbquad
 645         elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
 646           nbsufo = nbtetr
 647         elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then
 648           nbsufo = nbhexa
 649         elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then
 650           nbsufo = nbpyra
 651         elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then
 652           nbsufo = nbpent
 653         else
 654           write (ulsort,texte(langue,5)) typgeo
 655           write (ulsort,texte(langue,6))
 656           codret = 3
 657         endif
 658 c
 659         endif
 660 c
 661         if ( codret.eq.0 ) then
 662 c
 663         iaux = nrfonc
 664 #ifdef _DEBUG_HOMARD_
 665         write (ulsort,texte(langue,3)) 'PCFOR1_p', nompro
 666 #endif
 667         call pcfor1 ( option,
 668      >                nnfonc, iaux,
 669      >                nbpara, carenf, carchf,
 670      >                nppafo, npfopa,
 671      >                nbtrav, litrav,
 672      >                typfon, typcha, typgeo, nbtyas,
 673      >                ngauss, nbsufo, nnvapr,
 674      >                carsup, nbtafo, typint,
 675      >                lgtbix, tbiaux,
 676      >                apvale, apvalr, apobch, apprpg, aptyas,
 677      >                apvatt,
 678      >                ulsort, langue, codret )
 679 c
 680         endif
 681 c
 682 c 3.7. ==> pour les champs aux noeuds par elements, creation de la
 683 c          localisation des pseudo "points de Gauss"
 684 c          REMARQUE : on ne cree plus rien
 685 #ifdef _DEBUG_HOMARD_
 686         write (ulsort,90002) '3.7. pseudo ; codret', codret
 687         write (ulsort,90002) 'carsup', carsup
 688         write (ulsort,99001) 'afair2', afair2
 689         write (ulsort,99001) 'afair3', afair3
 690 #endif
 691 c
 692         if ( afair2 .and. carsup.eq.1793 ) then
 693 c
 694           if ( codret.eq.0 ) then
 695 c
 696 #ifdef _DEBUG_HOMARD_
 697       write (ulsort,texte(langue,3)) 'UTCRPG-2', nompro
 698 #endif
 699           call utcrpg ( oblop2,
 700      >                  nolop2, typge2, ngaus2, dimcp2, carsup,
 701      >                  ulsort, langue, codret )
 702 c
 703           endif
 704 c
 705         else
 706 c
 707           oblop2 = blan08
 708 c
 709         endif
 710 c
 711         if ( afair3 .and. carsup.eq.1793 ) then
 712 c
 713           if ( codret.eq.0 ) then
 714 c
 715 #ifdef _DEBUG_HOMARD_
 716       write (ulsort,texte(langue,3)) 'UTCRPG-3', nompro
 717 #endif
 718           call utcrpg ( oblop3,
 719      >                  nolop3, typge3, ngaus3, dimcp3, carsup,
 720      >                  ulsort, langue, codret )
 721 c
 722           endif
 723 c
 724         else
 725 c
 726           oblop3 = blan08
 727 c
 728         endif
 729 c
 730 #ifdef _DEBUG_HOMARD_
 731         write (ulsort,90003) 'oblop2', oblop2
 732         write (ulsort,90003) 'oblop3', oblop3
 733 #endif
 734 c
 735 c 3.8. ==> creation des fonctions pour la conformite
 736 #ifdef _DEBUG_HOMARD_
 737       write (ulsort,90002) '3.8. conformite ; codret', codret
 738 #endif
 739 c 3.8.1. ==> 1ere fonction
 740 c
 741         if ( afair2 ) then
 742 c
 743           if ( codret.eq.0 ) then
 744 c
 745 #ifdef _DEBUG_HOMARD_
 746           write (ulsort,texte(langue,9))
 747 #endif
 748 c
 749           nrfonm = nrfonm + 1
 750           nrfon2 = nrfonm
 751           typfon = -1
 752           laux = -1
 753 #ifdef _DEBUG_HOMARD_
 754       write (ulsort,texte(langue,3)) 'PCFOR1_2', nompro
 755 #endif
 756           call pcfor1 ( option,
 757      >                  nnfonc, nrfon2,
 758      >                  nbpara, carenf, carchf,
 759      >                  nppafo, npfopa,
 760      >                  nbtrav, litrav,
 761      >                  typfon, typcha, typge2, nbtyas,
 762      >                  ngaus2, nbent2, laux,
 763      >                  carsup, nbtafo, typint,
 764      >                  lgtbix, tbiaux,
 765      >                  apvale, apvalr, apobch, apprpg, aptyas,
 766      >                  apvatt,
 767      >                  ulsort, langue, codret )
 768 c
 769           carchf( 2,nrfon2) = nnfonc
 770           carchf( 3,nrfon2) = carchf( 1,nrfonc)
 771           carchf( 7,nrfon2) = oblop2
 772 c
 773           endif
 774 c
 775         endif
 776 c
 777 c 3.8.2. ==> 2nde fonction
 778 c
 779         if ( afair3 ) then
 780 c
 781           if ( codret.eq.0 ) then
 782 c
 783 #ifdef _DEBUG_HOMARD_
 784           write (ulsort,texte(langue,9))
 785 #endif
 786 c
 787           nrfonm = nrfonm + 1
 788           nrfon3 = nrfonm
 789           typfon = -1
 790           laux = -1
 791 #ifdef _DEBUG_HOMARD_
 792       write (ulsort,texte(langue,3)) 'PCFOR1_3', nompro
 793 #endif
 794           call pcfor1 ( option,
 795      >                  nnfonc, nrfon3,
 796      >                  nbpara, carenf, carchf,
 797      >                  nppafo, npfopa,
 798      >                  nbtrav, litrav,
 799      >                  typfon, typcha, typge3, nbtyas,
 800      >                  ngaus3, nbent3, laux,
 801      >                  carsup, nbtafo, typint,
 802      >                  lgtbix, tbiaux,
 803      >                  apvale, apvalr, apobch, apprpg, aptyas,
 804      >                  apvatt,
 805      >                  ulsort, langue, codret )
 806 c
 807           carchf( 2,nrfon3) = nnfonc
 808           carchf( 3,nrfon3) = carchf( 1,nrfonc)
 809           carchf( 7,nrfon3) = oblop3
 810 c
 811           endif
 812 c
 813         endif
 814 c
 815 c 3.9. ==> modification des types associes du paquet de fonction
 816 #ifdef _DEBUG_HOMARD_
 817       write (ulsort,90002) '3.9. modification ; codret', codret
 818 #endif
 819 c
 820         if ( afair2 .or. afair3 ) then
 821 c
 822           if ( codret.eq.0 ) then
 823 c
 824 #ifdef _DEBUG_HOMARD_
 825       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
 826 #endif
 827           iaux = 5
 828           call utmopf ( nppafo, iaux,
 829      >                  lgtbix, tbsaux, tbiaux,
 830      >                  saux08,
 831      >                  jaux, nbtyas, ngauss, laux, maux,
 832      >                  naux,
 833      >                  ulsort, langue, codret )
 834 c
 835           endif
 836 c
 837         endif
 838 c
 839 #ifdef _DEBUG_HOMARD_
 840         if ( codret.eq.0 ) then
 841         call gmprsx (nompro, nppafo )
 842         call gmprsx (nompro, nppafo//'.Fonction' )
 843         call gmprsx (nompro, nppafo//'.TypeSuAs')
 844         endif
 845 #endif
 846 c
 847 c 3.10. ==> Enregistrement des numeros de fonctions associees,
 848 c           reelles ou fictives
 849 c
 850         if ( codret.eq.0 ) then
 851 c
 852 #ifdef _DEBUG_HOMARD_
 853         write (ulsort,90002) 'nrfon2', nrfon2
 854         write (ulsort,90002) 'nrfon3', nrfon3
 855 #endif
 856 c
 857         carenf(25,nrfonc) = nrfon2
 858         carenf(26,nrfonc) = nrfon3
 859 c
 860         endif
 861 c
 862    30 continue
 863 c
 864 c====
 865 c 4. preparation des profils des fonctions du paquet
 866 c====
 867 #ifdef _DEBUG_HOMARD_
 868       write (ulsort,90002) '4. Preparation ; codret', codret
 869 #endif
 870 c
 871       do 40 , nrfonc = 1 , nrfonm
 872 c
 873 cgn      print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
 874 c
 875 c 4.1. ==> recuperation des informations
 876 c
 877         if ( codret.eq.0 ) then
 878 c
 879         typgeo = carenf( 3,nrfonc)
 880         nnvapr = carenf( 7,nrfonc)
 881         anlipr = carenf(14,nrfonc)
 882 #ifdef _DEBUG_HOMARD_
 883       write (ulsort,90002) 'typgeo', typgeo
 884       write (ulsort,90002) 'nnvapr', nnvapr
 885 #endif
 886 c
 887         extrul = .false.
 888         if ( typgeo.eq.0 ) then
 889           reenac = renoac
 890           rsenac = rsnoto
 891           adenhn = adnohn
 892           adencn = adnocn
 893           lgenin = lgnoin
 894           adenin = adnoin
 895           decala = decanu(-1)
 896         elseif ( typgeo.eq.edpoi1 ) then
 897           reenac = rempac
 898           rsenac = rsmpac
 899           adenhn = admphn
 900           adencn = admpcn
 901           lgenin = lgmpin
 902           adenin = admpin
 903           decala = decanu(0)
 904         elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
 905           reenac = rearac
 906           rsenac = rsarac
 907           adenhn = adarhn
 908           adencn = adarcn
 909           lgenin = lgarin
 910           adenin = adarin
 911           decala = decanu(1)
 912         elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
 913           reenac = retrac
 914           rsenac = rstrac
 915           adenhn = adtrhn
 916           adencn = adtrcn
 917           lgenin = lgtrin
 918           adenin = adtrin
 919           decala = decanu(2)
 920           extrul = extrus
 921           advofa = adpetr
 922           advohn = adpehn
 923           advocn = adpecn
 924         elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
 925           reenac = requac
 926           rsenac = rsquac
 927           adenhn = adquhn
 928           adencn = adqucn
 929           lgenin = lgquin
 930           adenin = adquin
 931           decala = decanu(4)
 932           extrul = extrus
 933           advofa = adhequ
 934           advohn = adhehn
 935           advocn = adhecn
 936         elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
 937           reenac = reteac
 938           rsenac = rsteac
 939           adenhn = adtehn
 940           adencn = adtecn
 941           lgenin = lgtein
 942           adenin = adtein
 943           decala = decanu(3)
 944         elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13  ) then
 945           reenac = repyac
 946           rsenac = rspyac
 947           adenhn = adpyhn
 948           adencn = adpycn
 949           lgenin = lgpyin
 950           adenin = adpyin
 951           decala = decanu(5)
 952         elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20  ) then
 953           reenac = reheac
 954           rsenac = rsheac
 955           adenhn = adhehn
 956           adencn = adhecn
 957           lgenin = lghein
 958           adenin = adhein
 959           decala = decanu(6)
 960         elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15  ) then
 961           reenac = repeac
 962           rsenac = rspeac
 963           adenhn = adpehn
 964           adencn = adpecn
 965           lgenin = lgpein
 966           adenin = adpein
 967           decala = decanu(7)
 968         else
 969           codret = 41
 970         endif
 971 c
 972         endif
 973 c
 974 c 4.2. ==> tableau reciproque de nenin
 975 c
 976         if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then
 977 c
 978           if ( codret.eq.0 ) then
 979 c
 980           call gmalot ( ntrav1, 'entier  ', reenac, adtra1, codret )
 981 c
 982           endif
 983 c
 984           if ( codret.eq.0 ) then
 985 c
 986           iaux = 0
 987 #ifdef _DEBUG_HOMARD_
 988       write (ulsort,texte(langue,3)) 'UTTBRC', nompro
 989 #endif
 990           call uttbrc ( iaux,
 991      >                  lgenin, imem(adenin), reenac, imem(adtra1),
 992      >                  ulsort, langue, codret)
 993 c
 994           endif
 995 c
 996         endif
 997 c
 998 c 4.3. ==> prise en compte du profil
 999 c
1000 #ifdef _DEBUG_HOMARD_
1001         write (ulsort,90002) 'nnvapr', nnvapr
1002         write (ulsort,90002) 'reenac', reenac
1003         write (ulsort,90002) 'rsenac', rsenac
1004         write (ulsort,90002) 'decala', decala
1005         write (ulsort,99001) 'extrul', extrul
1006 #endif
1007 c
1008         if ( .not.extrul ) then
1009 c
1010           if ( codret.eq.0 ) then
1011 c
1012           iaux = 0
1013 #ifdef _DEBUG_HOMARD_
1014       write (ulsort,texte(langue,3)) 'UTPR05', nompro
1015 #endif
1016           call utpr05 ( iaux, nnvapr, imem(anlipr),
1017      >                  reenac, rsenac,
1018      >                  imem(adenhn), imem(adencn), decala,
1019      >                  lgenin, imem(adenin), imem(adtra1),
1020      >                  obpcan, obpcap,
1021      >                  adpcan, adpcap,
1022      >                  ulsort, langue, codret )
1023 c
1024           endif
1025 c
1026         else
1027 c
1028           if ( codret.eq.0 ) then
1029 c
1030           iaux = 0
1031 #ifdef _DEBUG_HOMARD_
1032       write (ulsort,texte(langue,3)) 'UTPR06', nompro
1033 #endif
1034           call utpr06 ( iaux,
1035      >                  reenac, rsenac,
1036      >                  imem(advofa), imem(adenhn),
1037      >                  imem(advohn), imem(advocn),
1038      >                  obpcan, obpcap,
1039      >                  adpcan, adpcap,
1040      >                  ulsort, langue, codret )
1041 c
1042           endif
1043 c
1044         endif
1045 cgn        call gmprsx (nompro,obpcap)
1046 c
1047 c 4.4. ==> archivage
1048 c
1049         if ( codret.eq.0 ) then
1050 c
1051         carchf (4,nrfonc) = obpcan
1052         nbtrav = nbtrav + 1
1053         litrav(nbtrav) = obpcan
1054 cgn      write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcan = ', obpcan
1055 cgn        print *,'litrav(',nbtrav,') = ',litrav(nbtrav)
1056 c
1057         carchf (5,nrfonc) = obpcap
1058         nbtrav = nbtrav + 1
1059         litrav(nbtrav) = obpcap
1060 cgn      write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcap = ', obpcap
1061 cgn        print *,'litrav(',nbtrav,') = ',litrav(nbtrav)
1062 c
1063         endif
1064 c
1065       nnfonc = carchf(1,nrfonc)
1066 cgn      write (*,texte(langue,4)) nrfonc, nnfonc
1067 cgn      write (*,1788)(carenf(iaux,nrfonc),iaux=1,nbpara)
1068 cgn 1788 format(10I8)
1069 cgn      write (*,1789)(carchf(iaux,nrfonc),iaux=1,nbpara)
1070 cgn 1789 format(10(a8,1x))
1071 c
1072 c 4.5. ==> menage
1073 c
1074         if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then
1075 c
1076           if ( codret.eq.0 ) then
1077 c
1078           call gmlboj ( ntrav1 , codret )
1079 c
1080           endif
1081 c
1082         endif
1083 c
1084    40 continue
1085 c
1086 c====
1087 c 5. la fin
1088 c====
1089 c
1090       if ( codret.ne.0 ) then
1091 c
1092 #include "envex2.h"
1093 c
1094       write (ulsort,texte(langue,1)) 'Sortie', nompro
1095       write (ulsort,texte(langue,2)) codret
1096 c
1097       endif
1098 c
1099 #ifdef _DEBUG_HOMARD_
1100       write (ulsort,texte(langue,1)) 'Sortie', nompro
1101       call dmflsh (iaux)
1102 #endif
1103 c
1104       end