src/tool/AP_Conversion/pcsar1.F

   1       subroutine pcsar1 ( nbfonc, typint, deraff,
   2      >                    prfcan, prfcap,
   3      >                    hetare, ancare, filare,
   4      >                    nbanar, anfiar,
   5      >                    somare,
   6      >                    hettri, aretri, filtri,
   7      >                    nareca, narsca,
   8      >                    vafoen, vafott,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aPres adaptation - Conversion de Solution -
  31 c     -                 -             -
  32 c                       ARetes - solution P0 - etape 1
  33 c                       --                           -
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  39 c . typint . e   .   1    . type d'interpolation                       .
  40 c .        .     .        .  0, si automatique                         .
  41 c .        .     .        .  elements : 0 si intensif, sans orientation.
  42 c .        .     .        .             1 si extensif, sans orientation.
  43 c .        .     .        .             2 si intensif, avec orientation.
  44 c .        .     .        .             3 si extensif, avec orientation.
  45 c .        .     .        .  noeuds : 1 si degre 1                     .
  46 c .        .     .        .           2 si degre 2                     .
  47 c .        .     .        .           3 si iso-P2                      .
  48 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  49 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  50 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  51 c .        .     .        . 0 : l'entite est absente du profil         .
  52 c .        .     .        . i : l'entite est au rang i dans le profil  .
  53 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  54 c .        .     .        . 0 : l'entite est absente du profil         .
  55 c .        .     .        . 1 : l'entite est presente dans le profil   .
  56 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  57 c . ancare . e   . nbarto . anciens numeros des aretes conservees      .
  58 c . filare . e   . nbarto . fille ainee de chaque arete                .
  59 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  60 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  61 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  62 c . filtri . e   . nbtrto . premier fils des triangles                 .
  63 c . nareca . e   .   *    . nro des aretes dans le calcul en entree    .
  64 c . narsca . e   . rsarto . numero des aretes du calcul                .
  65 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  66 c .        .     .    *   .                                            .
  67 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  68 c .        .     .    *   .                                            .
  69 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  70 c . langue . e   .    1   . langue des messages                        .
  71 c .        .     .        . 1 : francais, 2 : anglais                  .
  72 c . codret . es  .    1   . code de retour des modules                 .
  73 c .        .     .        . 0 : pas de probleme                        .
  74 c .        .     .        . 1 : probleme                               .
  75 c ______________________________________________________________________
  76 c
  77 c====
  78 c 0. declarations et dimensionnement
  79 c====
  80 c
  81 c 0.1. ==> generalites
  82 c
  83       implicit none
  84       save
  85 c
  86       character*6 nompro
  87       parameter ( nompro = 'PCSAR1' )
  88 c
  89 #include "nblang.h"
  90 #include "fracta.h"
  91 #include "fractc.h"
  92 c
  93 c 0.2. ==> communs
  94 c
  95 #include "envex1.h"
  96 c
  97 #include "nombar.h"
  98 #include "nombtr.h"
  99 #include "nombsr.h"
 100 #include "nomber.h"
 101 c
 102 #include "demitr.h"
 103 #include "ope1a3.h"
 104 c
 105 c 0.3. ==> arguments
 106 c
 107       integer nbfonc
 108       integer typint
 109       integer prfcan(*), prfcap(*)
 110       integer hetare(nbarto), ancare(*)
 111       integer filare(nbarto)
 112       integer nbanar, anfiar(nbanar)
 113       integer somare(2,*)
 114       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 115       integer nareca(rearto), narsca(rsarto)
 116 c
 117       double precision vafoen(nbfonc,*)
 118       double precision vafott(nbfonc,*)
 119 c
 120       logical deraff
 121 c
 122       integer ulsort, langue, codret
 123 c
 124 c 0.4. ==> variables locales
 125 c
 126 c     arcn = ARetes en numerotation Calcul a l'iteration N
 127 c     arhnp1 = ARetes en numerotation HOMARD a l'iteration N+1
 128 c     arcnp1 = ARetes en numerotation Calcul a l'iteration N+1
 129 c
 130       integer arcn(4)
 131       integer arhnp1(3)
 132       integer arcnp1(3)
 133 c
 134 c     etan   = ETAt du triangle a l'iteration N
 135 c
 136       integer etan
 137 c
 138 c     f1trhp = Fils 1er du triangle en numerotation Homard a l'it. N+1
 139 c
 140       integer f1trhp
 141 c
 142 c     f1hn = Fille 1er de l'arete en numerotation Homard a l'it. N
 143 c
 144       integer f1hn
 145 c
 146       integer letria, letri0
 147 c
 148       integer typdec
 149       integer nrofon
 150       integer lareth, laretc
 151       integer iaux, jaux
 152       integer oripei(3), orifii(3)
 153       integer nufilo(3,3), nuarfi(3,3), nuarff(3,4)
 154 c
 155       double precision champ0(3), champ1(3,3), flux
 156       double precision oriped(3)
 157 c
 158       logical afaire
 159 c
 160       integer nbmess
 161       parameter ( nbmess = 10 )
 162       character*80 texte(nblang,nbmess)
 163 c
 164 c 0.5. ==> initialisations
 165 c ______________________________________________________________________
 166 c
 167 c====
 168 c 1. initialisations
 169 c====
 170 c
 171 #include "pcimp0.h"
 172 #include "impr01.h"
 173 #include "impr03.h"
 174 c
 175 #ifdef _DEBUG_HOMARD_
 176       write (ulsort,texte(langue,1)) 'Entree', nompro
 177       call dmflsh (iaux)
 178 #endif
 179 c
 180       texte(1,4) =
 181      > '(/,''Arete en cours : nro a l''''iteration '',a3,'' : '',i8)'
 182       texte(1,5) =
 183      > '(  ''                etat a l''''iteration '',a3,'' : '',i4)'
 184       texte(1,6) = '(  ''==> Aucune interpolation'')'
 185 c
 186       texte(2,4) =
 187      > '(/,''Current edge : # at iteration '',a3,'' : '',i8)'
 188       texte(2,5) =
 189      > '(  ''          status at iteration '',a3,'' : '',i4)'
 190       texte(2,6) = '(  ''==> No interpolation'')'
 191 c
 192       codret = 0
 193 c
 194 #ifdef _DEBUG_HOMARD_
 195       write (ulsort,90002) 'nbfonc', nbfonc
 196 #endif
 197 cgn      write(ulsort,*) 'nareca'
 198 cgn      write(ulsort,91020) nareca
 199 cgn      write(ulsort,*) 'prfcan'
 200 cgn      write(ulsort,91020)(prfcan(iaux),iaux=1,74)
 201 c
 202 c====
 203 c 2. on boucle sur toutes les triangles du maillage HOMARD
 204 c====
 205 c
 206       do 20 , letri0 = 1, nbtrto
 207 c
 208         letria = letri0
 209 c
 210 cgn        write (ulsort,*) ' '
 211 cgn        write (ulsort,90002) 'Triangle', letria
 212 cgn        write (ulsort,90012) '. aretes du triangle HOMARD', letria,
 213 cgn     >      (aretri(letria,iaux),iaux=1,3)
 214 cgn        if ( mod(hettri(letria),10).eq.0 ) then
 215 cgn        write (ulsort,90012) '. aretes du triangle Calcul', letria,
 216 cgn     >      (narsca(aretri(letria,iaux)),iaux=1,3)
 217 cgn        endif
 218 c
 219 c 2.1. ==> Type de decoupage
 220 c
 221         call pcs3tr ( letria, prfcan,
 222      >                somare, hettri, aretri,
 223      >                nbanar, anfiar,
 224      >                nareca,
 225      >                afaire, typdec, etan, oripei )
 226 c
 227 cgn        write (ulsort,90015) '. typdec', typdec,', etan', etan
 228 cgn        write (ulsort,99001) 'afaire', afaire
 229 c
 230         if ( afaire ) then
 231 c
 232 c 2.2. ==> Les caracteritiques du triangle
 233 c
 234         arhnp1(1) = aretri(letria,1)
 235         arhnp1(2) = aretri(letria,2)
 236         arhnp1(3) = aretri(letria,3)
 237 c
 238 c 2.2.1. ==> Orientations relatives des aretes du triangle
 239 c
 240 cgn        write (ulsort,90002) '. orientations                       ',
 241 cgn     >              oripei
 242         do 221 , iaux = 1 , 3
 243           oriped(iaux) = dble(oripei(iaux))
 244   221   continue
 245 cgn        if ( typdec.eq.4 ) then
 246 cgn        write (ulsort,90002) '. filles arete 1 du triangle H/C n+1',
 247 cgn     >      filare(arhnp1(1)),filare(arhnp1(1))+1,
 248 cgn     >      narsca(filare(arhnp1(1))),narsca(filare(arhnp1(1))+1)
 249 cgn        write (ulsort,90002) '. filles arete 2 du triangle H/C n+1',
 250 cgn     >      filare(arhnp1(2)),filare(arhnp1(2))+1,
 251 cgn     >      narsca(filare(arhnp1(2))),narsca(filare(arhnp1(2))+1)
 252 cgn        write (ulsort,90002) '. filles arete 3 du triangle H/C n+1',
 253 cgn     >      filare(arhnp1(3)),filare(arhnp1(3))+1,
 254 cgn     >      narsca(filare(arhnp1(3))),narsca(filare(arhnp1(3))+1)
 255 cgn        else
 256 cgn        write (ulsort,90015) '. filles arete', typdec,
 257 cgn     >      ' du triangle HOMARD n+1',
 258 cgn     >      filare(arhnp1(typdec)),filare(arhnp1(typdec))+1
 259 cgn        write (ulsort,90015) '. filles arete', typdec,
 260 cgn     >      ' du triangle Calcul n+1',
 261 cgn     >      narsca(filare(arhnp1(typdec))),
 262 cgn     >      narsca(filare(arhnp1(typdec))+1)
 263 cgn        endif
 264 c
 265 c 2.2.2. ==> Le fils du triangle
 266 c
 267 cgn        write (ulsort,90015) '. typdec', typdec,', etan', etan
 268         f1trhp = filtri(letria)
 269 cgn        write (ulsort,90015) '. aretes du fils', f1trhp,' HOMARD n+1',
 270 cgn     >      (aretri(f1trhp,iaux),iaux=1,3)
 271 cgn        write (ulsort,90015) '. aretes du fils', f1trhp,' Calcul n+1',
 272 cgn     >      (narsca(aretri(f1trhp,iaux)),iaux=1,3)
 273 c
 274 c 2.2.3. ==> Orientations relatives des aretes du fils du triangle
 275 c            s'il est coupe en 4
 276 c
 277         if ( typdec.eq.4 ) then
 278 c
 279         call utorat ( somare,
 280      >          aretri(f1trhp,1), aretri(f1trhp,2), aretri(f1trhp,3),
 281      >          orifii(1), orifii(2), orifii(3) )
 282 cgn        write (ulsort,90002) '. orientations                    ',
 283 cgn     >      orifii
 284 c
 285         endif
 286 c
 287 c 2.2.4. ==> Les aretes du triangle
 288 c 2.2.4.1. ==> S'il etait actif : arcn(1), (2), (3)
 289 c
 290         if ( etan.eq.0 ) then
 291 c
 292           arcn(1) = nareca(arhnp1(1))
 293           arcn(2) = nareca(arhnp1(2))
 294           arcn(3) = nareca(arhnp1(3))
 295 cgn      write(ulsort,90012)'. arete avant H Cn arcn(1)',
 296 cgn     >        arhnp1(1), arcn(1)
 297 cgn      write(ulsort,90012)'. arete avant H Cn arcn(2)',
 298 cgn     >        arhnp1(2), arcn(2)
 299 cgn      write(ulsort,90012)'. arete avant H Cn arcn(3)',
 300 cgn     >        arhnp1(3), arcn(3)
 301 c
 302 c 2.2.4.2. ==> S'il etait coupe en deux :
 303 c            arcn(1) : l'arete non coupee, avant celle coupee
 304 c            arcn(2) : l'arete non coupee, apres celle coupee
 305 c            arcn(3), arcn(4) : les 2 filles de l'aretes coupee
 306 c
 307         elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then
 308 c
 309           arcn(1) = nareca(aretri(letria,per1a3(-1,etan)))
 310 cgn      write(ulsort,90012)'. arete avant H Cn arcn(1)',
 311 cgn     >        aretri(letria,per1a3(-1,etan)), arcn(1)
 312           arcn(2) = nareca(aretri(letria,per1a3( 1,etan)))
 313 cgn      write(ulsort,90012)'. arete apres H Cn arcn(2)',
 314 cgn     >        aretri(letria,per1a3( 1,etan)), arcn(2)
 315           f1hn = anfiar(aretri(letria,etan))
 316 cgn      write(ulsort,90012)
 317 cgn     >      '. ancienne fille HOMARD de l''arete coupee',
 318 cgn     >        aretri(letria,etan), f1hn
 319           arcn(3) = nareca(f1hn)
 320 cgn      write(ulsort,90015)
 321 cgn     >      '. 1ere fille arete coupee H',f1hn,
 322 cgn     >      ', Cn arcn(3) =', arcn(3)
 323           arcn(4) = nareca(f1hn+1)
 324 cgn      write(ulsort,90015)'. 2nde fille arete coupee H',f1hn+1,
 325 cgn     >      ', Cn arcn(4) =',arcn(4)
 326 c
 327 c 2.2.4.3. ==> Decoupage en 4 avec bascule d'aretes
 328 c
 329         elseif ( etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then
 330           codret = 2243
 331           goto 2000
 332         endif
 333 c
 334 c 2.3. ==> Decoupage en 4 standard
 335 c
 336         if ( typdec.eq.4 ) then
 337 c
 338 c 2.3.1. ==> Quelles aretes tracees sur ce triangle ?
 339 c
 340           do 231 , iaux = 1 , 3
 341             arcnp1(iaux) = narsca(aretri(f1trhp,iaux))
 342             if ( arcnp1(iaux).eq.0 ) then
 343               goto 20
 344             endif
 345   231     continue
 346 c
 347 c 2.3.2. ==> Enregistrement
 348 c
 349           prfcap(arcnp1(1)) = 1
 350           prfcap(arcnp1(2)) = 1
 351           prfcap(arcnp1(3)) = 1
 352 c
 353 c 2.3.3. ==> Parcours des fonctions
 354 c 2.3.3.1. ==> numero des filles
 355 c           nufilo(i,j) = numero local de la fille de la j-eme arete
 356 c                         du pere pour le calcul de la valeur
 357 c                         sur la i-eme arete du fils
 358           if ( oripei(1).gt.0 ) then
 359             nufilo(2,1) = 0
 360             nufilo(3,1) = 1
 361           else
 362             nufilo(2,1) = 1
 363             nufilo(3,1) = 0
 364           endif
 365           if ( oripei(2).gt.0 ) then
 366             nufilo(1,2) = 1
 367             nufilo(3,2) = 0
 368           else
 369             nufilo(1,2) = 0
 370             nufilo(3,2) = 1
 371           endif
 372           if ( oripei(3).gt.0 ) then
 373             nufilo(1,3) = 0
 374             nufilo(2,3) = 1
 375           else
 376             nufilo(1,3) = 1
 377             nufilo(2,3) = 0
 378           endif
 379 c
 380           iaux = filare(arhnp1(3)) + nufilo(1,3)
 381           nuarfi(1,3) = narsca(iaux)
 382           if ( nuarfi(1,3).eq.0 ) then
 383             nuarff(1,1) = narsca(filare(iaux))
 384             nuarff(1,2) = narsca(filare(iaux)+1)
 385           endif
 386 c
 387           iaux = filare(arhnp1(2)) + nufilo(1,2)
 388           nuarfi(1,2) = narsca(iaux)
 389           if ( nuarfi(1,2).eq.0 ) then
 390             nuarff(1,3) = narsca(filare(iaux))
 391             nuarff(1,4) = narsca(filare(iaux)+1)
 392           endif
 393 c
 394           iaux = filare(arhnp1(1)) + nufilo(2,1)
 395           nuarfi(2,1) = narsca(iaux)
 396           if ( nuarfi(2,1).eq.0 ) then
 397             nuarff(2,1) = narsca(filare(iaux))
 398             nuarff(2,2) = narsca(filare(iaux)+1)
 399           endif
 400 c
 401           iaux = filare(arhnp1(3)) + nufilo(2,3)
 402           nuarfi(2,3) = narsca(iaux)
 403           if ( nuarfi(2,3).eq.0 ) then
 404             nuarff(2,3) = narsca(filare(iaux))
 405             nuarff(2,4) = narsca(filare(iaux)+1)
 406           endif
 407 c
 408           iaux = filare(arhnp1(1)) + nufilo(3,1)
 409           nuarfi(3,1) = narsca(iaux)
 410           if ( nuarfi(3,1).eq.0 ) then
 411             nuarff(3,1) = narsca(filare(iaux))
 412             nuarff(3,2) = narsca(filare(iaux)+1)
 413           endif
 414 c
 415           iaux = filare(arhnp1(2)) + nufilo(3,2)
 416           nuarfi(3,2) = narsca(iaux)
 417           if ( nuarfi(3,2).eq.0 ) then
 418             nuarff(3,3) = narsca(filare(iaux))
 419             nuarff(3,4) = narsca(filare(iaux)+1)
 420           endif
 421 cgn      write (ulsort,90002) '. filles pour 1', nuarfi(1,3), nuarfi(1,2)
 422 cgn      if ( nuarfi(1,3).eq.0 ) then
 423 cgn      write (ulsort,90002) '. petites filles pour 1',
 424 cgn     >                    nuarff(1,1), nuarff(1,2)
 425 cgn      endif
 426 cgn      if ( nuarfi(1,2).eq.0 ) then
 427 cgn      write (ulsort,90002) '. petites filles pour 1',
 428 cgn     >                    nuarff(1,3), nuarff(1,4)
 429 cgn      endif
 430 cgn      write (ulsort,90002) '. filles pour 2', nuarfi(2,1), nuarfi(2,3)
 431 cgn      if ( nuarfi(2,1).eq.0 ) then
 432 cgn      write (ulsort,90002) '. petites filles pour 2',
 433 cgn     >                    nuarff(2,1), nuarff(2,2)
 434 cgn      endif
 435 cgn      if ( nuarfi(2,3).eq.0 ) then
 436 cgn      write (ulsort,90002) '. petites filles pour 2',
 437 cgn     >                    nuarff(2,3), nuarff(2,4)
 438 cgn      endif
 439 cgn      write (ulsort,90002) '. filles pour 3', nuarfi(3,2), nuarfi(3,1)
 440 cgn      if ( nuarfi(3,2).eq.0 ) then
 441 cgn      write (ulsort,90002) '. petites filles pour 3',
 442 cgn     >                    nuarff(3,1), nuarff(3,2)
 443 cgn      endif
 444 cgn      if ( nuarfi(3,1).eq.0 ) then
 445 cgn      write (ulsort,90002) '. petites filles pour 3',
 446 cgn     >                    nuarff(3,3), nuarff(3,4)
 447 cgn      endif
 448 c
 449 c 2.3.3.2. ==> Interpolation
 450 c
 451           do 2321 , nrofon = 1 , nbfonc
 452 c
 453             if ( etan.eq.0 ) then
 454               champ0(1) = vafoen(nrofon,prfcan(arcn(1)))
 455               champ0(2) = vafoen(nrofon,prfcan(arcn(2)))
 456               champ0(3) = vafoen(nrofon,prfcan(arcn(3)))
 457             elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then
 458 cgn              write (ulsort,*) 'le triangle etait coupe en 2'
 459               champ0(etan) = vafoen(nrofon,prfcan(arcn(3)))
 460      >                     - vafoen(nrofon,prfcan(arcn(4)))
 461               champ0(per1a3(-1,etan)) = vafoen(nrofon,prfcan(arcn(1)))
 462               champ0(per1a3( 1,etan)) = vafoen(nrofon,prfcan(arcn(2)))
 463             endif
 464 cgn            write (ulsort,90004) '. champ0', champ0
 465 c
 466             call utflt0 ( somare, arhnp1,
 467      >                    champ0, flux,
 468      >                    ulsort, langue, codret )
 469             flux = unsqu*flux
 470 cgn         write (ulsort,90004) '. flux sur les 4 fils', flux
 471 c
 472               if ( nuarfi(1,3).ne.0 ) then
 473                 champ1(1,3) = vafott(nrofon,nuarfi(1,3))
 474               else
 475                 champ1(1,3) = vafott(nrofon,nuarff(1,1))
 476      >                      - vafott(nrofon,nuarff(1,2))
 477               endif
 478               if ( nuarfi(1,2).ne.0 ) then
 479                 champ1(1,2) = vafott(nrofon,nuarfi(1,2))
 480               else
 481                 champ1(1,2) = vafott(nrofon,nuarff(1,3))
 482      >                      - vafott(nrofon,nuarff(1,4))
 483               endif
 484               if ( nuarfi(2,1).ne.0 ) then
 485                 champ1(2,1) = vafott(nrofon,nuarfi(2,1))
 486               else
 487                 champ1(2,1) = vafott(nrofon,nuarff(2,1))
 488      >                      - vafott(nrofon,nuarff(2,2))
 489               endif
 490               if ( nuarfi(2,3).ne.0 ) then
 491                 champ1(2,3) = vafott(nrofon,nuarfi(2,3))
 492               else
 493                 champ1(2,3) = vafott(nrofon,nuarff(2,3))
 494      >                      - vafott(nrofon,nuarff(2,4))
 495               endif
 496               if ( nuarfi(3,2).ne.0 ) then
 497                 champ1(3,2) = vafott(nrofon,nuarfi(3,2))
 498               else
 499                 champ1(3,2) = vafott(nrofon,nuarff(3,1))
 500      >                      - vafott(nrofon,nuarff(3,2))
 501               endif
 502               if ( nuarfi(3,1).ne.0 ) then
 503                 champ1(3,1) = vafott(nrofon,nuarfi(3,1))
 504               else
 505                 champ1(3,1) = vafott(nrofon,nuarff(3,3))
 506      >                      - vafott(nrofon,nuarff(3,4))
 507               endif
 508 cgn      write (ulsort,90004) '. champ1 pour 1', champ1(1,3), champ1(1,2)
 509 cgn      write (ulsort,90004) '. champ1 pour 2', champ1(2,1), champ1(2,3)
 510 cgn      write (ulsort,90004) '. champ1 pour 3', champ1(3,2), champ1(3,1)
 511 c
 512             vafott(nrofon,arcnp1(1)) =
 513      >      orifii(1) * ( champ1(1,3) - champ1(1,2) - flux )
 514             vafott(nrofon,arcnp1(2)) =
 515      >      orifii(2) * ( champ1(2,1) - champ1(2,3) - flux )
 516              vafott(nrofon,arcnp1(3)) =
 517      >      orifii(3) * ( champ1(3,2) - champ1(3,1) - flux )
 518 cgn            do 2322 , iaux = 1 , 3
 519 cgn              write (ulsort,90024) '. arete',aretri(f1trhp,iaux),
 520 cgn     >        vafott(nrofon,arcnp1(iaux))
 521 cgn 2322       continue
 522 c
 523  2321     continue
 524 c
 525 c 2.4. ==> Decoupage en 2
 526 c
 527         elseif ( typdec.eq.1 .or. typdec.eq.2 .or. typdec.eq.3 ) then
 528 c
 529 c 2.4.1. ==> Quelle arete tracee sur ce triangle ?
 530 c            On base tout le raisonnement sur le triangle fils
 531 c            au rang nutrde(i,i+1) dans la numerotation
 532 c            Voir cmcdtr pour les conventions
 533 c         le bon fils :
 534           iaux = f1trhp + nutrde(typdec, per1a3(1,typdec))
 535 cgn          write (ulsort,90002) '. les 2 fils ', f1trhp, f1trhp+1
 536 cgn          write (ulsort,90002) '. le bon fils', iaux
 537 c         la bonne arete : celle a la place i-1
 538 cgn          write (ulsort,90002) '. per1a3(-1,typdec)', per1a3(-1,typdec)
 539           lareth = aretri(iaux,per1a3(-1,typdec))
 540 cgn          write (ulsort,90002) '. lareth', lareth, narsca(lareth)
 541           arcnp1(3) = narsca(lareth)
 542           if ( arcnp1(3).eq.0 ) then
 543             goto 20
 544           endif
 545 cgn          write (ulsort,90015) '. arete centrale HOMARD', lareth,
 546 cgn     >                         ', Calcul n+1', arcnp1(3)
 547 c
 548 c 2.4.2. ==> Les demi-aretes de la base du triangle
 549 c            arcnp1(1) : la premiere fille de l'arete coupee
 550 c            arcnp1(2) : la seconde fille de l'arete coupee
 551 c
 552           arcnp1(1) = narsca(filare(aretri(letria,typdec)))
 553           arcnp1(2) = narsca(filare(aretri(letria,typdec))+1)
 554 cgn          write (ulsort,90002) '. aretes filles', arcnp1(1),arcnp1(2)
 555 c
 556 c 2.4.3. ==> Enregistrement
 557 c
 558           prfcap(arcnp1(3)) = 1
 559 c
 560 c 2.4.4. ==> Parcours des fonctions
 561 c 2.4.4.1. ==> numero des filles
 562 c           nufilo(i,j) = numero local de la fille de la j-eme arete
 563 c                         pour le calcul de la i-eme valeur
 564           if ( oripei(typdec).gt.0 ) then
 565             jaux = 1
 566           else
 567             jaux = 0
 568           endif
 569 cgn          write (ulsort,90002) '. jaux/arete du pere/fille HOMARD',
 570 cgn     >       jaux,arhnp1(typdec),filare(arhnp1(typdec))+jaux
 571           laretc = narsca(filare(arhnp1(typdec))+jaux)
 572 cgn            write (ulsort,90114) '. champ sur cette arete Cn+1',
 573 cgn     >               laretc, vafott(1,laretc)
 574 c
 575 c 2.4.4.2. ==> Interpolation
 576 c
 577 cgn          write (ulsort,90002) '. arhnp1', arhnp1
 578 cgn          write (ulsort,90002) '. arcn  ', arcn
 579 c
 580           do 2422 , nrofon = 1 , nbfonc
 581 c
 582             if ( etan.eq.0 ) then
 583               champ0(1) = vafoen(nrofon,prfcan(arcn(1)))
 584               champ0(2) = vafoen(nrofon,prfcan(arcn(2)))
 585               champ0(3) = vafoen(nrofon,prfcan(arcn(3)))
 586             elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then
 587 cgn              write (ulsort,*) 'le triangle etait coupe en 2'
 588               champ0(etan) = vafoen(nrofon,prfcan(arcn(3)))
 589      >                     - vafoen(nrofon,prfcan(arcn(4)))
 590               champ0(per1a3(-1,etan)) = vafoen(nrofon,prfcan(arcn(1)))
 591               champ0(per1a3( 1,etan)) = vafoen(nrofon,prfcan(arcn(2)))
 592             elseif ( etan.le.5 ) then
 593 cgn              if ( etan.eq.4 ) then
 594 cgn                write (ulsort,*) 'le triangle etait coupe en 4'
 595 cgn              else
 596 cgn                write (ulsort,*) 'le triangle n''existait pas'
 597 cgn              endif
 598               champ0(typdec) = vafott(nrofon,arcnp1(1))
 599      >                       - vafott(nrofon,arcnp1(2))
 600               champ0(per1a3(-1,typdec)) =
 601      >         vafott(nrofon,narsca(arhnp1(per1a3(-1,typdec))))
 602               champ0(per1a3( 1,typdec)) =
 603      >         vafott(nrofon,narsca(arhnp1(per1a3( 1,typdec))))
 604             endif
 605 cgn            write (ulsort,90004) '. champ0', champ0
 606 c
 607             call utflt0 ( somare, arhnp1,
 608      >                    champ0, flux,
 609      >                    ulsort, langue, codret )
 610             flux = unsde*flux
 611 cgn         write (ulsort,90004) '. flux sur les 2 fils', flux
 612 cgn         write (ulsort,90114) '. champ sur l''arete fille n+1 laretc',
 613 cgn     >               laretc,vafott(nrofon,laretc)
 614 cgn         write (ulsort,90112) '. arcn  ', per1a3(1,typdec),
 615 cgn     >arcn(per1a3(1,typdec)),prfcan(arcn(per1a3(1,typdec)))
 616 cgn         write (ulsort,90114) '. arcn  ', per1a3(1,typdec),
 617 cgn     >oriped(per1a3(1,typdec)),
 618 cgn     >vafoen(nrofon,prfcan(arcn(per1a3(1,typdec))))
 619 c
 620             vafott(nrofon,arcnp1(3)) =
 621      >      ( flux
 622      >      + vafott(nrofon,laretc)
 623      >      - oriped(per1a3(1,typdec))*champ0(per1a3( 1,typdec)) )
 624 cgn          write (ulsort,90004) '. val', vafott(nrofon,arcnp1(3))
 625 c
 626  2422     continue
 627 c
 628         endif
 629 c
 630         endif
 631 c
 632    20 continue
 633 c
 634  2000 continue
 635 c
 636 cgn      write(ulsort,91020)(prfcap(iaux),iaux=1,nbtrto)
 637 cgn      print *,'nbfonc = ',nbfonc
 638 cgn      etan   = 1
 639 cgn      etanp1 = nbarto
 640 cgn      do 30001 , iaux=etan,etanp1
 641 cgn        if ( mod(hetare(iaux),10).eq.0 ) then
 642 cgn          print 11790,
 643 cgn     >    ntrsca(iaux),prfcap(narsca(iaux)),vafott(1,narsca(iaux))
 644 cgn        endif
 645 cgn30001 continue
 646 cgn11790 format(i4,' : ',i2,' / ',g15.7)
 647 c
 648 c====
 649 c 3. la fin
 650 c====
 651 c
 652       if ( codret.ne.0 ) then
 653 c
 654 #include "envex2.h"
 655 c
 656       write (ulsort,texte(langue,1)) 'Sortie', nompro
 657       write (ulsort,texte(langue,2)) codret
 658 c
 659       endif
 660 c
 661 #ifdef _DEBUG_HOMARD_
 662       write (ulsort,texte(langue,1)) 'Sortie', nompro
 663       call dmflsh (iaux)
 664 #endif
 665 c
 666       end