src/tool/Information/inffre.F

   1       subroutine inffre ( option, fotrva, foquva, titre0,
   2      >                    nocham, nrocmp, nrotab,
   3      >                    nbtrvi, nbquvi,
   4      >                    nntrvi, nnquvi,
   5      >                    nnoeca, ntreca, nqueca,
   6      >                    nnoeho, ntreho, nqueho,
   7      >                    lgnoin, lgtrin, lgquin,
   8      >                    nnoein, ntrein, nquein,
   9      >                    decanu,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c   INformation : Fichier - Fonction - REcuperation
  32 c   --            -         -          --
  33 c ______________________________________________________________________
  34 c
  35 c prise en compte de la fonction
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . option . e   .   1    . 1 : la sortie est exprimee sur des elements.
  41 c .        .     .        .     Si le champ est aux noeuds, on prend   .
  42 c .        .     .        .     la moyenne des valeurs sur tous ses    .
  43 c .        .     .        .     noeuds                                 .
  44 c .        .     .        .     Si le champ est aux noeuds par element .
  45 c .        .     .        .     ou aux points de Gauss, on prend la    .
  46 c .        .     .        .     moyenne des valeurs sur l'element      .
  47 c .        .     .        . 2 : la sortie est exprimee sur des noeuds  .
  48 c .        .     .        .     Si le champ est aux elements, on prend .
  49 c .        .     .        .     la moyenne des valeurs sur tous les    .
  50 c .        .     .        .     elements voisins du noeud              .
  51 c . fotrva .  s  . nbtrvi . fonctions triangles : valeur               .
  52 c .        .     .        . ou fonctions par noeud                     .
  53 c . foquva .  s  . nbquvi . fonctions quadrangles : valeur             .
  54 c . titre0 .  s  . char * . titre auxiliaire                           .
  55 c . nocham . e   . char8  . nom de l'objet champ                       .
  56 c . nrocmp . e   .   1    . 0 : le module (non operationnel)           .
  57 c .        .     .        . numero de la composante retenue            .
  58 c . nrotab . e   .   1    . numero du tableau associe au pas de temps  .
  59 c . nbtrvi . e   .   1    . nombre triangles visualisables             .
  60 c . nbquvi . e   .   1    . nombre de quadrangles visualisables        .
  61 c . nntrvi . e   .10nbtrvi. 1 : niveau du triangle a afficher          .
  62 c .        .     .        . 2 : numero HOMARD du triangle              .
  63 c .        .     .        . 3, 4, 5 : numeros des noeuds p1            .
  64 c .        .     .        . 6 : famille du triangle                    .
  65 c .        .     .        . 7, 8, 9 : numeros des noeuds p2            .
  66 c .        .     .        . 10 : numero du noeud interne               .
  67 c . nnquvi . e   .12nbquvi. 1 : niveau du quadrangle a afficher        .
  68 c .        .     .        . 2 : numero HOMARD du quadrangle            .
  69 c .        .     .        . 3, 4, 5, 6 : numeros des noeuds p1         .
  70 c .        .     .        . 7 : famille du quadrangle                  .
  71 c .        .     .        . 8, 9, 10, 11 : numeros des noeuds p2       .
  72 c .        .     .        . 12 : numero du noeud interne               .
  73 c . nnoeca . e   . renoto . noeuds en entree dans le calcul            .
  74 c . ntreca . e   . retrto . nro des triangles dans le calcul en entree .
  75 c . nqueca . e   . requto . nro des quads dans le calcul en entree     .
  76 c . nnoeho . e   . renoto . nro des noeuds dans HOMARD en entree       .
  77 c . ntreho . e   . retrto . nro des triangles dans HOMARD en entree    .
  78 c . nqueho . e   . requto . nro des quads dans HOMARD en entree        .
  79 c . decanu . e   .  -1:7  . decalage des numerotations selon le type   .
  80 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  81 c . langue . e   .    1   . langue des messages                        .
  82 c .        .     .        . 1 : francais, 2 : anglais                  .
  83 c . codret .  s  .    1   . code de retour des modules                 .
  84 c .        .     .        . 0 : pas de probleme                        .
  85 c ______________________________________________________________________
  86 c
  87 c====
  88 c 0. declarations et dimensionnement
  89 c====
  90 c
  91 c 0.1. ==> generalites
  92 c
  93       implicit none
  94       save
  95 c
  96       character*6 nompro
  97       parameter ( nompro = 'INFFRE' )
  98 c
  99 #include "nblang.h"
 100 #include "consts.h"
 101 #include "meddc0.h"
 102 #include "fractb.h"
 103 #include "fractc.h"
 104 #include "fracte.h"
 105 #include "fractf.h"
 106 #include "esutil.h"
 107 c
 108 c 0.2. ==> communs
 109 c
 110 #include "envex1.h"
 111 c
 112 #include "gmenti.h"
 113 #include "gmreel.h"
 114 #include "gmstri.h"
 115 c
 116 #include "nomber.h"
 117 #include "envca1.h"
 118 c
 119 c 0.3. ==> arguments
 120 c
 121       integer option
 122       integer nrocmp, nrotab
 123       integer nbtrvi, nbquvi
 124       integer nntrvi(10,nbtrvi)
 125       integer nnquvi(12,nbquvi)
 126       integer nnoeca(renoto), ntreca(retrto), nqueca(requto)
 127       integer nnoeho(*), ntreho(*), nqueho(*)
 128       integer lgnoin, lgtrin, lgquin
 129       integer nnoein(*), ntrein(*), nquein(*)
 130       integer decanu(-1:7)
 131 c
 132       double precision fotrva(*), foquva(*)
 133 c
 134       character*8 nocham
 135       character*(*) titre0
 136 c
 137       integer ulsort, langue, codret
 138 c
 139 c 0.4. ==> variables locales
 140 c
 141       integer nbcomp, nbtvch, typcha
 142       integer adnocp, adcaen, adcare, adcaca
 143       integer nrtvch
 144       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
 145       integer carsup, nbtafo, typint
 146       integer advale, advalr, adobch, adprpg, adtyas
 147       integer nbenti, adpcan, adlipr
 148       integer numdt
 149 c
 150       integer iaux1, iaux2, iaux3
 151       integer iaux, jaux, kaux
 152       integer adtra1
 153 c
 154       logical prem
 155 c
 156       double precision daux1, daux2
 157 c
 158       character*8 ntrav1
 159       character*8 obpcan
 160       character*8 saux08
 161       character*64 noprof
 162       character*64 nomcha
 163 c
 164       integer nbmess
 165       parameter ( nbmess = 10 )
 166       character*80 texte(nblang,nbmess)
 167 c_______________________________________________________________________
 168 c
 169 c====
 170 c 1. initialisation
 171 c====
 172 c 1.1. ==> messages
 173 c
 174 #include "impr01.h"
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,1)) 'Entree', nompro
 178       call dmflsh (iaux)
 179 #endif
 180 c
 181       texte(1,4) = '(''Objet champ a examiner : '',a)'
 182       texte(1,5) = '(''Nom du champ : '',a)'
 183       texte(1,6) = '(a,'' :'',i5)'
 184       texte(1,7) = '(''Impossible de projeter sur les noeuds'')'
 185 c
 186       texte(2,4) = '(''Field object : '',a)'
 187       texte(2,5) = '(''Field name : '',a)'
 188       texte(2,6) = '(a,'' :'',i5)'
 189       texte(2,7) = '(''Node projection cannot be done'')'
 190 c
 191 #include "impr03.h"
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,texte(langue,4)) nocham
 195       call gmprsx (nompro,nocham)
 196       call gmprsx (nompro,nocham//'.Nom_Comp')
 197       call gmprsx (nompro,nocham//'.Cham_Car')
 198 #endif
 199 c
 200 c====
 201 c 2. Decodage du champ retenu
 202 c====
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,3)) 'UTCACH', nompro
 206 #endif
 207       call utcach ( nocham,
 208      >              nomcha,
 209      >              nbcomp, nbtvch, typcha,
 210      >              adnocp, adcaen, adcare, adcaca,
 211      >              ulsort, langue, codret )
 212 c
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,texte(langue,5)) nomcha
 215       write (ulsort,texte(langue,6)) 'nbcomp', nbcomp
 216       write (ulsort,texte(langue,6)) 'nbtvch', nbtvch
 217 #endif
 218 c
 219 c====
 220 c 3. parcours des differents tableaux stockant les valeurs de ce champ
 221 c====
 222 c
 223       prem = .true.
 224 c
 225       if ( codret.eq.0 ) then
 226 c
 227       do 30 , nrtvch = 1 , nbtvch
 228 c
 229 c 3.1. ==> reperage du bon pas de temps
 230 c          . on retient le premier tableau correspondant a celui cherche
 231 c          . ensuite on retient tous ceux qui correspondent au meme
 232 c            numero de pas de temps. cela correspond au cas ou le champ
 233 c            est present sur plusieurs supports differents (tria+quad
 234 c            par exemple)
 235 c
 236         if ( codret.eq.0 ) then
 237 c
 238 c 3.1.1. ==> pour le premier tableau du bon pas de temps
 239 c
 240         if ( nrtvch.eq.nrotab) then
 241 c
 242           numdt  = imem(adcaen+nbinec*(nrtvch-1)+1)
 243           prem = .false.
 244           jaux = len(titre0)
 245           if ( numdt.ne.ednodt ) then
 246 c                          123456
 247             titre0(1:6) = '( t = '
 248             daux1 = rmem(adcare+nrtvch-1)
 249             call utrech ( daux1, 'G', iaux, titre0(7:jaux),
 250      >                    ulsort, langue, codret )
 251             if ( codret.eq.0 ) then
 252               titre0(iaux+1:iaux+2) = ' )'
 253             endif
 254           endif
 255           if ( codret.ne.0 .or. numdt.eq.ednodt ) then
 256             codret = 0
 257             do 31 , iaux = 1 , jaux
 258               titre0(iaux:iaux) = ' '
 259    31       continue
 260           endif
 261 c
 262         else
 263 c
 264 c 3.1.2. ==> pour un autre tableau
 265 c
 266           if ( prem ) then
 267             goto 30
 268           else
 269             if ( imem(adcaen+nbinec*(nrtvch-1)+1).ne.numdt ) then
 270               goto 30
 271             endif
 272           endif
 273 c
 274         endif
 275         iaux1 = imem(adcaen+nbinec*(nrtvch-1)+8)
 276 c
 277 c
 278         endif
 279 c
 280 c 3.2. ==> reperage de la fonction
 281 c
 282         saux08 = smem(adcaca+nbincc*(nrtvch-1))
 283 c
 284         if ( codret.eq.0 ) then
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287         call gmprsx (nompro, saux08 )
 288 cgn        call gmprsx (nompro, saux08//'.ValeursR' )
 289 #endif
 290 c
 291 #ifdef _DEBUG_HOMARD_
 292       write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 293 #endif
 294         call utcafo ( saux08,
 295      >                typcha,
 296      >                typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 297      >                carsup, nbtafo, typint,
 298      >                advale, advalr, adobch, adprpg, adtyas,
 299      >                ulsort, langue, codret )
 300 c
 301         endif
 302 c
 303         kaux = nbtafo*ngauss
 304 c
 305 cgn 1789   format(i4,12f15.7)
 306 cgn      print *, 'ngauss = ',ngauss
 307 cgn      print *, 'nbenmx = ',nbenmx
 308 cgn      print *, 'nrocmp = ',nrocmp
 309 cgn      print *, 'nbtafo = ',nbtafo
 310 cgn      print *, 'nbvapr = ',nbvapr
 311 cgn        if ( typgeo.eq.0 ) then
 312 cgn        do 310,jaux=1,nbenmx
 313 cgn         print 1789, jaux,
 314 cgn     >    (rmem(advalr+kaux*(jaux-1)+iaux-1),
 315 cgn     >     iaux=iaux1,iaux1+nbcomp-1)
 316 cgn 310   continue
 317 cgn        do 311,jaux=1,nbenmx*kaux
 318 cgn         print 1789, jaux,
 319 cgn     >    rmem(advalr+1*(jaux-1))
 320 cgn 311   continue
 321 cgn       endif
 322 c
 323 c 3.3. ==> changements de numerotation
 324 c
 325 c 3.3.1. ==> profil eventuel
 326 c
 327         if ( nbvapr.gt.0 ) then
 328 c
 329           if ( codret.eq.0 ) then
 330 c
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,texte(langue,3)) 'UTCAPR', nompro
 333 #endif
 334           call utcapr ( smem(adprpg),
 335      >                  iaux, noprof, adlipr,
 336      >                  ulsort, langue, codret )
 337 c
 338           endif
 339 c
 340         endif
 341 c
 342 c 3.3.2. ==> allocation du tableau de renumerotation
 343 c
 344         if ( codret.eq.0 ) then
 345 c
 346         if ( typgeo.eq.0 ) then
 347           nbenti = renoac
 348         elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
 349           nbenti = retrac
 350         elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
 351           nbenti = requac
 352         else
 353           nbenti = 0
 354         endif
 355 c
 356         call gmalot ( obpcan, 'entier  ', nbenti, adpcan, codret )
 357 c
 358         endif
 359 c
 360 c 3.3.3. ==> renumerotation
 361 c
 362         if ( codret.eq.0 ) then
 363 c
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,texte(langue,6)) 'typgeo', typgeo
 366       write (ulsort,texte(langue,6)) 'nbenti', nbenti
 367       write (ulsort,texte(langue,6)) 'nbvapr', nbvapr
 368 #endif
 369 c
 370         if ( codret.eq.0 ) then
 371 c
 372         call gmalot ( ntrav1, 'entier  ', nbenti, adtra1, codret )
 373 c
 374         endif
 375 c
 376         if ( typgeo.eq.0 ) then
 377 c
 378           if ( codret.eq.0 ) then
 379 c
 380           iaux = 0
 381 #ifdef _DEBUG_HOMARD_
 382       write (ulsort,texte(langue,3)) 'UTTBRC-no', nompro
 383 #endif
 384           call uttbrc ( iaux,
 385      >                  lgnoin, nnoein, nbenti, imem(adtra1),
 386      >                  ulsort, langue, codret)
 387 c
 388           endif
 389 c
 390           if ( codret.eq.0 ) then
 391 c
 392           iaux = 1
 393           jaux = decanu(-1)
 394 #ifdef _DEBUG_HOMARD_
 395       write (ulsort,texte(langue,3)) 'UTPR02-no', nompro
 396 #endif
 397           call utpr02 ( iaux,
 398      >                  nbenti, nbvapr, imem(adlipr),
 399      >                  nnoeho, nnoeca, jaux,
 400      >                  lgnoin, nnoein, imem(adtra1),
 401      >                  imem(adpcan),
 402      >                  ulsort, langue, codret )
 403 c
 404           endif
 405 c
 406         elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
 407 c
 408           if ( codret.eq.0 ) then
 409 c
 410           iaux = 1
 411 #ifdef _DEBUG_HOMARD_
 412       write (ulsort,texte(langue,3)) 'UTTBRC-tr', nompro
 413 #endif
 414           call uttbrc ( iaux,
 415      >                  lgtrin, ntrein, nbenti, imem(adtra1),
 416      >                  ulsort, langue, codret)
 417 c
 418           endif
 419 c
 420           if ( codret.eq.0 ) then
 421 c
 422           iaux = 1
 423           jaux = decanu(2)
 424 #ifdef _DEBUG_HOMARD_
 425       write (ulsort,texte(langue,3)) 'UTPR02-tr', nompro
 426 #endif
 427           call utpr02 ( iaux,
 428      >                  nbenti, nbvapr, imem(adlipr),
 429      >                  ntreho, ntreca, jaux,
 430      >                  lgtrin, ntrein, imem(adtra1),
 431      >                  imem(adpcan),
 432      >                  ulsort, langue, codret )
 433 c
 434           endif
 435 c
 436         elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
 437 c
 438           if ( codret.eq.0 ) then
 439 cgn      write (ulsort,*) 'nquein'
 440 cgn      write (ulsort,91020) (nquein(iaux), iaux = 1 , lgquin)
 441 c
 442           iaux = 1
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,3)) 'UTTBRC-qu', nompro
 445 #endif
 446           call uttbrc ( iaux,
 447      >                  lgquin, nquein, nbenti, imem(adtra1),
 448      >                  ulsort, langue, codret)
 449 c
 450           endif
 451 c
 452           if ( codret.eq.0 ) then
 453 c
 454           iaux = 1
 455           jaux = decanu(4)
 456 #ifdef _DEBUG_HOMARD_
 457       write (ulsort,texte(langue,3)) 'UTPR02-qu', nompro
 458 #endif
 459           call utpr02 ( iaux,
 460      >                  nbenti, nbvapr, imem(adlipr),
 461      >                  nqueho, nqueca, jaux,
 462      >                  lgquin, nquein, imem(adtra1),
 463      >                  imem(adpcan),
 464      >                  ulsort, langue, codret )
 465 c
 466           endif
 467 c
 468         endif
 469 c
 470         endif
 471 c
 472         if ( codret.eq.0 ) then
 473 c
 474         call gmlboj ( ntrav1 , codret )
 475 c
 476         endif
 477 c
 478 c 3.4. ==> transfert en fonction du support
 479 c
 480         if ( codret.eq.0 ) then
 481 c
 482         jaux = advalr - 2 + iaux1 + nrocmp - kaux
 483 c
 484 c 3.4.1. ==> sur les noeuds
 485 c
 486 cgn 1792 format(3i10,g15.7)
 487         if ( typgeo.eq.0 ) then
 488 c
 489           if ( option.eq.1 .and. degre.eq.1 ) then
 490 c
 491             do 3411 , iaux = 1 , nbtrvi
 492 cgn          print *,'                      ',iaux
 493 cgn          print 1792,nntrvi(3,iaux),nnoeca(nntrvi(3,iaux)),
 494 cgn     >        imem( adpcan + nnoeca(nntrvi(3,iaux))-1),
 495 cgn     >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1))
 496 cgn          print *,kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1)
 497 cgn          print 1792,nntrvi(4,iaux),nnoeca(nntrvi(4,iaux)),
 498 cgn     >        imem( adpcan + nnoeca(nntrvi(4,iaux))-1),
 499 cgn     >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1))
 500 cgn          print 1792,nntrvi(5,iaux),nnoeca(nntrvi(5,iaux)),
 501 cgn     >        imem( adpcan + nnoeca(nntrvi(5,iaux))-1),
 502 cgn     >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1))
 503               fotrva(iaux) = unstr * (
 504      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1)) +
 505      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) +
 506      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1)) )
 507 cgn          print 1789,iaux,fotrva(iaux)
 508  3411       continue
 509 c
 510             do 3412 , iaux = 1 , nbquvi
 511 cgn          if ( ( nnquvi(2,iaux).ge.27713 .and.
 512 cgn     >           nnquvi(2,iaux).le.27716 ) .or.
 513 cgn     >         ( nnquvi(2,iaux).ge.27725 .and.
 514 cgn     >           nnquvi(2,iaux).le.27728 ) .or.
 515 cgn     >           nnquvi(2,iaux).eq.17127 .or.
 516 cgn     >           nnquvi(2,iaux).eq.17198) ) then
 517 cgn          print *,'                   ',iaux,' (',nnquvi(2,iaux),')'
 518 cgn          print 1792,nnquvi(3,iaux),nnoeca(nnquvi(3,iaux)),
 519 cgn     >        imem(adpcan+nnoeca(nnquvi(3,iaux))-1),
 520 cgn     >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1))
 521 cgn          print 1792,nnquvi(4,iaux),nnoeca(nnquvi(4,iaux)),
 522 cgn        >       imem(adpcan+nnoeca(nnquvi(4,iaux))-1),
 523 cgn        >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1))
 524 cgn             print 1792,nnquvi(5,iaux),nnoeca(nnquvi(5,iaux)),
 525 cgn        >       imem(adpcan+nnoeca(nnquvi(5,iaux))-1),
 526 cgn        >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1))
 527 cgn              print 1792,nnquvi(6,iaux),nnoeca(nnquvi(6,iaux)),
 528 cgn        >       imem(adpcan+nnoeca(nnquvi(6,iaux))-1),
 529 cgn        >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1))
 530 cgn             endif
 531              foquva(iaux) = unsqu * (
 532      >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1)) +
 533      >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1)) +
 534      >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1)) +
 535      >       rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1)) )
 536 cgn          if ( ( nnquvi(2,iaux).ge.27713 .and.
 537 cgn     >           nnquvi(2,iaux).le.27716 ) .or.
 538 cgn     >         ( nnquvi(2,iaux).ge.27725 .and.
 539 cgn     >           nnquvi(2,iaux).le.27728 ) .or.
 540 cgn     >           nnquvi(2,iaux).eq.17127 .or.
 541 cgn     >           nnquvi(2,iaux).eq.17198) ) then
 542 cgn            print 1789,iaux,foquva(iaux)
 543 cgn           endif
 544 3412       continue
 545 c
 546           elseif ( option.eq.1 .and. degre.eq.2 ) then
 547 c
 548             do 3413 , iaux = 1 , nbtrvi
 549               fotrva(iaux) = unssix * (
 550      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) +
 551      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) +
 552      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1)) +
 553      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(7,iaux))-1)) +
 554      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(8,iaux))-1)) +
 555      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(9,iaux))-1)) )
 556  3413       continue
 557 c
 558             do 3414 , iaux = 1 , nbquvi
 559               foquva(iaux) = unshu * (
 560      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1)) +
 561      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1)) +
 562      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1)) +
 563      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1)) +
 564      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(8,iaux))-1)) +
 565      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(9,iaux))-1)) +
 566      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(10,iaux))-1)) +
 567      >        rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(11,iaux))-1)) )
 568  3414       continue
 569 c
 570           else
 571 c
 572             do 3415 , iaux = 1 , nbenti
 573               fotrva(iaux) = rmem(jaux+kaux*imem(adpcan+nnoeca(iaux)-1))
 574  3415       continue
 575 c
 576           endif
 577 c
 578 c 3.4.2. ==> fonction exprimee sur les triangles
 579 c
 580         elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
 581 c
 582           if ( option.eq.1 ) then
 583 c
 584 c 3.4.2.1. ==> une valeur constante par element
 585 c
 586             if ( ngauss.eq.1 ) then
 587 c
 588               do 3421 , iaux = 1 , nbtrvi
 589 cgn          print *,iaux,nntrvi(2,iaux),ntreca(nntrvi(2,iaux)),
 590 cgn     > imem(adpcan+ntreca(nntrvi(2,iaux))-1)
 591                 fotrva(iaux) = rmem( jaux +
 592      >                      kaux*imem(adpcan+ntreca(nntrvi(2,iaux))-1) )
 593 cgn          print 1789,iaux,fotrva(iaux)
 594  3421         continue
 595 c
 596             else
 597 c
 598 c 3.4.2.2. ==> plusieurs valeurs par element (points de Gauss)
 599 c
 600               daux1 = 1.d0/dble(ngauss)
 601 c
 602               iaux2 = jaux - nbtafo
 603               do 3422 , iaux = 1 , nbtrvi
 604                 daux2 = 0.d0
 605                 iaux3 = iaux2
 606      >                + kaux*imem(adpcan+ntreca(nntrvi(2,iaux))-1)
 607                 do 34221 , iaux1 = 1 , ngauss
 608                   daux2 = daux2 + rmem(iaux3+iaux1*nbtafo )
 609 34221           continue
 610                 fotrva(iaux) = daux1*daux2
 611  3422         continue
 612 c
 613             endif
 614 c
 615           else
 616 c
 617             write (ulsort,texte(langue,7))
 618 c
 619           endif
 620 c
 621 c 3.4.3. ==> fonction exprimee sur les quadrangles
 622 c
 623         elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
 624 c
 625           if ( option.eq.1 ) then
 626 c
 627 c 3.4.3.1. ==> une valeur constante par element
 628 c
 629             if ( ngauss.eq.1 ) then
 630 c
 631               do 3431 , iaux = 1 , nbquvi
 632 cgn            write (ulsort,90015) 'foquva(', iaux,')',nnquvi(2,iaux),nqueca(nnquvi(2,iaux)),
 633 cgn     > imem(adpcan+nqueca(nnquvi(2,iaux))-1)
 634                 foquva(iaux) = rmem( jaux +
 635      >                      kaux*imem(adpcan+nqueca(nnquvi(2,iaux))-1) )
 636 cgn          print 1789,iaux,foquva(iaux)
 637  3431         continue
 638 c
 639             else
 640 c
 641 c 3.4.3.2. ==> plusieurs valeurs par element (points de Gauss)
 642 c
 643               daux1 = 1.d0/dble(ngauss)
 644 c
 645               iaux2 = jaux - nbtafo
 646               do 3432 , iaux = 1 , nbquvi
 647                 daux2 = 0.d0
 648                 iaux3 = iaux2
 649      >                + kaux*imem(adpcan+nqueca(nnquvi(2,iaux))-1)
 650                 do 34321 , iaux1 = 1 , ngauss
 651                   daux2 = daux2 + rmem(iaux3+iaux1*nbtafo )
 652 34321           continue
 653                 foquva(iaux) = daux1*daux2
 654  3432         continue
 655 c
 656             endif
 657 c
 658           else
 659 c
 660             write (ulsort,texte(langue,7))
 661 c
 662           endif
 663 c
 664         endif
 665 c
 666         endif
 667 c
 668 c 3.5. ==> menage
 669 c
 670         if ( codret.eq.0 ) then
 671 c
 672         call gmlboj ( obpcan, codret )
 673 c
 674         endif
 675 c
 676    30 continue
 677 c
 678       endif
 679 c
 680 c====
 681 c 4. la fin
 682 c====
 683 c
 684       if ( codret.ne.0 ) then
 685 c
 686 #include "envex2.h"
 687 c
 688       write (ulsort,texte(langue,1)) 'Sortie', nompro
 689       write (ulsort,texte(langue,2)) codret
 690 c
 691       endif
 692 c
 693 #ifdef _DEBUG_HOMARD_
 694       write (ulsort,texte(langue,1)) 'Sortie', nompro
 695       call dmflsh (iaux)
 696 #endif
 697 c
 698       end