src/tool/AP_Conversion/pcstr0.F

   1       subroutine pcstr0 ( nbfonc, typint, deraff,
   2      >                    prfcan, prfcap,
   3      >                    hettri, anctri,
   4      >                    filtri,
   5      >                    nbantr, anfitr,
   6      >                    ntreca, ntrsca,
   7      >                    vafoen, vafott,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    aPres adaptation - Conversion de Solution -
  30 c     -                 -             -
  31 c                       TRiangles - solution P0
  32 c                       --                    -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  38 c . typint . e   .   1    . type d'interpolation                       .
  39 c .        .     .        .  0, si automatique                         .
  40 c .        .     .        .  elements : 0 si intensif, sans orientation.
  41 c .        .     .        .             1 si extensif, sans orientation.
  42 c .        .     .        .             2 si intensif, avec orientation.
  43 c .        .     .        .             3 si extensif, avec orientation.
  44 c .        .     .        .  noeuds : 1 si degre 1                     .
  45 c .        .     .        .           2 si degre 2                     .
  46 c .        .     .        .           3 si iso-P2                      .
  47 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  48 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  49 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  50 c .        .     .        . 0 : l'entite est absente du profil         .
  51 c .        .     .        . i : l'entite est au rang i dans le profil  .
  52 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  53 c .        .     .        . 0 : l'entite est absente du profil         .
  54 c .        .     .        . 1 : l'entite est presente dans le profil   .
  55 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  56 c . filtri . e   . nbtrto . premier fils des triangles                 .
  57 c . nbantr . e   .   1    . nombre de triangles decoupes par           .
  58 c .        .     .        . conformite sur le maillage avant adaptation.
  59 c . anfitr . e   . nbantr . tableau filtri du maillage de l'iteration n.
  60 c . ntreca . e   .   *    . nro des triangles dans le calcul en entree .
  61 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  62 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  63 c .        .     .    *   .                                            .
  64 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  65 c .        .     .    *   .                                            .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 1 : probleme                               .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'PCSTR0' )
  85 c
  86 #include "nblang.h"
  87 #include "fracta.h"
  88 #include "fractc.h"
  89 c
  90 c 0.2. ==> communs
  91 c
  92 #include "envex1.h"
  93 c
  94 #include "nombtr.h"
  95 #include "nombsr.h"
  96 #include "nomber.h"
  97 #include "demitr.h"
  98 #include "ope1a3.h"
  99 c
 100 c 0.3. ==> arguments
 101 c
 102       integer nbfonc
 103       integer typint
 104       integer prfcan(*), prfcap(*)
 105       integer hettri(nbtrto), anctri(*)
 106       integer filtri(nbtrto)
 107       integer nbantr, anfitr(nbantr)
 108       integer ntreca(retrto), ntrsca(rstrto)
 109 c
 110       double precision vafoen(nbfonc,*)
 111       double precision vafott(nbfonc,*)
 112 c
 113       logical deraff
 114 c
 115       integer ulsort, langue, codret
 116 c
 117 c 0.4. ==> variables locales
 118 c
 119 c     trcn   = TRiangle courant en numerotation Calcul a l'iteration N
 120 c     trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1
 121 c     trhn   = TRiangle courant en numerotation Homard a l'iteration N
 122 c     trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1
 123 c
 124       integer trcn, trcnp1, trhn, trhnp1
 125 c
 126 c     f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1
 127 c     fihp = Fils ieme du triangle en numerotation Homard a l'it. N+1
 128 c     f1cp = Fils 1er du triangle en numerotation Calcul a l'it. N+1
 129 c     f2cp = Fils 2eme du triangle en numerotation Calcul a l'it. N+1
 130 c     f3cp = Fils 3eme du triangle en numerotation Calcul a l'it. N+1
 131 c     f4cp = Fils 4eme du triangle en numerotation Calcul a l'it. N+1
 132 c
 133       integer f1hp, fihp
 134       integer f1cp, f2cp, f3cp, f4cp
 135 c
 136 c     f1hn = Fils 1er du triangle en numerotation Homard a l'it. N
 137 c     f1cn = Fils 1er du triangle en numerotation Calcul a l'it. N
 138 c     f2cn = Fils 2eme du triangle en numerotation Calcul a l'it. N
 139 c     f3cn = Fils 3eme du triangle en numerotation Calcul a l'it. N
 140 c     f4cn = Fils 4eme du triangle en numerotation Calcul a l'it. N
 141 c
 142       integer f1hn
 143       integer f1cn, f2cn, f3cn, f4cn
 144 c
 145 c     f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1
 146 c     f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1
 147 c     f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1
 148 c
 149       integer f1fhp, f1fcp, f2fcp
 150 c
 151 c     etan   = ETAt du triangle a l'iteration N
 152 c     etanp1 = ETAt du triangle a l'iteration N+1
 153 c
 154       integer etan, etanp1
 155 c
 156       integer nrofon
 157       integer iaux
 158 c
 159       double precision daux
 160       double precision daux1
 161 c
 162       integer nbmess
 163       parameter ( nbmess = 10 )
 164       character*80 texte(nblang,nbmess)
 165 c
 166 c 0.5. ==> initialisations
 167 c ______________________________________________________________________
 168 c
 169 c====
 170 c 1. initialisations
 171 c====
 172 c
 173 #include "pcimp0.h"
 174 #include "impr01.h"
 175 #include "impr03.h"
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,texte(langue,1)) 'Entree', nompro
 179       call dmflsh (iaux)
 180       write (ulsort,90002) 'nbfonc', nbfonc
 181       write (ulsort,90002) 'nbtrto', nbtrto
 182       write (ulsort,90002) 'retrto, rstrto', retrto, rstrto
 183 #endif
 184 c
 185       texte(1,4) =
 186      > '(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i8)'
 187       texte(1,5) =
 188      > '(  ''                   etat a l''''iteration '',a3,'' : '',i4)'
 189       texte(1,6) = '(  ''==> Aucune interpolation'')'
 190 c
 191       texte(2,4) =
 192      > '(/,''Current triangle : # at iteration '',a3,'' : '',i8)'
 193       texte(2,5) =
 194      > '(  ''              status at iteration '',a3,'' : '',i4)'
 195       texte(2,6) = '(  ''==> No interpolation'')'
 196 c
 197       codret = 0
 198 cgn      write(ulsort,*) 'ntreca'
 199 cgn      write(ulsort,91020) ntreca
 200 cgn      write(ulsort,*) 'prfcan'
 201 cgn      write(ulsort,91020)(prfcan(iaux),iaux=1,74)
 202 cgn 9999   format(1I5,g14.7,3i10)
 203 c
 204 c====
 205 c 2. on boucle sur tous les triangles du maillage HOMARD n+1
 206 c    on trie en fonction de l'etat du triangle dans le maillage n
 207 c    on numerote les paragraphes en fonction de la documentation, a
 208 c    savoir : le paragraphe doc.n.p traite de la mise a jour de solution
 209 c    pour un triangle dont l'etat est passe de n a p.
 210 c    les autres paragraphes sont numerotes classiquement
 211 c====
 212 c
 213       if ( nbfonc.ne.0 ) then
 214 c
 215       do 20 , trhnp1 = 1 , nbtrto
 216 c
 217 c 2.1. ==> caracteristiques du triangle :
 218 c 2.1.1. ==> son numero homard dans le maillage precedent
 219 c
 220         if ( deraff ) then
 221           trhn = anctri(trhnp1)
 222         else
 223           trhn = trhnp1
 224         endif
 225 c
 226 c 2.1.2. ==> l'historique de son etat
 227 c          On rappelle que l'etat vaut :
 228 c          etan = 0 : le triangle etait actif
 229 c          etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete
 230 c                           1, 2, 3 ; il y a eu deraffinement.
 231 c          etan = 4 : le triangle etait coupe en 4 ; il y a eu
 232 c                     deraffinement.
 233 c          etan = 5 : le triangle n'existait pas ; il a ete produit par
 234 c                     un decoupage.
 235 c          etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule
 236 c                           de l'arete etan-5 pour le suivi de
 237 c                           frontiere ; il y a eu deraffinement.
 238 c          etan = 9 : le triangle etait coupe en 4 et un de ses fils
 239 c                     est inactif
 240 c
 241         etanp1 = mod(hettri(trhnp1),10)
 242         etan   = (hettri(trhnp1)-etanp1) / 10
 243 c
 244 cgn        write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1
 245 c
 246 c=======================================================================
 247 c doc.0.p. ==> etan = 0 : le triangle etait actif
 248 c=======================================================================
 249 c
 250         if ( etan.eq.0 ) then
 251 cgn          print *,'le triangle etait actif'
 252 c
 253 c         on repere son ancien numero dans le calcul
 254 c
 255           trcn = ntreca(trhn)
 256 cgn          write (ulsort,1790) trcn,prfcan(trcn)
 257 cgn 1790 format('Numero du calcul precedent = ',i3,', de profil = ',i3)
 258 c
 259           if ( prfcan(trcn).gt.0 ) then
 260 c
 261 cgn      write (ulsort,90004)'Valeurs anciennes',
 262 cgn     >             (vafoen(nrofon,prfcan(trcn)),nrofon=1,nbfonc)
 263 c
 264 c doc.0.0. ===> etanp1 = 0 : le triangle etait actif et l'est encore ;
 265 c               il est inchange
 266 c             c'est le cas le plus simple : on prend la valeur de la
 267 c             fonction associee a l'ancien numero du triangle.
 268 c                   .                         .
 269 c                  . .                       . .
 270 c                 .   .                     .   .
 271 c                .     .                   .     .
 272 c               .       .      ===>       .       .
 273 c              .         .               .         .
 274 c             .           .             .           .
 275 c            .             .           .             .
 276 c           .................         .................
 277 c
 278           if ( etanp1.eq.0 ) then
 279 c
 280             trcnp1 = ntrsca(trhnp1)
 281             prfcap(trcnp1) = 1
 282 c
 283             do 221 , nrofon = 1 , nbfonc
 284               vafott(nrofon,trcnp1) = vafoen(nrofon,prfcan(trcn))
 285 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(trcn))
 286   221       continue
 287 cgn        write(21,9999) trcnp1,vafott(15,trcnp1),0,trcn,prfcan(trcn)
 288 cgn        write(ulsort,91020) trcn,-1,trcnp1
 289 c
 290 c doc.0.1/2/3 ==> etanp1 = 1, 2 ou 3 : le triangle etait actif et est
 291 c                 decoupe en 2.
 292 c                 les deux fils prennent la valeur de la fonction sur
 293 c                 le pere
 294 c                   .                         .
 295 c                  . .                       ...
 296 c                 .   .                     . . .
 297 c                .     .                   .  .  .
 298 c               .       .      ===>       .   .   .
 299 c              .         .               .    .    .
 300 c             .           .             .     .     .
 301 c            .             .           .      .      .
 302 c           .................         .................
 303 c
 304           elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then
 305 c
 306             f1hp = filtri(trhnp1)
 307             f1cp = ntrsca(f1hp)
 308             f2cp = ntrsca(f1hp+1)
 309             prfcap(f1cp) = 1
 310             prfcap(f2cp) = 1
 311             if ( typint.eq.0 ) then
 312               do 2220 , nrofon = 1 , nbfonc
 313                 daux = vafoen(nrofon,prfcan(trcn))
 314                 vafott(nrofon,f1cp) = daux
 315                 vafott(nrofon,f2cp) = daux
 316 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(trcn))
 317  2220         continue
 318             else
 319               do 2221 , nrofon = 1 , nbfonc
 320                 daux = unsde*vafoen(nrofon,prfcan(trcn))
 321                 vafott(nrofon,f1cp) = daux
 322                 vafott(nrofon,f2cp) = daux
 323 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(trcn))
 324  2221         continue
 325             endif
 326 cgn        write(22,9999) f1cp,vafott(15,f1cp),2,trcn,prfcan(trcn)
 327 cgn        write(22,9999) f2cp,vafott(15,f1cp),2,trcn,prfcan(trcn)
 328 cgn        write(22,91020) f1cp,f2cp
 329 cgn        write(ulsort,91020) trcn,-1,
 330 cgn     >                     f1cp,f2cp
 331 c
 332 c doc.0.4/6/7/8. ==> etanp1 = 4, 6, 7 ou 8 : le triangle etait actif et
 333 c                    est decoupe en 4.
 334 c                    les quatre fils prennent la valeur de la fonction
 335 c                    sur le pere
 336 c                   .                         .
 337 c                  . .                       . .
 338 c                 .   .                     .   .
 339 c                .     .                   .     .
 340 c               .       .      ===>       .........
 341 c              .         .               . .     . .
 342 c             .           .             .   .   .   .
 343 c            .             .           .     . .     .
 344 c           .................         .................
 345 c
 346 c
 347           elseif ( etanp1.eq.4 .or.
 348      >             etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then
 349 c
 350             f1hp = filtri(trhnp1)
 351             f1cp = ntrsca(f1hp)
 352             f2cp = ntrsca(f1hp+1)
 353             f3cp = ntrsca(f1hp+2)
 354             f4cp = ntrsca(f1hp+3)
 355             prfcap(f1cp) = 1
 356             prfcap(f2cp) = 1
 357             prfcap(f3cp) = 1
 358             prfcap(f4cp) = 1
 359             if ( typint.eq.0 ) then
 360               do 2230 , nrofon = 1 , nbfonc
 361                 daux = vafoen(nrofon,prfcan(trcn))
 362                 vafott(nrofon,f1cp) = daux
 363                 vafott(nrofon,f2cp) = daux
 364                 vafott(nrofon,f3cp) = daux
 365                 vafott(nrofon,f4cp) = daux
 366 cgn              write(ulsort,92010) daux
 367  2230         continue
 368             else
 369               do 2231 , nrofon = 1 , nbfonc
 370                 daux = unsqu*vafoen(nrofon,prfcan(trcn))
 371                 vafott(nrofon,f1cp) = daux
 372                 vafott(nrofon,f2cp) = daux
 373                 vafott(nrofon,f3cp) = daux
 374                 vafott(nrofon,f4cp) = daux
 375 cgn              write(ulsort,92010) daux
 376  2231         continue
 377             endif
 378 cgn        write(23,9999) f1cp,vafott(15,f1cp),4,trcn,prfcan(trcn)
 379 cgn        write(23,9999) f2cp,vafott(15,f1cp),4,trcn,prfcan(trcn)
 380 cgn        write(23,9999) f3cp,vafott(15,f1cp),4,trcn,prfcan(trcn)
 381 cgn        write(23,9999) f4cp,vafott(15,f1cp),4,trcn,prfcan(trcn)
 382 cgn        write(23,91020) f1cp,f2cp,f3cp,f4cp
 383 cgn        write(ulsort,91020) trcn,-1,
 384 cgn     >                     f1cp,f2cp,f3cp,f4cp
 385 c
 386 c doc.0.erreur. ==> aucun autre etat sur le triangle courant n'est
 387 c                   possible
 388 c
 389           else
 390 c
 391             codret = codret + 1
 392             write (ulsort,texte(langue,4)) 'n  ', trhn
 393             write (ulsort,texte(langue,5)) 'n  ', etan
 394             write (ulsort,texte(langue,4)) 'n+1', trhnp1
 395             write (ulsort,texte(langue,5)) 'n+1', etanp1
 396 c
 397           endif
 398 c
 399           endif
 400 c
 401 c=======================================================================
 402 c doc.1/2/3.p. ==> etan = 1, 2 ou 3 : le triangle etait coupe en 2
 403 c=======================================================================
 404 c
 405         elseif ( etan.ge.1 .and. etan.le.3 ) then
 406 c
 407 cgn          print *,'le triangle etait coupe en 2'
 408 c         on repere les numeros dans le calcul pour ses deux fils a
 409 c         l'iteration n
 410 c
 411           f1hn = anfitr(trhn)
 412           f1cn = ntreca(f1hn)
 413           f2cn = ntreca(f1hn+1)
 414 c
 415           if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then
 416 c
 417 c doc.1/2/3.0. ===> etanp1 = 0 : le triangle est actif. il est reactive.
 418 c                   on lui attribue la valeur moyenne sur les deux
 419 c                   anciens fils.
 420 c        remarque : cela arrive seulement avec du deraffinement.
 421 c                   .                         .
 422 c                  ...                       . .
 423 c                 . . .                     .   .
 424 c                .  .  .                   .     .
 425 c               .   .   .      ===>       .       .
 426 c              .    .    .               .         .
 427 c             .     .     .             .           .
 428 c            .      .      .           .             .
 429 c           .................         .................
 430 c
 431           if ( etanp1.eq.0 ) then
 432 c
 433             trcnp1 = ntrsca(trhnp1)
 434             prfcap(trcnp1) = 1
 435 c
 436             if ( typint.eq.0 ) then
 437               do 2310 , nrofon = 1 , nbfonc
 438                 vafott(nrofon,trcnp1) =
 439      >                       unsde * ( vafoen(nrofon,prfcan(f1cn))
 440      >                               + vafoen(nrofon,prfcan(f2cn)) )
 441 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 442 cgn     >                           vafoen(nrofon,prfcan(f2cn))
 443  2310         continue
 444             else
 445               do 2311 , nrofon = 1 , nbfonc
 446                 vafott(nrofon,trcnp1) =
 447      >                                 vafoen(nrofon,prfcan(f1cn))
 448      >                               + vafoen(nrofon,prfcan(f2cn))
 449 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 450 cgn     >                           vafoen(nrofon,prfcan(f2cn))
 451  2311         continue
 452             endif
 453 cgn        write(31,91020) trcnp1
 454 cgn        write(ulsort,91020) f1cn,f2cn,-1,trcnp1
 455 c
 456 c doc.1/2/3.1/2/3. ===> etanp1 = etan : le triangle est decoupe en deux
 457 c                       selon le meme decoupage.
 458 c             c'est ce qui se passe quand un decoupage de conformite
 459 c             est supprime au debut des algorithmes d'adaptation,
 460 c             puis reproduit a la creation du maillage car les
 461 c             triangles autour n'ont pas change entre les deux
 462 c             iterations.
 463 c             le fils prend la valeur de la fonction sur l'ancien
 464 c             fils qui etait au meme endroit. comme la procedure de
 465 c             numerotation est la meme (voir cmcdtr), le premier fils
 466 c             est toujours le meme, le second egalement. on prendra
 467 c             alors la valeur sur le fils de rang identique a
 468 c             l'iteration n.
 469 c                   .                         .
 470 c                  ...                       ...
 471 c                 . . .                     . . .
 472 c                .  .  .                   .  .  .
 473 c               .   .   .      ===>       .   .   .
 474 c              .    .    .               .    .    .
 475 c             .     .     .             .     .     .
 476 c            .      .      .           .      .      .
 477 c           .................         .................
 478 c
 479           elseif ( etanp1.eq.etan ) then
 480 c
 481             f1hp = filtri(trhnp1)
 482             f1cp = ntrsca(f1hp)
 483             f2cp = ntrsca(f1hp+1)
 484             prfcap(f1cp) = 1
 485             prfcap(f2cp) = 1
 486             do 232 , nrofon = 1 , nbfonc
 487               vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn))
 488               vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn))
 489 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 490 cgn     >                           vafoen(nrofon,prfcan(f2cn))
 491   232       continue
 492 cgn        write(32,91020) f1cp,f2cp
 493 cgn        write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp
 494 c
 495 c doc.1/2/3.perm(1/2/3). ===> etanp1 = 1, 2 ou 3 et different de etan :
 496 c                             le triangle est encore decoupe en deux
 497 c                             mais par un autre decoupage.
 498 c             c'est ce qui se passe quand un decoupage de conformite
 499 c             est supprime au debut des algorithmes d'adaptation. il y
 500 c             a du deraffinement dans la zone qui induisait le decoupage
 501 c             de conformite et raffinement sur une autre zone.
 502 c             on donne la valeur moyenne de la fonction sur les deux
 503 c             anciens fils a chaque nouveau fils.
 504 c             remarque : on pourrait certainement faire mieux, avec des
 505 c                        moyennes ponderees en fonction du recouvrement
 506 c                        des anciens et nouveaux fils. c'est trop
 507 c                        complique pour que cela vaille le coup.
 508 c             remarque : cela arrive seulement avec du deraffinement.
 509 c                   .                         .
 510 c                  ...                       . .
 511 c                 . . .                     .   .
 512 c                .  .  .                   .     .
 513 c               .   .   .      ===>       .       .
 514 c              .    .    .               .  .      .
 515 c             .     .     .             .      .    .
 516 c            .      .      .           .          .  .
 517 c           .................         .................
 518 c
 519           elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then
 520 c
 521             f1hp = filtri(trhnp1)
 522             f1cp = ntrsca(f1hp)
 523             f2cp = ntrsca(f1hp+1)
 524             prfcap(f1cp) = 1
 525             prfcap(f2cp) = 1
 526             do 233 , nrofon = 1 , nbfonc
 527               daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 528      >                       + vafoen(nrofon,prfcan(f2cn)) )
 529               vafott(nrofon,f1cp) = daux
 530               vafott(nrofon,f2cp) = daux
 531 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 532 cgn     >                           vafoen(nrofon,prfcan(f2cn))
 533   233       continue
 534 cgn        write(33,91020) f1cp,f2cp
 535 cgn        write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp
 536 c
 537 c doc.1/2/3.4/6/7/8. ===> etanp1 = 4, 6, 7 ou 8 : le triangle est
 538 c                         decoupe en quatre.
 539 c             c'est ce qui se passe quand un decoupage de conformite
 540 c             est supprime au debut des algorithmes d'adaptation. il y
 541 c             a ensuite raffinement du triangle. qui plus est, par suite
 542 c             de la regle des ecarts de niveau, on peut avoir induit
 543 c             un decoupage de conformite sur l'un des fils.
 544 c             remarque : c'est toujours un des fils du cote qui etait
 545 c             decoupe qui subit le decoupage, et c'est toujours par
 546 c             une subdivision du dit cote.
 547 c
 548 c             . pour le triangle central et le triangle dans le coin
 549 c             oppose a l'arete initialement decoupee, on attribue la
 550 c             valeur moyenne de la fonction sur les deux anciens fils.
 551 c             . pour les deux autres triangles, on repere dans lequel
 552 c             des deux fils ils se trouvent. si un de ces triangles est
 553 c             decoupe, c'est en 2 et par la meme arete que le triangle
 554 c             courant ; on affecte la valeur du fils du maillage n
 555 c             a ces deux fils. si un des triangles est actif, on lui
 556 c             attribue la valeur.
 557 c
 558 c             . on pose i, j et k comme etant les numeros locaux des
 559 c             aretes du triangle courant.
 560 c             si etan vaut i, c'est que la i-eme arete du triangle
 561 c             etait coupee. les numerotations des 2 fils sont obtenues
 562 c             par la fonction nutrde : a = nutrde(i,j), b = nutrde(i,k)
 563 c             les numerotations des 4 fils sont +0, +i, +j et +k.
 564 c             on voit donc que :
 565 c              . les fils +O et +i doivent recevoir la moyenne
 566 c              . le fils +k, ou ses fils, doit recevoir la valeur
 567 c                de +nutrde(i,j)
 568 c              . le fils +j, ou ses fils, doit recevoir la valeur
 569 c                de +nutrde(i,k)
 570 c
 571 c                   .                         .
 572 c                  ...                       . .
 573 c                 . . .                     .   .
 574 c                .  .  .                   . +i  .
 575 c             j .   .   . k    ===>     j ......... k
 576 c              .    .    .               . .     . .
 577 c             . +a  . +b  .             .   .+0 .   .
 578 c            .      .      .           . +k  . . +j  .
 579 c           .................         .................
 580 c                   i                        i
 581 c
 582 c                   .                         .
 583 c                  ...                       . .
 584 c                 . . .                     .   .
 585 c                .  .  .                   . +i  .
 586 c             j .   .   . k    ===>     j ......... k
 587 c              .    .    .               . .     ...
 588 c             . +a  . +b  .             .   .+0 . . .
 589 c            .      .      .           . +k  . .+j.+j.
 590 c           .................         .................
 591 c                   i                        i
 592 c
 593 c                   .                         .
 594 c                  ...                       . .
 595 c                 . . .                     .   .
 596 c                .  .  .                   . +i  .
 597 c             j .   .   . k    ===>     j ......... k
 598 c              .    .    .               ...     ...
 599 c             . +a  . +b  .             . . .+0 . . .
 600 c            .      .      .           .+k.+k. .+j.+j.
 601 c           .................         .................
 602 c                   i                        i
 603 c
 604 c
 605           elseif ( etanp1.eq.4 .or.
 606      >             etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then
 607 c
 608 c           ==> les deux triangles central et opposee
 609 c
 610             f1hp = filtri(trhnp1)
 611             f1cp = ntrsca(f1hp)
 612             f2cp = ntrsca(f1hp+etan)
 613             prfcap(f1cp) = 1
 614             prfcap(f2cp) = 1
 615             if ( typint.eq.0 ) then
 616               daux1 = unsde
 617             else
 618               daux1 = unsqu
 619             endif
 620             do 2341 , nrofon = 1 , nbfonc
 621               daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 622      >                       + vafoen(nrofon,prfcan(f2cn)) )
 623               vafott(nrofon,f1cp) = daux
 624               vafott(nrofon,f2cp) = daux
 625 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 626 cgn     >                           vafoen(nrofon,prfcan(f2cn))
 627  2341       continue
 628 cgn        write(34,91020) f1cp,f2cp
 629 cgn        write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp
 630 c
 631 c           ==> le triangle d'un des cotes
 632 c
 633             iaux = prfcan(ntreca(f1hn+nutrde(etan,per1a3( 1,etan))))
 634             fihp = f1hp+per1a3(-1,etan)
 635             if ( mod(hettri(fihp),10).eq.0 ) then
 636               f3cp = ntrsca(fihp)
 637               prfcap(f3cp) = 1
 638               if ( typint.eq.0 ) then
 639                 do 23420 , nrofon = 1 , nbfonc
 640                   vafott(nrofon,f3cp) = vafoen(nrofon,iaux)
 641 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 642 23420           continue
 643               else
 644                 do 23421 , nrofon = 1 , nbfonc
 645                   vafott(nrofon,f3cp) = unsde * vafoen(nrofon,iaux)
 646 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 647 23421           continue
 648               endif
 649 cgn        write(35,91020) f3cp
 650 cgn        write(ulsort,91020) f1hn+nutrde(etan,per1a3( 1,etan)),-1,f3cp
 651             elseif ( mod(hettri(fihp),10).eq.etan ) then
 652               f1fhp = filtri(fihp)
 653               f1fcp = ntrsca(f1fhp)
 654               f2fcp = ntrsca(f1fhp+1)
 655               prfcap(f1fcp) = 1
 656               prfcap(f2fcp) = 1
 657               if ( typint.eq.0 ) then
 658                 do 23430 , nrofon = 1 , nbfonc
 659                   vafott(nrofon,f1fcp) = vafoen(nrofon,iaux)
 660                   vafott(nrofon,f2fcp) = vafoen(nrofon,iaux)
 661 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 662 23430           continue
 663               else
 664                 do 23431 , nrofon = 1 , nbfonc
 665                   vafott(nrofon,f1fcp) = unsqu * vafoen(nrofon,iaux)
 666                   vafott(nrofon,f2fcp) = unsqu * vafoen(nrofon,iaux)
 667 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 668 23431           continue
 669               endif
 670 cgn        write(36,91020) f1fcp,f2fcp
 671 cgn        write(ulsort,91020) f1hn+nutrde(etan,per1a3( 1,etan)),-1,
 672 cgn     >                     f1fcp,f2fcp
 673             else
 674               codret = codret + 1
 675               write (ulsort,texte(langue,4)) 'n+1', fihp
 676               write (ulsort,texte(langue,5)) 'n+1', hettri(fihp)
 677             endif
 678 c
 679 c           ==> le triangle de l'autre cote
 680 c
 681             iaux = prfcan(ntreca(f1hn+nutrde(etan,per1a3(-1,etan))))
 682             fihp = f1hp+per1a3( 1,etan)
 683             if ( mod(hettri(fihp),10).eq.0 ) then
 684               f3cp = ntrsca(fihp)
 685               prfcap(f3cp) = 1
 686               if ( typint.eq.0 ) then
 687                 do 23440 , nrofon = 1 , nbfonc
 688                   vafott(nrofon,f3cp) = vafoen(nrofon,iaux)
 689 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 690 23440           continue
 691               else
 692                 do 23441 , nrofon = 1 , nbfonc
 693                   vafott(nrofon,f3cp) = unsde * vafoen(nrofon,iaux)
 694 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 695 23441           continue
 696               endif
 697 cgn        write(37,91020) f3cp
 698 cgn        write(ulsort,91020) f1hn+nutrde(etan,per1a3(-1,etan)),-1,f3cp
 699             elseif ( mod(hettri(fihp),10).eq.etan ) then
 700               f1fhp = filtri(fihp)
 701               f1fcp = ntrsca(f1fhp)
 702               f2fcp = ntrsca(f1fhp+1)
 703               prfcap(f1fcp) = 1
 704               prfcap(f2fcp) = 1
 705               if ( typint.eq.0 ) then
 706                 do 23450 , nrofon = 1 , nbfonc
 707                   vafott(nrofon,f1fcp) = vafoen(nrofon,iaux)
 708                   vafott(nrofon,f2fcp) = vafoen(nrofon,iaux)
 709 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 710 23450           continue
 711               else
 712                 do 23451 , nrofon = 1 , nbfonc
 713                   vafott(nrofon,f1fcp) = unsqu * vafoen(nrofon,iaux)
 714                   vafott(nrofon,f2fcp) = unsqu * vafoen(nrofon,iaux)
 715 cgn                write(ulsort,92010) vafoen(nrofon,iaux)
 716 23451           continue
 717               endif
 718 cgn        write(38,91020) f1fcp,f2fcp
 719 cgn        write(ulsort,91020) f1hn+nutrde(etan,per1a3(-1,etan)),-1,
 720 cgn     >                     f1fcp,f2fcp
 721             else
 722               codret = codret + 1
 723               write (ulsort,texte(langue,4)) 'n+1', fihp
 724               write (ulsort,texte(langue,5)) 'n+1', hettri(fihp)
 725             endif
 726 c
 727 c doc.1/2/3.erreur. ==> aucun autre etat sur le triangle courant
 728 c                       n'est possible
 729 c
 730           else
 731 c
 732             codret = codret + 1
 733             write (ulsort,texte(langue,4)) 'n  ', trhn
 734             write (ulsort,texte(langue,5)) 'n  ', etan
 735             write (ulsort,texte(langue,4)) 'n+1', trhnp1
 736             write (ulsort,texte(langue,5)) 'n+1', etanp1
 737 c
 738           endif
 739 c
 740           endif
 741 c
 742 c=======================================================================
 743 c doc.4. ==> le triangle etait coupe en 4 :
 744 c=======================================================================
 745 c
 746         elseif ( etan.eq.4 .or.
 747      >           etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then
 748 c
 749 cgn          print *,'le triangle etait coupe en 4'
 750 c         on repere les numeros dans le calcul pour ses quatre fils
 751 c         a l'iteration n
 752 c
 753           f1hn = anfitr(trhn)
 754           f1cn = ntreca(f1hn)
 755           f2cn = ntreca(f1hn+1)
 756           f3cn = ntreca(f1hn+2)
 757           f4cn = ntreca(f1hn+3)
 758 cgn          print *,'Les 4 fils :'
 759 cgn          print 1790,f1cn,prfcan(f1cn)
 760 cgn          print 1790,f2cn,prfcan(f2cn)
 761 cgn          print 1790,f3cn,prfcan(f3cn)
 762 cgn          print 1790,f4cn,prfcan(f4cn)
 763 c
 764           if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and.
 765      >         prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then
 766 c
 767 c doc.4.0. ===> etanp1 = 0 : le triangle est actif ; il est reactive.
 768 c             on lui attribue la valeur moyenne sur les quatre anciens
 769 c             fils.
 770 c             remarque : cela arrive seulement avec du deraffinement.
 771 c                   .                         .
 772 c                  . .                       . .
 773 c                 .   .                     .   .
 774 c                .     .                   .     .
 775 c               .........      ===>       .       .
 776 c              . .     . .               .         .
 777 c             .   .   .   .             .           .
 778 c            .     . .     .           .             .
 779 c           .................         .................
 780 c
 781           if ( etanp1.eq.0 ) then
 782 c
 783             trcnp1 = ntrsca(trhnp1)
 784             prfcap(trcnp1) = 1
 785 c
 786             do 241 , nrofon = 1 , nbfonc
 787               vafott(nrofon,trcnp1) =
 788      >               unsqu * ( vafoen(nrofon,prfcan(f1cn))
 789      >                       + vafoen(nrofon,prfcan(f2cn))
 790      >                       + vafoen(nrofon,prfcan(f3cn))
 791      >                       + vafoen(nrofon,prfcan(f4cn)) )
 792 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 793 cgn     >                           vafoen(nrofon,prfcan(f2cn)),
 794 cgn     >                           vafoen(nrofon,prfcan(f3cn)),
 795 cgn     >                           vafoen(nrofon,prfcan(f4cn))
 796   241       continue
 797 cgn        write (41,91020) trcnp1
 798 cgn        write (ulsort,91020) f1cn,f2cn,f3cn,f4cn,-1,trcnp1
 799 c
 800 c doc.4.1/2/3. ===> etanp1 = 1, 2 ou 3 : le triangle est decoupe en
 801 c             deux.
 802 c             on attribue la valeur moyenne sur les quatre anciens
 803 c             fils a chacune des deux nouveaux fils.
 804 c             remarque : on pourrait certainement faire mieux, avec des
 805 c                        moyennes ponderees en fonction du recouvrement
 806 c                        des anciens et nouveaux fils. c'est trop
 807 c                        complique pour que cela vaille le coup.
 808 c             remarque : cela arrive seulement avec du deraffinement.
 809 c                   .                         .
 810 c                  . .                       ...
 811 c                 .   .                     . . .
 812 c                .     .                   .  .  .
 813 c               .........      ===>       .   .   .
 814 c              . .     . .               .    .    .
 815 c             .   .   .   .             .     .     .
 816 c            .     . .     .           .      .      .
 817 c           .................         .................
 818 c
 819           elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then
 820 c
 821             f1hp = filtri(trhnp1)
 822             f1cp = ntrsca(f1hp)
 823             f2cp = ntrsca(f1hp+1)
 824 cgn            print *,f1hp,f1cp,f2cp
 825             prfcap(f1cp) = 1
 826             prfcap(f2cp) = 1
 827             do 242 , nrofon = 1 , nbfonc
 828               daux = unsqu * ( vafoen(nrofon,prfcan(f1cn))
 829      >                       + vafoen(nrofon,prfcan(f2cn))
 830      >                       + vafoen(nrofon,prfcan(f3cn))
 831      >                       + vafoen(nrofon,prfcan(f4cn)) )
 832               vafott(nrofon,f1cp) = daux
 833               vafott(nrofon,f2cp) = daux
 834 cgn              write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)),
 835 cgn     >                           vafoen(nrofon,prfcan(f2cn)),
 836 cgn     >                           vafoen(nrofon,prfcan(f3cn)),
 837 cgn     >                           vafoen(nrofon,prfcan(f4cn))
 838   242       continue
 839 cgn        write(42,91020) f1cp,f2cp
 840 cgn        write(ulsort,91020) f1cn,f2cn,f3cn,f4cn,-1,
 841 cgn     >                     f1cp,f2cp
 842 c
 843           endif
 844 c
 845           endif
 846 c
 847 #ifdef _DEBUG_HOMARD_
 848 c
 849 c=======================================================================
 850 c doc.4. ==> le triangle n'existait pas
 851 c=======================================================================
 852 c
 853         else
 854 c
 855 cgn          print *,'le triangle n''existait pas'
 856           write (ulsort,texte(langue,6))
 857 c
 858 #endif
 859 c
 860 c=======================================================================
 861 c
 862         endif
 863 c
 864    20 continue
 865 c
 866       endif
 867 c
 868 cgn      write(ulsort,91020)(prfcap(iaux),iaux=1,nbtrto)
 869 cgn      print *,'nbfonc = ',nbfonc
 870 cgn      etan   = 1
 871 cgn      etanp1 = nbtrto
 872 cgn      do 30001 , iaux=etan,etanp1
 873 cgn        if ( mod(hettri(iaux),10).eq.0 ) then
 874 cgn          print 11790,
 875 cgn     >    ntrsca(iaux),prfcap(ntrsca(iaux)),vafott(1,ntrsca(iaux))
 876 cgn        endif
 877 cgn30001 continue
 878 cgn11790 format(i4,' : ',i2,' / ',g15.7)
 879 c
 880 c====
 881 c 3. la fin
 882 c====
 883 c
 884       if ( codret.ne.0 ) then
 885 c
 886 #include "envex2.h"
 887 c
 888       write (ulsort,texte(langue,1)) 'Sortie', nompro
 889       write (ulsort,texte(langue,2)) codret
 890 c
 891       endif
 892 c
 893 #ifdef _DEBUG_HOMARD_
 894       write (ulsort,texte(langue,1)) 'Sortie', nompro
 895       call dmflsh (iaux)
 896 #endif
 897 c
 898       end