src/tool/AP_Conversion/pcsovr.F

   1       subroutine pcsovr ( nocson, nocsop,
   2      >                    nomail, norenn, nosvmn,
   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    aPres adaptation - Conversion de Solution VRaie
  26 c     -                 -             -        --
  27 c ______________________________________________________________________
  28 c remarque : en principe, tous les cas de figure sont couverts ...
  29 c            mais c'est tellement alambique que je prefere mettre un
  30 c            code de retour non nul au cas ou ...
  31 c            comme disait le quotidien de mon enfance :
  32 c            "On peut etre trop petit ou trop grand,
  33 c             on n'est jamais trop prudent."
  34 c                                          La Montagne - 1972
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . nocsop .   s . char8  . nom de l'objet solution iteration n+1      .
  40 c . nocson . e   . char8  . nom de l'objet solution iteration n        .
  41 c . nomail . e   . char8  . nom de l'objet maillage homard iter. n+1   .
  42 c . norenn . e   . char8  . nom de l'objet renumerotation iteration n  .
  43 c . nosvmn . e   . char8  . nom de l'objet contenant les sauvegardes   .
  44 c .        .     .        . du maillage n                              .
  45 c . option . e   .    1   . option du traitement                       .
  46 c .        .     .        . -1 : Pas de changement dans le maillage    .
  47 c .        .     .        .  0 : Adaptation complete                   .
  48 c .        .     .        .  1 : Modification de degre                 .
  49 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  50 c . langue . e   .    1   . langue des messages                        .
  51 c .        .     .        . 1 : francais, 2 : anglais                  .
  52 c . codret . es  .    1   . code de retour des modules                 .
  53 c .        .     .        . 0 : pas de probleme                        .
  54 c .        .     .        . 1 : probleme                               .
  55 c ______________________________________________________________________
  56 c
  57 c====
  58 c 0. declarations et dimensionnement
  59 c====
  60 c
  61 c 0.1. ==> generalites
  62 c
  63       implicit none
  64       save
  65 c
  66       character*6 nompro
  67       parameter ( nompro = 'PCSOVR' )
  68 c
  69 #include "nblang.h"
  70 #include "consts.h"
  71 #include "meddc0.h"
  72 c
  73 c 0.2. ==> communs
  74 c
  75 #include "envex1.h"
  76 c
  77 #include "gmenti.h"
  78 #include "gmreel.h"
  79 #include "gmstri.h"
  80 c
  81 #include "envada.h"
  82 #include "nombtr.h"
  83 #include "nombqu.h"
  84 #include "nombte.h"
  85 #include "nombhe.h"
  86 #include "nombpy.h"
  87 #include "nombpe.h"
  88 #include "nomber.h"
  89 #include "nombsr.h"
  90 #include "envca1.h"
  91 #include "impr02.h"
  92 c
  93 c 0.3. ==> arguments
  94 c
  95       character*8 nocsop, nocson
  96       character*8 nomail, norenn, nosvmn
  97 c
  98       integer option
  99 c
 100       integer ulsort, langue, codret
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer iaux, jaux, kaux
 105       integer codre1, codre2, codre3
 106       integer codre0
 107 c
 108       integer nbcham, nbpafo, nbprof, nblopg
 109       integer phetno, pcoono, pancno
 110       integer phetar, psomar, pnp2ar, pfilar, pancar
 111       integer phettr, paretr, pfiltr, ppertr, panctr, adpetr
 112       integer phetqu, parequ, pfilqu, pperqu, pancqu, adhequ
 113       integer phette, ptrite, pcotrt, parete, pfilte, pmerte, pancte
 114       integer phethe, pquahe, pcoquh, parehe, pfilhe, pmerhe, panche
 115       integer adhes2
 116       integer phetpy, pfacpy, pcofay, parepy, pfilpy, pmerpy, pancpy
 117       integer phetpe, pfacpe, pcofap, parepe, pfilpe, pmerpe, pancpe
 118       integer adpes2
 119       integer pcfaar, pcfatr, pcfaqu
 120       integer pfamar, pfamtr, pfamqu, pfamte, pfamhe, pfampy, pfampe
 121 c
 122       integer adnbrn, adnbrp
 123       integer adnohp, adnocp
 124       integer         adarcp
 125       integer         adtrcp
 126       integer         adqucp
 127       integer         adtecp
 128       integer         adhecp
 129       integer         adpycp
 130       integer         adpecp
 131       integer adnohn, adnocn, adnoin, lgnoin
 132       integer admphn, admpcn, admpin, lgmpin
 133       integer adarhn, adarcn, adarin, lgarin
 134       integer adtrhn, adtrcn, adtrin, lgtrin
 135       integer adquhn, adqucn, adquin, lgquin
 136       integer adtehn, adtecn, adtein, lgtein
 137       integer adhehn, adhecn, adhein, lghein
 138       integer adpyhn, adpycn, adpyin, lgpyin
 139       integer adpehn, adpecn, adpein, lgpein
 140 c
 141       integer aninch, aninpf, aninpr, aninlg
 142       integer apinch, apinpf, apinpr, apinlg
 143       integer npprof, approf, nbproi
 144       integer nplopg, aplopg, nblpgi
 145       integer nnfopa, tnpgpf, anobfo, antyge
 146       integer npfopa, typgpf, apobfo, aptyge
 147       integer typint
 148       integer nbpara
 149       integer nrpafo
 150       integer nrfonc
 151       integer adtr1i, adtr1s
 152       integer adtra2, adtrav, nbtrav
 153       integer nrpass
 154 c
 155       integer typgeo, ngauss, carsup
 156 c
 157       integer nbanar, adafar, adaear
 158       integer nbantr, adaftr, adaetr
 159       integer nbanqu, adafqu, adaequ
 160       integer nbante, adafte, adaete
 161       integer nbanhe, adafhe, adaehe, adaihe
 162       integer nbanpy, adafpy, adaepy
 163       integer nbanpe, adafpe, adaepe, adaipe
 164       integer         pafatr
 165 c
 166       integer tbiaux(1)
 167       integer nbmapo, nbsegm, nbtria, nbtetr,
 168      >        nbquad, nbhexa, nbpent, nbpyra
 169       integer decanu(-1:7)
 170 c
 171       character*8 norenu
 172       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 173       character*8 nhtetr, nhhexa, nhpyra, nhpent
 174       character*8 nhelig
 175       character*8 nhvois, nhsupe, nhsups
 176       character*8 nnpafo, nppafo
 177       character*8 ntrav1, ntrav2
 178       character*8 ntrava
 179       character*8 liprof
 180       character*8 lilopg
 181       character*8 tbsaux(1)
 182 c
 183       logical deraff
 184       logical extrus
 185 c
 186       integer nbmess
 187       parameter ( nbmess = 20 )
 188       character*80 texte(nblang,nbmess)
 189 c
 190 c 0.5. ==> initialisations
 191 c ______________________________________________________________________
 192 c
 193 c====
 194 c 1. initialisations
 195 c====
 196 c
 197 c 1.1. ==> messages
 198 c
 199 #include "impr01.h"
 200 #include "impr03.h"
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,texte(langue,1)) 'Entree', nompro
 204       call dmflsh (iaux)
 205 #endif
 206 c
 207       texte(1,4) = '(''Solution a l''''iteration '',a,'' : '')'
 208       texte(1,5) = '(''Nombre de paquets de fonctions : '', i3)'
 209       texte(1,7) = '(5x,''Conversion HOMARD ----> '',a18,/)'
 210       texte(1,8) = '(/,''Champs sur les '',a)'
 211       texte(1,9) = '(/,''Champs aux noeuds par element sur les '',a)'
 212       texte(1,10) = '(/,''Champs aux points de Gauss des '',a)'
 213       texte(1,11) = '(/,''Champs aux points de Gauss des '',a)'
 214       texte(1,12) = '(''Paquet de fonction '',a,'' numero : '',i3)'
 215       texte(1,13) = '(''... fonction numero : '',i3)'
 216 c
 217       texte(2,4) = '(''Solution at iteration '',a,'' : '')'
 218       texte(2,5) = '(''Number of packs of functions : '', i3)'
 219       texte(2,7) = '(5x,''Conversion HOMARD ----> '',a18,/)'
 220       texte(2,8) = '(/,''Fields over '',a)'
 221       texte(2,9) = '(/,''Fields based on nodes per element for '',a)'
 222       texte(2,10) = '(/,''Fields based on Gauss points for '',a)'
 223       texte(2,11) = '(/,''Fields based on Gauss points for '',a)'
 224       texte(2,12) = '(''Function pack '',a,'' # : '',i3)'
 225       texte(2,13) = '(''.. Function # : '',i3)'
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,90002) 'option', option
 229 #endif
 230 c
 231 c 1.2. ==> nombre de parametres a enregistrer par fonction
 232 c
 233       nbpara = 26
 234 c
 235 #ifdef _DEBUG_HOMARD_
 236 10000 format(43('='))
 237       write (ulsort,10000)
 238       write (ulsort,texte(langue,4)) 'n'
 239       call gmprsx (nompro, nocson )
 240       call gmprsx (nompro, nocson//'.InfoCham' )
 241       call gmprsx (nompro, '%%%%%%%9' )
 242       call gmprsx (nompro, '%%%%%%%9.Nom_Comp' )
 243       call gmprsx (nompro, '%%%%%%%9.Cham_Ent' )
 244       call gmprsx (nompro, '%%%%%%%9.Cham_Car' )
 245 cgn      call gmprsx (nompro, '%%%%%%10' )
 246 cgn      call gmprsx (nompro, '%%%%%%10.Nom_Comp' )
 247 cgn      call gmprsx (nompro, '%%%%%%10.Cham_Ent' )
 248 cgn      call gmprsx (nompro, '%%%%%%11' )
 249 cgn      call gmprsx (nompro, '%%%%%%11.Nom_Comp' )
 250 cgn      call gmprsx (nompro, '%%%%%%11.Cham_Ent' )
 251 cgn      call gmprsx (nompro, '%%%%%%%8' )
 252 cgn      call gmprsx (nompro, '%%%%%%%8.Cham_Ent' )
 253 cgn      call gmprsx (nompro, '%%%%%%%8.Cham_Car' )
 254 cgn      call gmprsx (nompro, '%%%%%%%9' )
 255 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Ent' )
 256 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Car' )
 257       call gmprsx (nompro, nocson//'.InfoPaFo' )
 258       call gmprsx (nompro, '%%%%%%13' )
 259       call gmprsx (nompro, '%%%%%%13.Fonction' )
 260       call gmprsx (nompro, '%%%%%%12' )
 261 cgn      call gmprsx (nompro, '%%%%%%19.Fonction' )
 262 cgn      call gmprsx (nompro, '%%%%%%18' )
 263 cgn      call gmprsx (nompro, '%%%%%%18.InfoPrPG' )
 264 cgn      call gmprsx (nompro, nocson//'.InfoProf' )
 265       write (ulsort,10000)
 266 #endif
 267 c
 268 c====
 269 c 2. recuperation des pointeurs
 270 c====
 271 c
 272 c 2.1. ==> structure generale
 273 c
 274       if ( codret.eq.0 ) then
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 278 #endif
 279       call utnomh ( nomail,
 280      >                sdim,   mdim,
 281      >               degre, maconf, homolo, hierar,
 282      >              rafdef, nbmane, typcca, typsfr, maextr,
 283      >              mailet,
 284      >              norenu,
 285      >              nhnoeu, nhmapo, nharet,
 286      >              nhtria, nhquad,
 287      >              nhtetr, nhhexa, nhpyra, nhpent,
 288      >              nhelig,
 289      >              nhvois, nhsupe, nhsups,
 290      >              ulsort, langue, codret)
 291 c
 292       endif
 293 c
 294       if ( codret.eq.0 ) then
 295 #include "mslve4.h"
 296       endif
 297 c
 298       if ( codret.eq.0 ) then
 299 c
 300         if ( ( rafdef.eq.3 .or. rafdef.eq.4 ) .and. nbiter.gt.0 ) then
 301           deraff = .true.
 302         else
 303           deraff = .false.
 304         endif
 305 c
 306         if ( typcca.eq.26 .or .typcca.eq.46 ) then
 307           extrus = .false.
 308         elseif ( maextr.ne.0 ) then
 309           extrus = .true.
 310         else
 311           extrus = .false.
 312         endif
 313 c
 314       endif
 315 c
 316 c 2.2. ==> les tableaux
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,90002) '2.2 ==> les tableaux ; codret', codret
 319 #endif
 320 c
 321 c 2.2.1. ==> tableaux lies a la solution
 322 c
 323       if ( codret.eq.0 ) then
 324 c
 325 #ifdef _DEBUG_HOMARD_
 326       write (ulsort,texte(langue,3)) 'UTCASO', nompro
 327 #endif
 328       call utcaso ( nocson,
 329      >              nbcham, nbpafo, nbprof, nblopg,
 330      >              aninch, aninpf, aninpr, aninlg,
 331      >              ulsort, langue, codret )
 332 c
 333 #ifdef _DEBUG_HOMARD_
 334       write (ulsort,texte(langue,5)) nbpafo
 335 #endif
 336 c
 337       endif
 338 c
 339 c 2.2.2. ==> les renumerotations
 340 #ifdef _DEBUG_HOMARD_
 341       write (ulsort,90002) '2.2.2 ==> renumerotations ; codret', codret
 342 #endif
 343 c
 344 c 2.2.2.1. ==> la renumerotation a l'iteration n
 345 c
 346       if ( codret.eq.0 ) then
 347 c
 348       call gmadoj ( norenn//'.Nombres', adnbrn, iaux, codret )
 349 c
 350       endif
 351 c
 352       if ( codret.eq.0 ) then
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355       write (ulsort,texte(langue,3)) 'UTNBMH', nompro
 356 #endif
 357       call utnbmh ( imem(adnbrn),
 358      >              renois, renoei, renomp,
 359      >              renop1,   iaux,   iaux,
 360      >                iaux,   iaux,   iaux,
 361      >                iaux,   iaux,   iaux,   iaux,
 362      >              nbmapo, nbsegm, nbtria, nbtetr,
 363      >              nbquad, nbhexa, nbpent, nbpyra,
 364      >                iaux,   iaux,
 365      >                iaux,   iaux,
 366      >              ulsort, langue, codret )
 367 c
 368       reno1i = renois + renoei + renomp + renop1
 369 c
 370 c cf. eslmm2
 371       decanu(-1) = 0
 372       decanu(3) = 0
 373       decanu(2) = nbtetr
 374       decanu(1) = nbtetr + nbtria
 375       decanu(0) = nbtetr + nbtria + nbsegm
 376       decanu(4) = nbtetr + nbtria + nbsegm + nbmapo
 377       decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad
 378       decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 379       decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 380      >          + nbpyra
 381 #ifdef _DEBUG_HOMARD_
 382       write(ulsort,90002) 'nbmapo', nbmapo
 383       write(ulsort,90002) 'nbsegm', nbsegm
 384       write(ulsort,90002) 'nbtria', nbtria
 385       write(ulsort,90002) 'nbtetr', nbtetr
 386       write(ulsort,90002) 'nbquad', nbquad
 387       write(ulsort,90002) 'nbhexa', nbhexa
 388       write(ulsort,90002) 'nbpent', nbpent
 389       write(ulsort,90002) 'nbpyra', nbpyra
 390       write(ulsort,90002) 'decanu', decanu
 391 #endif
 392 c
 393       endif
 394 c
 395 c 2.2.2.2. ==> la renumerotation a l'iteration n+1
 396 c
 397       if ( codret.eq.0 ) then
 398 c
 399       call gmadoj ( norenu//'.Nombres', adnbrp, iaux, codret )
 400 c
 401       endif
 402 c
 403       if ( codret.eq.0 ) then
 404 c
 405       rsnois = imem(adnbrp)
 406       rsnoei = imem(adnbrp+1)
 407       rsnomp = imem(adnbrp+2)
 408       rsnop1 = imem(adnbrp+3)
 409       rsnop2 = imem(adnbrp+4)
 410       rsnoim = imem(adnbrp+5)
 411       rseutc = imem(adnbrp+6)
 412 c
 413       endif
 414 c
 415 c 2.2.3. ==> les tableaux generaux
 416 #ifdef _DEBUG_HOMARD_
 417       write (ulsort,90002) '2.2.3 tableaux generaux ; codret', codret
 418 #endif
 419 c
 420 c 2.2.3.1. ==> pour les noeuds
 421 #ifdef _DEBUG_HOMARD_
 422       write (ulsort,90002)' 2.2.3.1. noeuds ; codret', codret
 423 #endif
 424 c
 425       if ( codret.eq.0 ) then
 426 c
 427 #ifdef _DEBUG_HOMARD_
 428       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 429 #endif
 430       iaux = 6
 431       call utad01 (   iaux, nhnoeu,
 432      >              phetno,
 433      >                jaux,   jaux,   jaux,
 434      >              pcoono,   jaux,   jaux,  jaux,
 435      >              ulsort, langue, codret )
 436 c
 437       if ( deraff .or.
 438      >    ( option.eq.1 .and. degre.eq.1 ) ) then
 439         call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codre0 )
 440         codret = max ( abs(codre0), codret )
 441       else
 442         pancno = 1
 443       endif
 444 c
 445       endif
 446 #ifdef _DEBUG_HOMARD_
 447       write (ulsort,90002) '. apres noeuds ; codret', codret
 448 #endif
 449 c
 450       if ( codret.eq.0 ) then
 451 c
 452 #ifdef _DEBUG_HOMARD_
 453       write (ulsort,texte(langue,3)) 'UTRE03_no_new', nompro
 454 #endif
 455       iaux = -1
 456       jaux = 210
 457       call utre03 ( iaux, jaux, norenu,
 458      >              rsnoac, rsnoto, adnohp, adnocp,
 459      >              ulsort, langue, codret)
 460 c
 461       endif
 462 c
 463       if ( codret.eq.0 ) then
 464 c
 465 #ifdef _DEBUG_HOMARD_
 466       write (ulsort,texte(langue,3)) 'UTRE03_no_old', nompro
 467 #endif
 468       iaux = -1
 469       jaux = 210
 470       call utre03 ( iaux, jaux, norenn,
 471      >              renoac, renoto, adnohn, adnocn,
 472      >              ulsort, langue, codret)
 473 c
 474       endif
 475 c
 476       if ( codret.eq.0 ) then
 477 c
 478 #ifdef _DEBUG_HOMARD_
 479       write (ulsort,texte(langue,3)) 'UTRE04_no_old', nompro
 480 #endif
 481       iaux = -1
 482       jaux = 11
 483       call utre04 ( iaux, jaux, norenn,
 484      >              lgnoin, adnoin,
 485      >              ulsort, langue, codret)
 486 c
 487       endif
 488 c
 489 c 2.2.3.2. ==> pour les aretes
 490 #ifdef _DEBUG_HOMARD_
 491       write (ulsort,90002)' 2.2.3.2. aretes ; codret', codret
 492 #endif
 493 c
 494       if ( codret.eq.0 ) then
 495 c
 496 #ifdef _DEBUG_HOMARD_
 497       write (ulsort,texte(langue,3)) 'UTAD97_ar', nompro
 498 #endif
 499       iaux = 1
 500       jaux = 1
 501       call utad97 (   iaux,   jaux, deraff, extrus,
 502      >              nharet, norenu, norenn, nosvmn,
 503      >              phetar, psomar,   kaux, pfilar,   kaux,
 504      >              pfamar, pcfaar, pnp2ar,   kaux,
 505      >              nbanar, pancar,
 506      >              adafar, adaear,   kaux,   kaux,
 507      >              rsarto, adarcp,
 508      >              rearac, rearto, adarhn, adarcn,
 509      >              lgarin, adarin,
 510      >              ulsort, langue, codret )
 511 c
 512       endif
 513 c
 514 c
 515 c 2.2.3.3. ==> pour les triangles
 516 #ifdef _DEBUG_HOMARD_
 517       write (ulsort,90002)' 2.2.3.3. triangles ; codret', codret
 518 #endif
 519 c
 520       if ( nbtrto.ne.0 ) then
 521 c
 522         if ( codret.eq.0 ) then
 523 c
 524 #ifdef _DEBUG_HOMARD_
 525       write (ulsort,texte(langue,3)) 'UTAD97_tr', nompro
 526 #endif
 527         iaux = 2
 528         jaux = 1
 529         call utad97 (   iaux,   jaux, deraff, extrus,
 530      >                nhtria, norenu, norenn, nosvmn,
 531      >                phettr, paretr,   kaux, pfiltr, ppertr,
 532      >                pfamtr, pcfatr, adpetr,   kaux,
 533      >                nbantr, panctr,
 534      >                adaftr, adaetr, pafatr,   kaux,
 535      >                rstrto, adtrcp,
 536      >                retrac, retrto, adtrhn, adtrcn,
 537      >                lgtrin, adtrin,
 538      >                ulsort, langue, codret )
 539 c
 540         endif
 541 c
 542       endif
 543 c
 544 c 2.2.3.4. ==> pour les tetraedres
 545 #ifdef _DEBUG_HOMARD_
 546       write (ulsort,90002)' 2.2.3.4. tetraedres ; codret', codret
 547 #endif
 548 c
 549       if ( nbteto.ne.0 ) then
 550 c
 551         if ( codret.eq.0 ) then
 552 c
 553 #ifdef _DEBUG_HOMARD_
 554       write (ulsort,texte(langue,3)) 'UTAD97_te', nompro
 555 #endif
 556         iaux = 3
 557         jaux = 1
 558         call utad97 (   iaux,   jaux, deraff, extrus,
 559      >                nhtetr, norenu, norenn, nosvmn,
 560      >                phette, ptrite, parete, pfilte, pmerte,
 561      >                pfamte,   kaux, pcotrt,   kaux,
 562      >                nbante, pancte,
 563      >                adafte, adaete,   kaux,   kaux,
 564      >                rsteto, adtecp,
 565      >                reteac, reteto, adtehn, adtecn,
 566      >                lgtein, adtein,
 567      >                ulsort, langue, codret )
 568 c
 569         endif
 570 c
 571       endif
 572 c
 573 c 2.2.3.5. ==> pour les quadrangles
 574 #ifdef _DEBUG_HOMARD_
 575       write (ulsort,90002)' 2.2.3.5. quadrangles ; codret', codret
 576 #endif
 577 c
 578       if ( nbquto.ne.0 ) then
 579 c
 580         if ( codret.eq.0 ) then
 581 c
 582 #ifdef _DEBUG_HOMARD_
 583       write (ulsort,texte(langue,3)) 'UTAD97_qu', nompro
 584 #endif
 585         iaux = 4
 586         jaux = 1
 587         call utad97 (   iaux,   jaux, deraff, extrus,
 588      >                nhquad, norenu, norenn, nosvmn,
 589      >                phetqu, parequ,   kaux, pfilqu, pperqu,
 590      >                pfamqu, pcfaqu, adhequ,   kaux,
 591      >                nbanqu, pancqu,
 592      >                adafqu, adaequ,   kaux,   kaux,
 593      >                rsquto, adqucp,
 594      >                requac, requto, adquhn, adqucn,
 595      >                lgquin, adquin,
 596      >                ulsort, langue, codret )
 597 c
 598         endif
 599 c
 600       endif
 601 c
 602 c 2.2.3.6. ==> pour les pyramides
 603 #ifdef _DEBUG_HOMARD_
 604       write (ulsort,90002)' 2.2.3.6. pyramides ; codret', codret
 605 #endif
 606 c
 607       if ( nbpyto.ne.0 ) then
 608 c
 609         if ( codret.eq.0 ) then
 610 c
 611 #ifdef _DEBUG_HOMARD_
 612       write (ulsort,texte(langue,3)) 'UTAD97_py', nompro
 613 #endif
 614         iaux = 5
 615         jaux = 1
 616         call utad97 (   iaux,   jaux, deraff, extrus,
 617      >                nhpyra, norenu, norenn, nosvmn,
 618      >                phetpy, pfacpy, parepy, pfilpy, pmerpy,
 619      >                pfampy,   kaux, pcofay,   kaux,
 620      >                nbanpy, pancpy,
 621      >                adafpy, adaepy,   kaux,   kaux,
 622      >                rspyto, adpycp,
 623      >                repyac, repyto, adpyhn, adpycn,
 624      >                lgpyin, adpyin,
 625      >                ulsort, langue, codret )
 626 c
 627         endif
 628 c
 629       endif
 630 c
 631 c 2.2.3.7. ==> pour les hexaedres
 632 #ifdef _DEBUG_HOMARD_
 633       write (ulsort,90002)' 2.2.3.7. hexaedres ; codret', codret
 634 #endif
 635 c
 636       if ( nbheto.ne.0 ) then
 637 c
 638         if ( codret.eq.0 ) then
 639 c
 640 #ifdef _DEBUG_HOMARD_
 641       write (ulsort,texte(langue,3)) 'UTAD97_He', nompro
 642 #endif
 643         iaux = 6
 644         if ( nbheco.eq.0 ) then
 645           jaux = 1
 646         else
 647           jaux = 2
 648         endif
 649         call utad97 (   iaux,   jaux, deraff, extrus,
 650      >                nhhexa, norenu, norenn, nosvmn,
 651      >                phethe, pquahe, parehe, pfilhe, pmerhe,
 652      >                pfamhe,   kaux, pcoquh, adhes2,
 653      >                nbanhe, panche,
 654      >                adafhe, adaehe,   kaux, adaihe,
 655      >                rsheto, adhecp,
 656      >                reheac, reheto, adhehn, adhecn,
 657      >                lghein, adhein,
 658      >                ulsort, langue, codret )
 659 c
 660         endif
 661 c
 662       endif
 663 c
 664 c 2.2.3.8. ==> pour les pentaedres
 665 #ifdef _DEBUG_HOMARD_
 666       write (ulsort,90002)' 2.2.3.8. pentaedres ; codret', codret
 667 #endif
 668 c
 669       if ( nbpeto.ne.0 ) then
 670 c
 671         if ( codret.eq.0 ) then
 672 c
 673 #ifdef _DEBUG_HOMARD_
 674       write (ulsort,texte(langue,3)) 'UTAD97_Pe', nompro
 675 #endif
 676         iaux = 7
 677         if ( nbpeco.eq.0 ) then
 678           jaux = 1
 679         else
 680           jaux = 2
 681         endif
 682         call utad97 (   iaux,   jaux, deraff, extrus,
 683      >                nhpent, norenu, norenn, nosvmn,
 684      >                phetpe, pfacpe, parepe, pfilpe, pmerpe,
 685      >                pfampe,   kaux, pcofap, adpes2,
 686      >                nbanpe, pancpe,
 687      >                adafpe, adaepe,   kaux, adaipe,
 688      >                rspeto, adpecp,
 689      >                repeac, repeto, adpehn, adpecn,
 690      >                lgpein, adpein,
 691      >                ulsort, langue, codret )
 692 c
 693         endif
 694 c
 695       endif
 696 c
 697 cgn      call gmprsx(nompro,norenn//'.InfoSupE')
 698 cgn      call gmprsx(nompro,norenn//'.InfoSupE.Tab3')
 699 cgn      call gmprsx(nompro,norenn//'.InfoSupE.Tab4')
 700 cgn      call gmprsx(nompro,norenn//'.InfoSupE.Tab6')
 701 cgn      call gmprsx(nompro,norenn//'.TrCalcul')
 702 cgn      call gmprsx(nompro,norenn//'.TrHOMARD')
 703 cgn      call gmprsx(nompro,norenn//'.QuCalcul')
 704 cgn      call gmprsx(nompro,norenn//'.QuHOMARD')
 705 c====
 706 c 3. allocations
 707 c====
 708 #ifdef _DEBUG_HOMARD_
 709       write (ulsort,90002) '3. allocation ; codret', codret
 710 #endif
 711 c
 712 c 3.1. ==> allocation de l'objet de tete
 713 c
 714       if ( codret.eq.0 ) then
 715 c
 716 #ifdef _DEBUG_HOMARD_
 717       write (ulsort,texte(langue,3)) 'UTALSO', nompro
 718 #endif
 719       call utalso ( nocsop,
 720      >              nbcham, nbpafo, nbprof, nblopg,
 721      >              apinch, apinpf, apinpr, apinlg,
 722      >              ulsort, langue, codret )
 723 c
 724       endif
 725 c
 726 c 3.2. ==> copie des caracteristiques des champs
 727 c
 728       if ( codret.eq.0 ) then
 729 c
 730       call gmcpgp ( nocson//'.InfoCham',
 731      >              nocsop//'.InfoCham', codre1 )
 732       call gmadoj ( nocsop//'.InfoCham', apinch, iaux, codre2 )
 733 c
 734       codre0 = min ( codre1, codre2 )
 735       codret = max ( abs(codre0), codret,
 736      >               codre1, codre2 )
 737 c
 738 cgn      call gmprsx (nompro, nocsop )
 739 cgn      call gmprsx (nompro, nocsop//'.InfoCham' )
 740 cgn      call gmprsx('1er champ :', smem(apinch))
 741 cgn      call gmprsx ('  Fonction      Profil        LocaPG ',
 742 cgn     >             smem(apinch)//'.Cham_Car')
 743 cgn      if ( nbcham.ge.2 ) then
 744 cgn        call gmprsx('2nd champ :', smem(apinch+1))
 745 cgn        call gmprsx ('  Fonction      Profil        LocaPG ',
 746 cgn     >               smem(apinch+1)//'.Cham_Car')
 747 c
 748       endif
 749 c
 750 c 3.3. ==> allocation d'une memorisation des profils eventuels
 751 c          on alloue 3 fois plus grand pour tenir compte des
 752 c          eventuelles mailles de conformite
 753 c
 754       if ( codret.eq.0 ) then
 755 c
 756       npprof = 0
 757 c
 758 cgn      write (ulsort,90002) 'nbprof', nbprof
 759       nbproi = 3*nbprof
 760       call gmalot ( liprof, 'chaine  ', nbproi, approf, codret )
 761 c
 762       endif
 763 c
 764 c 3.4. ==> allocation d'une memorisation des localisations de points
 765 c          de Gauss eventuelles
 766 c          on alloue 3 fois plus grand pour tenir compte des
 767 c          eventuelles mailles de conformite
 768 c
 769       if ( codret.eq.0 ) then
 770 c
 771       nplopg = 0
 772 c
 773 cgn      write (ulsort,90002) 'nbpafo =', nbpafo
 774       nblpgi = 3*nbpafo
 775       call gmalot ( lilopg, 'chaine  ', nblpgi, aplopg, codret )
 776 c
 777       endif
 778 c
 779 c 3.5. ==> allocation d'une memorisation des tableaux temporaires
 780 c
 781       if ( codret.eq.0 ) then
 782 c
 783       iaux = 20*nbpafo
 784       call gmalot ( ntrava, 'chaine  ', iaux, adtrav, codret )
 785 c
 786       endif
 787 c
 788 c====
 789 c 4. On classe les paquets de fonctions ainsi :
 790 c     . la premiere serie traite les champs aux noeuds par element
 791 c     . la seconde serie traite les autres champs
 792 c     Cela est indispensable pour pouvoir traiter les interpolations
 793 c     des champs exprimes aux points de Gauss dans le cas ou ils
 794 c     sont lies aux champs aux noeuds par elements : ils ont besoin des
 795 c     valeurs actualisees de leurs projection aux noeuds par element
 796 c
 797 c    Pour chaque paquet de fonctions :
 798 c      tnpgpf : type geometrique associe
 799 c      ngauss : nombre de points de gauss
 800 c      carsup : caracteristiques du support
 801 c                1, si aux noeuds par elements
 802 c                2, si aux points de Gauss, associe avec
 803 c                   un champ aux noeuds par elements
 804 c                3, si aux points de Gauss autonome
 805 c                0, sinon
 806 c      typint : type d'interpolation
 807 c                0, si automatique
 808 c                aux noeuds : 1 si degre 1, 2 si degre 2, 3 si iso-P2
 809 c                par element : 0 si intensif, 1 si extensif
 810 c
 811 c     La liste allouee ici contient donc les noms des paquets de
 812 c     fonctions dans l'ordre du traitement. Cela occupe les nbpafo
 813 c     premieres cases.
 814 c     Dans les nbpafo cases suivantes, on memorise le paquet associe
 815 c     dans le cas de champs aux noeuds par elements ou aux points
 816 c     de Gauss.
 817 c
 818 c====
 819 #ifdef _DEBUG_HOMARD_
 820       write (ulsort,90002) '4. classement ; codret', codret
 821 #endif
 822 c
 823       if ( codret.eq.0 ) then
 824 c
 825       iaux = 2*nbpafo
 826       call gmalot ( ntrav2, 'chaine  ', iaux, adtra2, codret )
 827 c
 828       endif
 829 c
 830       if ( codret.eq.0 ) then
 831 c
 832       jaux = adtra2
 833 c
 834       do 41 , nrpass = 1 , 2
 835 cgn          write (ulsort,90002) '== NRPASS ====', nrpass
 836 c
 837         do 411 , nrpafo = 1 , nbpafo
 838 c
 839           if ( codret.eq.0 ) then
 840 c
 841           nnpafo = smem(aninpf+nrpafo-1)
 842 #ifdef _DEBUG_HOMARD_
 843           write (ulsort,texte(langue,12)) nnpafo, nrpafo
 844 #endif
 845 c
 846 #ifdef _DEBUG_HOMARD_
 847       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 848 #endif
 849           call utcapf ( nnpafo,
 850      >                  nnfopa, tnpgpf, ngauss, carsup, typint,
 851      >                  anobfo, antyge,
 852      >                  ulsort, langue, codret )
 853 c
 854           endif
 855 c
 856           if ( codret.eq.0 ) then
 857 c
 858 #ifdef _DEBUG_HOMARD_
 859           if ( codret.eq.0 ) then
 860           write (ulsort,90002) 'nnfopa', nnfopa
 861           write (ulsort,90002) 'tnpgpf', tnpgpf
 862           write (ulsort,90002) 'carsup', carsup
 863           write (ulsort,90002) 'typint', typint
 864           write (ulsort,*) (smem(anobfo+iaux),' ',iaux=0,nnfopa)
 865           endif
 866 #endif
 867 c
 868           if ( nrpass.eq.1 .and. carsup.eq.1 ) then
 869             iaux = 1
 870           elseif ( nrpass.eq.2 .and.
 871      >           ( carsup.eq.0 .or. carsup.eq.2 .or. carsup.eq.3) ) then
 872             iaux = 1
 873           else
 874             iaux = 0
 875           endif
 876 cgn          write (ulsort,90002) '===> iaux', iaux
 877           if ( iaux.ne.0 ) then
 878             smem(jaux) = nnpafo
 879 cc            smem(jaux+nbpafo) = smem(anobfo+nnfopa)
 880             jaux = jaux + 1
 881           endif
 882 c
 883           endif
 884 c
 885   411   continue
 886 c
 887    41 continue
 888 c
 889       endif
 890 c
 891 #ifdef _DEBUG_HOMARD_
 892       call gmprsx (nompro, ntrav2 )
 893 #endif
 894 c
 895 c====
 896 c 5. Exploration des divers paquets de fonctions
 897 c====
 898 #ifdef _DEBUG_HOMARD_
 899       write (ulsort,90002) '5. Exploration ; codret', codret
 900 #endif
 901 c
 902       do 50 , nrpafo = 1 , nbpafo
 903 c
 904         nbtrav = 0
 905 c
 906 c 5.1. ==> caracterisation du paquet de fonctions courant
 907 #ifdef _DEBUG_HOMARD_
 908       write (ulsort,90002) '5.1. caracterisation ; codret', codret
 909 #endif
 910 c
 911         if ( codret.eq.0 ) then
 912 c
 913         nnpafo = smem(adtra2+nrpafo-1)
 914 c
 915 #ifdef _DEBUG_HOMARD_
 916         write (ulsort,*) ' '
 917         write (ulsort,texte(langue,12)) nnpafo, nrpafo
 918 #endif
 919 c
 920 #ifdef _DEBUG_HOMARD_
 921 c        write (ulsort,10000)
 922         write (ulsort,texte(langue,12)) 'n', nrpafo
 923         call gmprsx (nompro, nnpafo )
 924 c      couple (nom objet Fonction, nom objet Fonction associe eventuel)
 925 cgn        call gmprsx (
 926 cgn     >   'couples (objet Fonction, objet Fonction associe eventuel) :',
 927 cgn     >    nnpafo//'.Fonction' )
 928 cgn        call gmprsx (nompro, nnpafo//'.TypeSuAs' )
 929         if ( nrpafo.eq.-1 ) then
 930           call gmprsx (nompro, '%%%%%%15' )
 931         elseif ( nrpafo.eq.-2 ) then
 932           call gmprsx (nompro, '%%%%%%16' )
 933         elseif ( nrpafo.eq.-3 ) then
 934           call gmprsx (nompro, '%%%%%%17' )
 935         endif
 936 cgn        call gmprsx (nompro, '%%%%%%%9' )
 937 cgn        call gmprsx (nompro, '%%%%%%%9.InfoPrPG' )
 938 cgn        call gmprsx (nompro, '%%%%%%14.ListEnti' )
 939 #endif
 940 c
 941 #ifdef _DEBUG_HOMARD_
 942       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 943 #endif
 944         call utcapf ( nnpafo,
 945      >                nnfopa, tnpgpf, ngauss, carsup, typint,
 946      >                anobfo, antyge,
 947      >                ulsort, langue, codret )
 948 c
 949 #ifdef _DEBUG_HOMARD_
 950         if ( codret.eq.0 ) then
 951         write (ulsort,90002) 'nnfopa', nnfopa
 952         write (ulsort,90002) 'tnpgpf', tnpgpf
 953         write (ulsort,90002) 'carsup', carsup
 954         write (ulsort,90002) 'typint', typint
 955         write (ulsort,*)
 956      >'couples (objet Fonction, objet Fonction associe eventuel) :'
 957         write (ulsort,*) (smem(anobfo+iaux),' ',iaux=0,nnfopa)
 958         call gmprsx ('1ere fonction du paquet', smem(anobfo) )
 959         call gmprsx ('  Profil        LocaPG        F. Associee',
 960      >               smem(anobfo)//'.InfoPrPG' )
 961         endif
 962 #endif
 963 c
 964         endif
 965 c
 966 c 5.2. ==> creation du paquet pour la solution en sortie
 967 #ifdef _DEBUG_HOMARD_
 968       write (ulsort,90002) '5.2. creation ; codret', codret
 969 #endif
 970 c 5.2.1. ==> allocation d'un nouveau paquet
 971 c
 972         if ( codret.eq.0 ) then
 973 c
 974 #ifdef _DEBUG_HOMARD_
 975       write (ulsort,texte(langue,3)) 'UTALPF', nompro
 976 #endif
 977         npfopa = 0
 978         typgpf = tnpgpf
 979         call utalpf ( nppafo,
 980      >                npfopa, typgpf, ngauss, carsup, typint,
 981      >                apobfo, aptyge,
 982      >                ulsort, langue, codret )
 983 c
 984 #ifdef _DEBUG_HOMARD_
 985         write (ulsort,*) 'Le paquet ',nppafo,' est cree :'
 986         call gmprsx (nompro, nppafo )
 987 #endif
 988 c
 989         endif
 990 c
 991 c 5.2.2. ==> memorisation
 992 c
 993         if ( codret.eq.0 ) then
 994 c
 995         smem(apinpf+nrpafo-1) = nppafo
 996         smem(adtra2+nrpafo-1+nbpafo) = nppafo
 997 c
 998         endif
 999 c
1000 c 5.3. ==> copie eventuelle des types associes
1001 #ifdef _DEBUG_HOMARD_
1002       write (ulsort,90002) '5.3. copie ; codret', codret
1003 #endif
1004 c
1005         if ( typgpf.lt.0 ) then
1006 c
1007           if ( codret.eq.0 ) then
1008 c
1009 #ifdef _DEBUG_HOMARD_
1010       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
1011 #endif
1012           iaux = 5
1013           jaux = abs(typgpf)
1014           call utmopf ( nppafo, iaux,
1015      >                  jaux, tbsaux, imem(antyge),
1016      >                  nnpafo,
1017      >                  npfopa, typgpf, ngauss, carsup, typint,
1018      >                  apobfo,
1019      >                  ulsort, langue, codret )
1020 c
1021           endif
1022 c
1023 #ifdef _DEBUG_HOMARD_
1024         if ( codret.eq.0 ) then
1025         write (ulsort,*) (smem(apobfo+iaux),iaux=0,npfopa),nompro
1026         endif
1027 #endif
1028 c
1029         endif
1030 c
1031 c 5.4. ==> Pour un champ aux points de Gauss avec lien sur des
1032 c          elements aux noeuds, memorisation du paquet associe
1033 #ifdef _DEBUG_HOMARD_
1034       write (ulsort,90002) '5.4. paquet associe ; codret', codret
1035 #endif
1036 c
1037         if ( carsup.eq.2 ) then
1038 c
1039           if ( codret.eq.0 ) then
1040 c
1041 #ifdef _DEBUG_HOMARD_
1042       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
1043 #endif
1044           iaux = 4
1045           call utmopf ( nppafo, iaux,
1046      >                  nbpafo, smem(adtra2), tbiaux,
1047      >                  nnpafo,
1048      >                  npfopa, typgpf, ngauss, carsup, typint,
1049      >                  apobfo,
1050      >                  ulsort, langue, codret )
1051 c
1052           endif
1053 c
1054 #ifdef _DEBUG_HOMARD_
1055         if ( codret.eq.0 ) then
1056         write (ulsort,*) (smem(apobfo+iaux),iaux=0,npfopa),nompro
1057         endif
1058 #endif
1059 c
1060         endif
1061 c
1062 c 5.5. ==> stockage des informations liees aux fonctions du paquet
1063 c          adtr1i : caracteristiques entieres des fonctions :
1064 c                   anc/nou, typcha, typgeo, typass, ngauss, etc.
1065 c          adtr1s : caracteristiques caracteres des fonctions
1066 c                   nom fonc., nom fonc. n, nom fonc. p, etc.
1067 #ifdef _DEBUG_HOMARD_
1068       write (ulsort,90002) '5.5. stockage ; codret', codret
1069 #endif
1070 c
1071         if ( codret.eq.0 ) then
1072 c
1073         iaux = nbpara*nnfopa*3
1074         call gmalot ( ntrav1, 'entier  ', iaux, adtr1i, codre1 )
1075         smem(adtrav) = ntrav1
1076         call gmalot ( ntrav1, 'chaine  ', iaux, adtr1s, codre2 )
1077         smem(adtrav+1) = ntrav1
1078         nbtrav = 2
1079 cgn        print *,nompro,' 5.4 nbtrav = ', nbtrav
1080 cgn        print *,(' ',smem(adtrav+iaux-1),iaux=1,nbtrav)
1081 c
1082         codre0 = min ( codre1, codre2 )
1083         codret = max ( abs(codre0), codret,
1084      >                 codre1, codre2 )
1085 c
1086         endif
1087 c
1088         if ( codret.eq.0 ) then
1089 c
1090 #ifdef _DEBUG_HOMARD_
1091       write (ulsort,texte(langue,3)) 'PCFORE', nompro
1092       call gmprsx (nompro,smem(anobfo+nnfopa-1))
1093       call gmprsx (nompro,smem(anobfo+nnfopa-1)//'.InfoCham')
1094 cgn      call gmprsx (nompro,'%%%%%%%8')
1095 cgn      call gmprsx (nompro,'%%%%%%%8.Nom_Comp')
1096 cgn      call gmprsx (nompro,'%%%%%%%8.Cham_Ent')
1097 cgn      call gmprsx (nompro,'%%%%%%%8.Cham_Car')
1098 cgn      call gmprsx (nompro,smem(anobfo+nnfopa-1)//'.InfoPrPG')
1099 #endif
1100         call pcfore ( option, extrus,
1101      >                nnfopa, anobfo,
1102      >                npfopa, nppafo,
1103      >                nbpara, imem(adtr1i), smem(adtr1s),
1104      >                nbtrav, smem(adtrav),
1105      >                adpetr, adhequ,
1106      >                adnohn, admphn, adarhn, adtrhn, adquhn,
1107      >                adtehn, adpyhn, adhehn, adpehn,
1108      >                adnocn, admpcn, adarcn, adtrcn, adqucn,
1109      >                adtecn, adpycn, adhecn, adpecn,
1110      >                adnoin, admpin, adarin, adtrin, adquin,
1111      >                adtein, adpyin, adhein, adpein,
1112      >                lgnoin, lgmpin, lgarin, lgtrin, lgquin,
1113      >                lgtein, lgpyin, lghein, lgpein,
1114      >                decanu,
1115      >                ulsort, langue, codret )
1116 c
1117         endif
1118 c
1119 #ifdef _DEBUG_HOMARD_
1120         if ( codret.eq.0 ) then
1121         write (ulsort,90002) 'Apres PCFORE, npfopa', npfopa
1122 cgn        write (ulsort,10000)
1123 cgn        call gmprsx (nompro,smem(adtrav))
1124 cgn        call gmprsx (nompro,smem(adtrav+1))
1125         write (ulsort,texte(langue,12)) 'p', nrpafo
1126         call gmprsx (nompro, nppafo )
1127         call gmprsx (nompro, nppafo//'.Fonction' )
1128 cgn        call gmprsx (nompro, nppafo//'.TypeSuAs' )
1129         endif
1130 #endif
1131 c
1132 c 5.6. ==> mise a jour selon le support de chaque fonction du paquet
1133 cgn        print *,nompro,' 5.6 nbtrav = ', nbtrav
1134 cgn        print *,(' ',smem(adtrav+iaux-1),iaux=1,nbtrav)
1135 cgn        call gmprsx (nompro, '%%%%%%25' )
1136 cgn        call gmprsx (nompro, '%%%%%%26' )
1137 cgn        call gmprsx (nompro, '%%%%%%28' )
1138 cgn        call gmprsx (nompro, '%%%%%%29' )
1139 #ifdef _DEBUG_HOMARD_
1140       write (ulsort,90002) '5.6. mise a jour ; codret', codret
1141 #endif
1142 c
1143         do 56 , nrfonc = 1 , nnfopa
1144 c
1145 c 5.6.1. ==> le type de support
1146 c
1147           if ( codret.eq.0 ) then
1148 c
1149           typgeo = imem(adtr1i-1+nbpara*(nrfonc-1)+3)
1150 c
1151 #ifdef _DEBUG_HOMARD_
1152           write (ulsort,*) '=============================='
1153           write (ulsort,texte(langue,13)) nrfonc
1154           write (ulsort,90002) 'typgeo', typgeo
1155 #endif
1156 c
1157           endif
1158 c
1159           iaux = nrfonc
1160 c
1161 c 5.6.2. ==> sur les noeuds
1162 c
1163           if ( typgeo.eq.0 ) then
1164 c
1165             if ( codret.eq.0 ) then
1166 c
1167             write (ulsort,texte(langue,8)) mess14(langue,3,-1)
1168 #ifdef _DEBUG_HOMARD_
1169       write (ulsort,texte(langue,3)) 'PCSONO', nompro
1170 #endif
1171             call pcsono ( renop1, renoto, typint, deraff, option,
1172      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1173      >                    imem(phetno), imem(pancno),
1174      >                    imem(adnohn), imem(adnocn), imem(adnohp),
1175      >                    imem(phetar), imem(psomar), imem(pfilar),
1176      >                    imem(pnp2ar),
1177      >                    imem(phettr), imem(paretr), imem(pfiltr),
1178      >                    imem(phetqu), imem(parequ), imem(pfilqu),
1179      >                    imem(ptrite), imem(pcotrt), imem(parete),
1180      >                    imem(pfilte), imem(phette),
1181      >                    imem(pquahe), imem(pcoquh), imem(parehe),
1182      >                    imem(pfilhe), imem(phethe), imem(adhes2),
1183      >                    imem(pfacpe), imem(pcofap), imem(parepe),
1184      >                    imem(pfilpe), imem(phetpe), imem(adpes2),
1185      >                    imem(pfacpy), imem(pcofay), imem(parepy),
1186      >                    ulsort, langue, codret )
1187 c
1188             endif
1189 c
1190 c 5.6.3. ==> sur les aretes
1191 c
1192           elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
1193 c
1194             if ( codret.eq.0 ) then
1195 c
1196             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,1)
1197 cgn          print *,'sur les aretes, avec carsup = ', carsup
1198 #ifdef _DEBUG_HOMARD_
1199       write (ulsort,texte(langue,3)) 'PCSOAR', nompro
1200 #endif
1201             call pcsoar ( typint, deraff,
1202      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1203      >                    imem(phetar), imem(pancar), imem(pfilar),
1204      >                    imem(psomar),
1205      >                    rmem(pcoono),
1206      >                    imem(phettr), imem(paretr), imem(pfiltr),
1207      >                    imem(phetqu), imem(parequ), imem(pfilqu),
1208      >                    nbanar, imem(adafar),
1209      >                    imem(adarcn), imem(adarcp),
1210      >                    ulsort, langue, codret )
1211 c
1212             endif
1213 c
1214 c 5.6.4. ==> sur les triangles
1215 c
1216           elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
1217 c
1218             if ( codret.eq.0 ) then
1219 c
1220             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,2)
1221 cgn          print *,'sur les triangles, avec carsup = ', carsup
1222 #ifdef _DEBUG_HOMARD_
1223       write (ulsort,texte(langue,3)) 'PCSOTR', nompro
1224 #endif
1225             call pcsotr ( typint, deraff, option,
1226      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1227      >                    imem(phettr), imem(panctr), imem(pfiltr),
1228      >                    nbantr, imem(adaftr), imem(adaetr),
1229      >                    imem(adtrcn), imem(adtrcp),
1230      >                    ulsort, langue, codret )
1231 c
1232             endif
1233 c
1234 c 5.6.5. ==> sur les quadrangles
1235 c
1236           elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
1237 c
1238             if ( codret.eq.0 ) then
1239 c
1240             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,4)
1241 cgn          print *,'sur les quadrangles, avec carsup = ', carsup
1242 #ifdef _DEBUG_HOMARD_
1243         write (ulsort,texte(langue,3)) 'PCSOQU', nompro
1244 #endif
1245             call pcsoqu ( typint, deraff, option,
1246      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1247      >                    rmem(pcoono),
1248      >                    imem(psomar),
1249      >                    imem(paretr),
1250      >                    imem(parequ),
1251      >                    imem(phetqu), imem(pancqu), imem(pfilqu),
1252      >                    nbanqu, imem(adafqu), imem(adaequ),
1253      >                    imem(adqucn), imem(adqucp),
1254      >                    nbantr, imem(pafatr),
1255      >                    imem(adtrcn), imem(adtrcp),
1256      >                    ulsort, langue, codret )
1257 c
1258             endif
1259 c
1260 c 5.6.6. ==> sur les tetraedres
1261 c
1262           elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
1263 c
1264             if ( codret.eq.0 ) then
1265 c
1266             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,3)
1267 cgn          print *,'sur les tetraedres, avec carsup = ', carsup
1268 #ifdef _DEBUG_HOMARD_
1269       write (ulsort,texte(langue,3)) 'PCSOTE', nompro
1270 #endif
1271             call pcsote ( typint, deraff,
1272      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1273      >                    imem(phette), imem(pancte), imem(pfilte),
1274      >                    nbante, imem(adafte), imem(adaete),
1275      >                    imem(adtecn), imem(adtecp),
1276      >                    ulsort, langue, codret )
1277 c
1278             endif
1279 c
1280 c
1281 c 5.6.7. ==> sur les hexaedres
1282 c
1283           elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20  ) then
1284 c
1285             if ( codret.eq.0 ) then
1286 c
1287             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,6)
1288 cgn          print *,'sur les hexaedres, avec carsup = ', carsup
1289 #ifdef _DEBUG_HOMARD_
1290       write (ulsort,texte(langue,3)) 'PCSOHE', nompro
1291 #endif
1292             call pcsohe ( typint, deraff,
1293      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1294      >                    rmem(pcoono),
1295      >                    imem(psomar),
1296      >                    imem(paretr),
1297      >                    imem(parequ),
1298      >                    imem(ptrite), imem(pcotrt), imem(parete),
1299      >                    imem(pquahe), imem(pcoquh), imem(parehe),
1300      >                    imem(pfacpy), imem(pcofay), imem(parepy),
1301      >                    imem(phethe), imem(panche), imem(pfilhe),
1302      >                    imem(adhes2),
1303      >                    nbanhe,
1304      >                    imem(adafhe), imem(adaehe), imem(adaihe),
1305      >                    imem(adhecn), imem(adhecp),
1306      >                    imem(adtecn), imem(adtecp),
1307      >                    imem(adpycn), imem(adpycp),
1308      >                    ulsort, langue, codret )
1309 c
1310             endif
1311 c
1312 c 5.6.8. ==> sur les pentaedres
1313 c
1314           elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then
1315 c
1316             if ( codret.eq.0 ) then
1317 c
1318             write (ulsort,texte(langue,8+carsup)) mess14(langue,3,7)
1319 cgn          print *,'sur les pentaedres, avec carsup = ', carsup
1320 #ifdef _DEBUG_HOMARD_
1321       write (ulsort,texte(langue,3)) 'PCSOPE', nompro
1322 #endif
1323             call pcsope ( typint, deraff,
1324      >                    nbpara, imem(adtr1i), smem(adtr1s), iaux,
1325      >                    rmem(pcoono),
1326      >                    imem(psomar),
1327      >                    imem(paretr),
1328      >                    imem(parequ),
1329      >                    imem(ptrite), imem(pcotrt), imem(parete),
1330      >                    imem(pfacpe), imem(pcofap), imem(parepe),
1331      >                    imem(pfacpy), imem(pcofay), imem(parepy),
1332      >                    imem(phetpe), imem(pancpe), imem(pfilpe),
1333      >                    imem(adpes2),
1334      >                    nbanpe,
1335      >                    imem(adafpe), imem(adaepe), imem(adaipe),
1336      >                    imem(adpecn), imem(adpecp),
1337      >                    imem(adtecn), imem(adtecp),
1338      >                    imem(adpycn), imem(adpycp),
1339      >                    ulsort, langue, codret )
1340 c
1341             endif
1342 c
1343 c 5.6.9. ==> sur les pyramides
1344 c
1345 cgn          elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then
1346 c
1347 cgn            if ( codret.eq.0 ) then
1348 c
1349 cgn            write (ulsort,texte(langue,8+carsup)) mess14(langue,3,5)
1350 cgn          print *,'sur les pyramides, avec carsup = ', carsup
1351 cgn            codret = 568
1352 c
1353 cgn            endif
1354 c
1355           endif
1356 c
1357 #ifdef _DEBUG_HOMARD_
1358           if ( codret.eq.0 ) then
1359           write (ulsort,texte(langue,12)) 'p', nrpafo
1360           endif
1361 #endif
1362 c
1363    56   continue
1364 c
1365 c 5.7. ==> mise a jour
1366 #ifdef _DEBUG_HOMARD_
1367       write (ulsort,90002) '5.7. mise a jour ; codret', codret
1368 #endif
1369 c
1370 c 5.7.1. ==> recuperation des caracteristiques du paquet de fonctions p
1371 c
1372         if ( codret.eq.0 ) then
1373 c
1374 #ifdef _DEBUG_HOMARD_
1375       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
1376 #endif
1377         call utcapf ( nppafo,
1378      >                npfopa, typgpf, ngauss, carsup, typint,
1379      >                apobfo, aptyge,
1380      >                ulsort, langue, codret )
1381 c
1382         endif
1383 c
1384 c 5.7.2. ==> mise a jour des caracteristiques des profils
1385 cgn      write(ulsort,93020)'5.7.2',(smem(adtr1s+iaux-1),iaux=1,7)
1386 c
1387         if ( codret.eq.0 ) then
1388 c
1389 #ifdef _DEBUG_HOMARD_
1390       write (ulsort,texte(langue,3)) 'PCCAPR', nompro
1391 #endif
1392         call pccapr ( npfopa, npprof, smem(approf),
1393      >                nbpara, imem(adtr1i), smem(adtr1s),
1394      >                ulsort, langue, codret )
1395 c
1396         endif
1397 c
1398 c 5.7.3. ==> mise a jour des localisations des points de Gauss
1399 cgn      write(ulsort,93020)'5.7.3 - debut',(smem(adtr1s+iaux-1),iaux=1,7)
1400 c
1401         if ( codret.eq.0 ) then
1402 c
1403 #ifdef _DEBUG_HOMARD_
1404       write (ulsort,texte(langue,3)) 'PCCAPG', nompro
1405 #endif
1406         call pccapg ( npfopa, nplopg, smem(aplopg),
1407      >                nbpara, imem(adtr1i), smem(adtr1s),
1408      >                ulsort, langue, codret )
1409 c
1410         endif
1411 c
1412 c 5.7.4. ==> mise a jour des caracteristiques du paquet de fonctions
1413 cgn      write(ulsort,93020)'5.7.4',(smem(adtr1s+iaux-1),iaux=1,7)
1414 c
1415         if ( codret.eq.0 ) then
1416 c
1417 #ifdef _DEBUG_HOMARD_
1418       write (ulsort,texte(langue,3)) 'PCCAPF', nompro
1419 #endif
1420         call pccapf ( nppafo, npfopa, nbcham, smem(apinch),
1421      >                nbpara, imem(adtr1i), smem(adtr1s),
1422      >                option,
1423      >                ulsort, langue, codret )
1424 c
1425         endif
1426 c
1427 c 5.8. ==> menage
1428 c
1429 #ifdef _DEBUG_HOMARD_
1430       write (ulsort,90002) '5.8. menage ; codret', codret
1431       write (ulsort,90002) 'nombre de tableaux', nbtrav
1432 #endif
1433 c
1434         do 58 , iaux = 1 , nbtrav
1435 c
1436           if ( codret.eq.0 ) then
1437 #ifdef _DEBUG_HOMARD_
1438       write (ulsort,90003) 'tableau ', smem(adtrav+iaux-1)
1439 #endif
1440 c
1441           call gmobal ( smem(adtrav+iaux-1) , jaux )
1442 #ifdef _DEBUG_HOMARD_
1443           write (ulsort,90002) 'jaux', jaux
1444 cgn          if ( smem(adtrav+iaux-1).eq.'%%%%%%41')then
1445 cgn          call gmprsx ( nompro, smem(adtrav+iaux-1))
1446 cgn        endif
1447 #endif
1448 c
1449           if ( jaux.eq.1 ) then
1450             call gmsgoj ( smem(adtrav+iaux-1) , codret )
1451           elseif ( jaux.eq.2 ) then
1452             call gmlboj ( smem(adtrav+iaux-1) , codret )
1453           else
1454             codret = -1
1455           endif
1456 #ifdef _DEBUG_HOMARD_
1457       write (ulsort,90002) 'codret', codret
1458 #endif
1459 c
1460           endif
1461 c
1462    58   continue
1463 #ifdef _DEBUG_HOMARD_
1464       write (ulsort,90002) 'entre 58 et 50 continue ; codret', codret
1465 #endif
1466 c
1467    50 continue
1468 c
1469 c====
1470 c 6. finitions
1471 c====
1472 #ifdef _DEBUG_HOMARD_
1473       write (ulsort,90002) '6. finitions ; codret', codret
1474 #endif
1475 c
1476 c 6.1. ==> menage de la solution en entree desormais inutile et des
1477 c          tableaux de travail
1478 c
1479       do 61 , iaux = 1 , nbpafo
1480 c
1481         if ( codret.eq.0 ) then
1482 c
1483         call gmsgoj ( smem(adtra2+iaux-1) , codret )
1484 c
1485         endif
1486 c
1487    61 continue
1488 c
1489       if ( codret.eq.0 ) then
1490 c
1491       call gmsgoj ( nocson , codre1 )
1492       call gmlboj ( ntrava , codre2 )
1493       call gmlboj ( ntrav2 , codre3 )
1494 c
1495       codre0 = min ( codre1, codre2, codre3 )
1496       codret = max ( abs(codre0), codret,
1497      >               codre1, codre2, codre3 )
1498 c
1499       endif
1500 c
1501 c 6.2. ==> memorisation des profils
1502 #ifdef _DEBUG_HOMARD_
1503       write (ulsort,90002) '6.2. profils ; codret', codret
1504 #endif
1505 c
1506       if ( npprof.ne.0 ) then
1507 c
1508 #ifdef _DEBUG_HOMARD_
1509         call gmprsx (nompro//' liste des profils', liprof )
1510 #endif
1511         if ( codret.eq.0 ) then
1512         call gmmod ( liprof, approf, nbproi, npprof, 1, 1, codret )
1513         endif
1514 c
1515         if ( codret.eq.0 ) then
1516         call gmecat ( nocsop, 3, npprof, codre1 )
1517         call gmcpgp ( liprof, nocsop//'.InfoProf', codre2 )
1518         call gmlboj ( liprof, codre3 )
1519 c
1520         codre0 = min ( codre1, codre2, codre3 )
1521         codret = max ( abs(codre0), codret,
1522      >                 codre1, codre2, codre3 )
1523         endif
1524 c
1525       endif
1526 c
1527 c 6.3. ==> memorisation des localisations de points de Gauss
1528 #ifdef _DEBUG_HOMARD_
1529       write (ulsort,90002) '6.3. Gauss ; codret', codret
1530       write (ulsort,90002) 'nplopg', nplopg
1531 #endif
1532 c
1533       if ( nplopg.ne.0 ) then
1534 c
1535 #ifdef _DEBUG_HOMARD_
1536         call gmprsx (nompro, lilopg )
1537 #endif
1538         if ( codret.eq.0 ) then
1539         call gmmod ( lilopg, approf, nblpgi, nplopg, 1, 1, codret )
1540         endif
1541 c
1542         if ( codret.eq.0 ) then
1543         call gmecat ( nocsop, 4, nplopg, codre1 )
1544         call gmcpgp ( lilopg, nocsop//'.InfoLoPG', codre2 )
1545         call gmlboj ( lilopg, codre3 )
1546 c
1547         codre0 = min ( codre1, codre2, codre3 )
1548         codret = max ( abs(codre0), codret,
1549      >                 codre1, codre2, codre3 )
1550         endif
1551 c
1552       endif
1553 c
1554 #ifdef _DEBUG_HOMARD_
1555       if ( codret.eq.0 ) then
1556 cgn      write (ulsort,10000)
1557       write (ulsort,texte(langue,4)) 'p'
1558       call gmprsx (nompro//' apres 6.3', nocsop )
1559 cgn      call gmprsx (nompro, nocsop//'.InfoCham' )
1560 cgn      call gmprsx('1er champ :', smem(apinch))
1561 cgn      call gmprsx ('  Fonction      Profil        LocaPG ',
1562 cgn     >             smem(apinch)//'.Cham_Car')
1563 cgn      if ( nbcham.ge.2 ) then
1564 cgn        call gmprsx('2nd champ :', smem(apinch+1))
1565 cgn        call gmprsx ('  Fonction      Profil        LocaPG ',
1566 cgn     >               smem(apinch+1)//'.Cham_Car')
1567 cgn      endif
1568 cgn        call gmprsx ('  Profil        LocaPG        F. Associee',
1569 cgn     >               '%%%%%%20.InfoPrPG' )
1570 cgn      call gmprsx (nompro, '%%%%%%%9' )
1571 cgn      call gmprsx (nompro, '%%%%%%%9.Nom_Comp' )
1572 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Ent' )
1573 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Car' )
1574 cgn      call gmprsx (nompro, '%%%%%%10' )
1575 cgn      call gmprsx (nompro, '%%%%%%10.Nom_Comp' )
1576 cgn      call gmprsx (nompro, '%%%%%%10.Cham_Ent' )
1577 cgn      call gmprsx (nompro, '%%%%%%11' )
1578 cgn      call gmprsx (nompro, '%%%%%%11.Nom_Comp' )
1579 cgn      call gmprsx (nompro, '%%%%%%11.Cham_Ent' )
1580 cgn      call gmprsx (nompro, '%%%%%%%8' )
1581 cgn      call gmprsx (nompro, '%%%%%%%8.Cham_Ent' )
1582 cgn      call gmprsx (nompro, '%%%%%%%8.Cham_Car' )
1583 cgn      call gmprsx (nompro, '%%%%%%%9' )
1584 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Ent' )
1585 cgn      call gmprsx (nompro, '%%%%%%%9.Cham_Car' )
1586 cgn      call gmprsx (nompro, nocsop//'.InfoPaFo' )
1587 cgn      call gmprsx (nompro, '%%%%%%16' )
1588 cgn      call gmprsx (nompro, '%%%%%%16.Fonction' )
1589 cgn      call gmprsx (nompro, '%%%%%%24' )
1590 cgn      call gmprsx (nompro, '%%%%%%24.ValeursR' )
1591 cgn      call gmprsx (nompro, '%%%%%%24.InfoCham' )
1592 cgn      call gmprsx (nompro, '%%%%%%16' )
1593 cgn      call gmprsx (nompro, '%%%%%%16.Fonction' )
1594 cgn      call gmprsx (nompro, '%%%%%%23' )
1595 cgn      call gmprsx (nompro, '%%%%%%23.ValeursR' )
1596 cgn      call gmprsx (nompro, '%%%%%%23.InfoCham' )
1597 cgn      call gmprsx (nompro, nocsop//'.InfoProf' )
1598 cgncgn      write (ulsort,10000)
1599       endif
1600 #endif
1601 c
1602 c====
1603 c 7. la fin
1604 c====
1605 c
1606       if ( codret.ne.0 ) then
1607 c
1608 #include "envex2.h"
1609 c
1610       write (ulsort,texte(langue,1)) 'Sortie', nompro
1611       write (ulsort,texte(langue,2)) codret
1612 c
1613       endif
1614 c
1615 #ifdef _DEBUG_HOMARD_
1616       write (ulsort,texte(langue,1)) 'Sortie', nompro
1617       call dmflsh (iaux)
1618 #endif
1619 c
1620       end