src/tool/AP_Conversion/pcseq2.F

   1       subroutine pcseq2 ( etan, etanp1, quhn, quhnp1, typint,
   2      >                            prfcap,
   3      >                    coonoe,
   4      >                    somare,
   5      >                    arequa, hetqua, filqua,
   6      >                    nbanqu, anfiqu,
   7      >                            nqusca,
   8      >                    aretri,
   9      >                    ntreca, ntrsca,
  10      >                    nbfonc,         vafott,
  11      >                    vatren, vatrtt,
  12      >                    prftrn, prftrp,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c    aPres adaptation - Conversion de Solution Elements de volume -
  35 c     -                 -             -        -
  36 c                       Quadrangles d'etat anterieur 31, 32, 33, 34
  37 c                       -
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . etan   . e   .    1   . ETAt du quadrangle a l'iteration N         .
  43 c . etanp1 . e   .    1   . ETAt du quadrangle a l'iteration N+1       .
  44 c . quhn   . e   .    1   . Quadrangle courant en numerotation Homard  .
  45 c .        .     .        . a l'iteration N                            .
  46 c . quhnp1 . e   .    1   . Quadrangle courant en numerotation Homard  .
  47 c .        .     .        . a l'iteration N+1                          .
  48 c . typint . e   .   1    . type d'interpolation                       .
  49 c .        .     .        .  0, si automatique                         .
  50 c .        .     .        .  elements : 0 si intensif, sans orientation.
  51 c .        .     .        .             1 si extensif, sans orientation.
  52 c .        .     .        .             2 si intensif, avec orientation.
  53 c .        .     .        .             3 si extensif, avec orientation.
  54 c .        .     .        .  noeuds : 1 si degre 1                     .
  55 c .        .     .        .           2 si degre 2                     .
  56 c .        .     .        .           3 si iso-P2                      .
  57 c . typint . e   .   1    . type d'interpolation                       .
  58 c .        .     .        .  0, si automatique                         .
  59 c .        .     .        .  elements : 0 si intensif, sans orientation.
  60 c .        .     .        .             1 si extensif, sans orientation.
  61 c .        .     .        .             2 si intensif, avec orientation.
  62 c .        .     .        .             3 si extensif, avec orientation.
  63 c .        .     .        .  noeuds : 1 si degre 1                     .
  64 c .        .     .        .           2 si degre 2                     .
  65 c .        .     .        .           3 si iso-P2                      .
  66 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  67 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  68 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  69 c .        .     .        . 0 : l'entite est absente du profil         .
  70 c .        .     .        . 1 : l'entite est presente dans le profil   .
  71 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  72 c .        .     . * sdim .                                            .
  73 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  74 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  75 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  76 c . filqua . e   . nbquto . premier fils des quadrangles               .
  77 c . nbanqu . e   .   1    . nombre de quadrangles decoupes par         .
  78 c .        .     .        . conformite sur le maillage avant adaptation.
  79 c . anfiqu . e   . nbanqu . tableau filqua du maillage de l'iteration n.
  80 c . nqusca . e   . rsquto . numero des quadrangles du calcul           .
  81 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  82 c . ntreca . e   .   *    . nro des triangles dans le calcul en entree .
  83 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  84 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  85 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  86 c .        .     .    *   .                                            .
  87 c . vatren . e   . nbfonc*. variables en entree de l'adaptation        .
  88 c .        .     .    *   .                                            .
  89 c . vatrtt .   a . nbfonc*. tableau temporaire de la solution pour     .
  90 c .        .     .    *   . les triangles de conformite                .
  91 c . prftrn . es  .   *    . En numero du calcul a l'iteration n   :    .
  92 c .        .     .        . 0 : le triangle est absent du profil       .
  93 c .        .     .        . 1 : le triangle est present dans le profil .
  94 c . prftrp . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  95 c .        .     .        . 0 : le triangle est absent du profil       .
  96 c .        .     .        . 1 : le triangle est present dans le profil .
  97 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  98 c . langue . e   .    1   . langue des messages                        .
  99 c .        .     .        . 1 : francais, 2 : anglais                  .
 100 c . codret . es  .    1   . code de retour des modules                 .
 101 c .        .     .        . 0 : pas de probleme                        .
 102 c .        .     .        . 1 : probleme                               .
 103 c ______________________________________________________________________
 104 c
 105 c====
 106 c 0. declarations et dimensionnement
 107 c====
 108 c
 109 c 0.1. ==> generalites
 110 c
 111       implicit none
 112       save
 113 c
 114       character*6 nompro
 115       parameter ( nompro = 'PCSEQ2' )
 116 c
 117 #include "nblang.h"
 118 #include "fractb.h"
 119 c
 120 c 0.2. ==> communs
 121 c
 122 #include "envca1.h"
 123 #include "nombno.h"
 124 #include "nombar.h"
 125 #include "nombtr.h"
 126 #include "nombqu.h"
 127 #include "nombsr.h"
 128 #include "nomber.h"
 129 c
 130 c 0.3. ==> arguments
 131 c
 132       integer etan, etanp1, quhn, quhnp1
 133       integer typint
 134       integer nbfonc
 135       integer prfcap(*)
 136       integer somare(2,nbarto)
 137       integer arequa(nbquto,4), hetqua(nbquto)
 138       integer filqua(nbquto)
 139       integer nbanqu, anfiqu(nbanqu)
 140       integer nqusca(rsquto)
 141       integer aretri(nbtrto,3)
 142       integer ntreca(retrto), ntrsca(rstrto)
 143       integer prftrn(*), prftrp(*)
 144 c
 145       double precision coonoe(nbnoto,sdim)
 146       double precision vafott(nbfonc,*)
 147       double precision vatren(nbfonc,*)
 148       double precision vatrtt(nbfonc,*)
 149 c
 150       integer ulsort, langue, codret
 151 c
 152 c 0.4. ==> variables locales
 153 c
 154 c     qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1
 155 c
 156       integer qucnp1
 157 c
 158 c     f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1
 159 c     fihp = Fils ieme du quadrangle en numerotation Homard a l'it. N+1
 160 c     ficp = Fils ieme du quadrangle en numerotation Calcul a l'it. N+1
 161 c     f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1
 162 c     f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1
 163 c     f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1
 164 c
 165       integer f1hp, fihp, ficp
 166       integer f1cp, f2cp, f3cp
 167 c
 168 c     f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N
 169 c     f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N
 170 c     f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N
 171 c     f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N
 172 c
 173       integer f1hn
 174       integer f1cn, f2cn, f3cn
 175 c
 176 c     f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1
 177 c     f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1
 178 c     f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1
 179 c     f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1
 180 c
 181       integer f1fhp, f1fcp, f2fcp, f3fcp
 182 c
 183       integer coderr
 184       integer nrofon
 185       integer iaux
 186 c
 187       double precision daux
 188       double precision daux0, daux1, daux2, daux3
 189 c
 190       integer nbmess
 191       parameter ( nbmess = 10 )
 192       character*80 texte(nblang,nbmess)
 193 c
 194 c 0.5. ==> initialisations
 195 c ______________________________________________________________________
 196 c
 197 c====
 198 c 1. initialisations
 199 c====
 200 c
 201 #include "pcimp0.h"
 202 #include "impr01.h"
 203 #include "impr03.h"
 204 c
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,texte(langue,1)) 'Entree', nompro
 207       call dmflsh (iaux)
 208 #endif
 209 c
 210       texte(1,4) =
 211      >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)'
 212       texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)'
 213 c
 214       texte(2,4) =
 215      >'(''Current quadrangle : # at iteration '',a3,''     : '',i10)'
 216       texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)'
 217 c
 218       coderr = 0
 219 c
 220 c 1.2. ==> on repere les numeros dans le calcul pour les fils
 221 c          a l'iteration n
 222 c
 223       f1hn = -anfiqu(quhn)
 224       f1cn = ntreca(f1hn)
 225       f2cn = ntreca(f1hn+1)
 226       f3cn = ntreca(f1hn+2)
 227 c
 228       if ( prftrn(f1cn).gt.0 .and. prftrn(f2cn).gt.0 .and.
 229      >     prftrn(f3cn).gt.0 ) then
 230 c
 231 c====
 232 c 2. le quadrangle etait coupe en 3 triangles
 233 c====
 234 c 2.1. ==> etanp1 = 0 : le quadrangle est actif. il est
 235 c                   reactive.
 236 c                   on lui attribue la valeur moyenne sur les trois
 237 c                   anciens fils.
 238 c        remarque : cela arrive seulement avec du deraffinement.
 239 c           .................         .................
 240 c           .      . .      .         .               .
 241 c           .     .   .     .         .               .
 242 c           .    .     .    .         .               .
 243 c           .   .       .   .  ===>   .               .
 244 c           .  .         .  .         .               .
 245 c           . .           . .         .               .
 246 c           ..             ..         .               .
 247 c           .................         .................
 248 c
 249       if ( etanp1.eq.0 ) then
 250 cgn      write(ulsort,*)'... quadrangle reactive'
 251 c
 252         qucnp1 = nqusca(quhnp1)
 253         prfcap(qucnp1) = 1
 254 c
 255         if ( typint.eq.0 ) then
 256           daux1 = unstr
 257         else
 258           daux1 = 1.d0
 259         endif
 260         do 21 , nrofon = 1 , nbfonc
 261           daux = daux1 * ( vatren(nrofon,prftrn(f1cn))
 262      >                   + vatren(nrofon,prftrn(f2cn))
 263      >                   + vatren(nrofon,prftrn(f3cn)) )
 264 cgn            write(ulsort,90004) 'daux', daux
 265           vafott(nrofon,qucnp1) = daux
 266 cgn              write(ulsort,92010) vatren(nrofon,prftrn(qucnp1))
 267    21   continue
 268 c
 269 c 2.2. ==> etanp1 = 21 ou 22 : le quadrangle est decoupe en deux
 270 c                              quadrangles
 271 c             c'est ce qui se passe quand un decoupage de conformite
 272 c             est supprime au debut des algorithmes d'adaptation. il y
 273 c             a du deraffinement dans la zone qui induisait le decoupage
 274 c             de conformite et raffinement sur une autre zone.
 275 c             On donne la valeur moyenne de la fonction sur les trois
 276 c             anciens fils a chaque nouveau fils.
 277 c             remarque : on pourrait certainement faire mieux, avec des
 278 c                        moyennes ponderees en fonction du recouvrement
 279 c                        des anciens et nouveaux fils. c'est trop
 280 c                        complique pour que cela vaille le coup.
 281 c             remarque : cela arrive seulement avec du deraffinement.
 282 c
 283 c           .................         .................
 284 c           .      . .      .         .       .       .
 285 c           .     .   .     .         .       .       .
 286 c           .    .     .    .         .       .       .
 287 c           .   .       .   .  ===>   .       .       .
 288 c           .  .         .  .         .       .       .
 289 c           . .           . .         .       .       .
 290 c           ..             ..         .       .       .
 291 c           .................         .................
 292 c
 293       elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then
 294 cgn      write(ulsort,*)'... quadrangle coupe en 2'
 295 c
 296         f1hp = filqua(quhnp1)
 297         f1cp = nqusca(f1hp)
 298         f2cp = nqusca(f1hp+1)
 299         prfcap(f1cp) = 1
 300         prfcap(f2cp) = 1
 301 cgn       write (ulsort,90002) 'f1cp, f2cp', f1cp, f2cp
 302 c
 303         if ( typint.eq.0 ) then
 304           do 221 , nrofon = 1 , nbfonc
 305             daux = unstr * ( vatren(nrofon,prftrn(f1cn))
 306      >                     + vatren(nrofon,prftrn(f2cn))
 307      >                     + vatren(nrofon,prftrn(f3cn)) )
 308 cgn            write(ulsort,90004) 'daux', daux
 309             vafott(nrofon,f1cp) = daux
 310             vafott(nrofon,f2cp) = daux
 311 cgn              write(*,92010) daux
 312  221      continue
 313         else
 314           call utqqua ( f1hp  , daux, daux1, coonoe, somare, arequa )
 315           call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
 316           daux0 = daux1 + daux2
 317           daux1 = daux1 / daux0
 318           daux2 = daux2 / daux0
 319           do 222 , nrofon = 1 , nbfonc
 320             daux = vatren(nrofon,prftrn(f1cn))
 321      >           + vatren(nrofon,prftrn(f2cn))
 322      >           + vatren(nrofon,prftrn(f3cn))
 323 cgn            write(ulsort,90004) 'daux', daux
 324             vafott(nrofon,f1cp) = daux1 * daux
 325             vafott(nrofon,f2cp) = daux2 * daux
 326 cgn              write(*,92010) daux
 327  222      continue
 328         endif
 329 c
 330 c 2.3. ==> etanp1 = etan : le quadrangle est decoupe en
 331 c                       trois triangles selon le meme decoupage.
 332 c             c'est ce qui se passe quand un decoupage de conformite
 333 c             est supprime au debut des algorithmes d'adaptation,
 334 c             puis reproduit a la creation du maillage car les
 335 c             quadrangles autour n'ont pas change entre les deux
 336 c             iterations.
 337 c             le fils prend la valeur de la fonction sur l'ancien
 338 c             fils qui etait au meme endroit. comme la procedure de
 339 c             numerotation est la meme (voir cmcdqu), le premier fils
 340 c             est toujours le meme, le 2eme et le 3eme egalement.
 341 c             on prendra alors la valeur sur le fils de rang identique
 342 c             a l'iteration n.
 343 c           .................         .................
 344 c           .      . .      .         .      . .      .
 345 c           .     .   .     .         .     .   .     .
 346 c           .    .     .    .         .    .     .    .
 347 c           .   .       .   .  ===>   .   .       .   .
 348 c           .  .         .  .         .  .         .  .
 349 c           . .           . .         . .           . .
 350 c           ..             ..         ..             ..
 351 c           .................         .................
 352 c
 353       elseif ( etanp1.eq.etan ) then
 354 cgn      write(ulsort,*)'... quadrangle coupe en 3 triangles ; meme dec'
 355 c
 356         f1hp = -filqua(quhnp1)
 357         f1cp = ntrsca(f1hp)
 358         f2cp = ntrsca(f1hp+1)
 359         f3cp = ntrsca(f1hp+2)
 360         prftrp(f1cp) = 1
 361         prftrp(f2cp) = 1
 362         prftrp(f3cp) = 1
 363 c
 364 cgn        write(32,91010) f1cp,f2cp,f3cp
 365         do 230 , nrofon = 1 , nbfonc
 366           vatrtt(nrofon,f1cp) = vatren(nrofon,prftrn(f1cn))
 367           vatrtt(nrofon,f2cp) = vatren(nrofon,prftrn(f2cn))
 368           vatrtt(nrofon,f3cp) = vatren(nrofon,prftrn(f3cn))
 369 cgn          write(ulsort,92010) vatren(nrofon,prftrn(f1cn)),
 370 cgn     >                       vatren(nrofon,prftrn(f2cn)),
 371 cgn     >                       vatren(nrofon,prftrn(f3cn))
 372   230   continue
 373 c
 374 c 2.4. ==> etanp1 = 31, 32, 33 ou 34 et different de etan :
 375 c          le quadrangle est encore decoupe en trois triangles,
 376 c          mais par un autre decoupage.
 377 c             c'est ce qui se passe quand un decoupage de conformite
 378 c             est supprime au debut des algorithmes d'adaptation. il y
 379 c             a du deraffinement dans la zone qui induisait le decoupage
 380 c             de conformite et raffinement sur une autre zone.
 381 c             On donne la valeur moyenne de la fonction sur les trois
 382 c             anciens fils a chaque nouveau fils.
 383 c             remarque : on pourrait certainement faire mieux, avec des
 384 c                        moyennes ponderees en fonction du recouvrement
 385 c                        des anciens et nouveaux fils. c'est trop
 386 c                        complique pour que cela vaille le coup.
 387 c             remarque : cela arrive seulement avec du deraffinement.
 388 c
 389 c           .................         .................
 390 c           .      . .      .         ..             ..
 391 c           .     .   .     .         . .           . .
 392 c           .    .     .    .         .  .         .  .
 393 c           .   .       .   .  ===>   .   .       .   .
 394 c           .  .         .  .         .    .     .    .
 395 c           . .           . .         .     .   .     .
 396 c           ..             ..         .      . .      .
 397 c           .................         .................
 398 c
 399       elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
 400 cgn      write(ulsort,*)'... quadrangle coupe en 3 triangles ; autre'
 401 c
 402         f1hp = -filqua(quhnp1)
 403         f1cp = ntrsca(f1hp)
 404         f2cp = ntrsca(f1hp+1)
 405         f3cp = ntrsca(f1hp+2)
 406         prftrp(f1cp) = 1
 407         prftrp(f2cp) = 1
 408         prftrp(f3cp) = 1
 409 c
 410         if ( typint.eq.0 ) then
 411 c
 412           do 241 , nrofon = 1 , nbfonc
 413             daux = unstr * ( vatren(nrofon,prftrn(f1cn))
 414      >                     + vatren(nrofon,prftrn(f2cn))
 415      >                     + vatren(nrofon,prftrn(f3cn)) )
 416 cgn            write(ulsort,90004) 'daux', daux
 417             vatrtt(nrofon,f1cp) = daux
 418             vatrtt(nrofon,f2cp) = daux
 419             vatrtt(nrofon,f3cp) = daux
 420   241     continue
 421 c
 422         else
 423 c
 424           call utqtri ( f1hp  , daux, daux1, coonoe, somare, aretri )
 425           call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri )
 426           call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri )
 427           daux0 = daux1 + daux2 + daux3
 428           daux1 = daux1 / daux0
 429           daux2 = daux2 / daux0
 430           daux3 = daux3 / daux0
 431           do 242 , nrofon = 1 , nbfonc
 432             daux = vatren(nrofon,prftrn(f1cn))
 433      >           + vatren(nrofon,prftrn(f2cn))
 434      >           + vatren(nrofon,prftrn(f3cn))
 435 cgn            write(ulsort,90004) 'unsde*daux', unsde*daux
 436 cgn            write(ulsort,90004) 'unsqu*daux', unsqu*daux
 437             vatrtt(nrofon,f1cp) = daux1 * daux
 438             vatrtt(nrofon,f2cp) = daux2 * daux
 439             vatrtt(nrofon,f3cp) = daux3 * daux
 440   242     continue
 441 c
 442         endif
 443 c
 444 c 2.5. ==> etanp1 = 4 : le quadrangle est decoupe en quatre.
 445 c             c'est ce qui se passe quand un decoupage de conformite
 446 c             est supprime au debut des algorithmes d'adaptation. il y
 447 c             a ensuite raffinement du quadrangle. qui plus est, par
 448 c             suite de la regle des ecarts de niveau, on peut avoir
 449 c             induit un decoupage de conformite sur un ou plusieurs
 450 c             des fils. Ce ou ces fils sont obligatoirement du cote du
 451 c             precedent point de non conformite. Ils ne peuvent pas etre
 452 c             des decoupages en 2 car une arte interne ne peut pas avoir
 453 c             ete coupee puisqu'elle n'existait pas.
 454 c
 455 c             On donne la valeur moyenne de la fonction sur les trois
 456 c             anciens fils a chaque nouveau fils.
 457 c             remarque : on pourrait certainement faire mieux, avec des
 458 c                        moyennes ponderees en fonction du recouvrement
 459 c                        des anciens et nouveaux fils. c'est trop
 460 c                        complique pour que cela vaille le coup.
 461 c
 462 c           .................         .................
 463 c           .      . .      .         .       .       .
 464 c           .     .   .     .         .       .       .
 465 c           .    .     .    .         .       .       .
 466 c           .   .       .   .  ===>   .................
 467 c           .  .         .  .         .       .       .
 468 c           . .           . .         .       .       .
 469 c           ..             ..         .       .       .
 470 c           .................         .................
 471 c
 472 c
 473 c           .................         .................
 474 c           .      . .      .         .  . .  .       .
 475 c           .     .   .     .         . .   . .       .
 476 c           .    .     .    .         ..     ..       .
 477 c           .   .       .   .  ===>   .................
 478 c           .  .         .  .         .       .       .
 479 c           . .           . .         .       .       .
 480 c           ..             ..         .       .       .
 481 c           .................         .................
 482 c
 483 c
 484 c           .................         .................
 485 c           .      . .      .         .  .    .       .
 486 c           .     .   .     .         ....    .       .
 487 c           .    .     .    .         .     . .       .
 488 c           .   .       .   .  ===>   .................
 489 c           .  .         .  .         .       .       .
 490 c           . .           . .         .       .       .
 491 c           ..             ..         .       .       .
 492 c           .................         .................
 493 c
 494 c
 495 c       On parcourt chacun des 4 quadrangles fils et on distingue
 496 c       le cas ou il est actif et le cas ou il est coupe en 3 triangles
 497 c       ou en 3 quadrangles
 498 c
 499       elseif ( etanp1.eq.4 ) then
 500 cgn      write(ulsort,*)'... quadrangle coupe en 4 quadrangles'
 501 c
 502         f1hp = filqua(quhnp1)
 503         if ( typint.eq.0 ) then
 504 c
 505           do 251 , nrofon = 1 , nbfonc
 506 c
 507             daux = unstr * ( vatren(nrofon,prftrn(f1cn))
 508      >                     + vatren(nrofon,prftrn(f2cn))
 509      >                     + vatren(nrofon,prftrn(f3cn)) )
 510 cgn            write(ulsort,90004) 'daux', daux
 511 c
 512             do 2511 , iaux = 0 , 3
 513               fihp = f1hp + iaux
 514 cgn       write (ulsort,texte(langue,4)) 'n+1', fihp
 515 cgn       write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 516               if ( mod(hetqua(fihp),100).eq.0 ) then
 517                 ficp = nqusca(fihp)
 518 cgn       write (ulsort,90002) 'ficp', ficp
 519                 vafott(nrofon,ficp) = daux
 520                 prfcap(ficp) = 1
 521               elseif ( mod(hetqua(fihp),100).ge.31 .and.
 522      >                 mod(hetqua(fihp),100).le.34 ) then
 523                 f1fhp = -filqua(fihp)
 524                 f1fcp = ntrsca(f1fhp)
 525                 f2fcp = ntrsca(f1fhp+1)
 526                 f3fcp = ntrsca(f1fhp+2)
 527 c
 528                 prftrp(f1fcp) = 1
 529                 prftrp(f2fcp) = 1
 530                 prftrp(f3fcp) = 1
 531                 vatrtt(nrofon,f1fcp) = daux
 532                 vatrtt(nrofon,f2fcp) = daux
 533                 vatrtt(nrofon,f3fcp) = daux
 534               elseif ( mod(hetqua(fihp),100).ge.41 .and.
 535      >                 mod(hetqua(fihp),100).le.44 ) then
 536                 f1fhp = filqua(fihp)
 537                 f1fcp = nqusca(f1fhp)
 538                 f2fcp = nqusca(f1fhp+1)
 539                 f3fcp = nqusca(f1fhp+2)
 540 c
 541                 prfcap(f1fcp) = 1
 542                 prfcap(f2fcp) = 1
 543                 prfcap(f3fcp) = 1
 544                 vafott(nrofon,f1fcp) = daux
 545                 vafott(nrofon,f2fcp) = daux
 546                 vafott(nrofon,f3fcp) = daux
 547               else
 548                 codret = codret + 1
 549                 write (ulsort,texte(langue,4)) 'n+1', fihp
 550                 write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 551                 write (ulsort,texte(langue,7)) etan
 552               endif
 553  2511       continue
 554 c
 555   251     continue
 556 c
 557         else
 558 c
 559           call utqqua ( quhn, daux, daux0, coonoe, somare, arequa )
 560 c
 561           do 252 , iaux = 0 , 3
 562 c
 563             fihp = f1hp + iaux
 564             if ( mod(hetqua(fihp),100).eq.0 ) then
 565               ficp = nqusca(fihp)
 566               prfcap(ficp) = 1
 567               call utqqua ( fihp, daux, daux1, coonoe, somare, arequa )
 568               do 2521 , nrofon = 1 , nbfonc
 569                 daux = vatren(nrofon,prftrn(f1cn))
 570      >               + vatren(nrofon,prftrn(f2cn))
 571      >               + vatren(nrofon,prftrn(f3cn))
 572                 vafott(nrofon,ficp) = daux * daux1 / daux0
 573  2521         continue
 574             elseif ( mod(hetqua(fihp),100).ge.31 .and.
 575      >               mod(hetqua(fihp),100).le.34 ) then
 576               f1fhp = -filqua(fihp)
 577               f1fcp = ntrsca(f1fhp)
 578               f2fcp = ntrsca(f1fhp+1)
 579               f3fcp = ntrsca(f1fhp+2)
 580               prftrp(f1fcp) = 1
 581               prftrp(f2fcp) = 1
 582               prftrp(f3fcp) = 1
 583               call utqtri ( f1fhp  , daux, daux1,
 584      >                      coonoe, somare, aretri )
 585               call utqtri ( f1fhp+1, daux, daux2,
 586      >                      coonoe, somare, aretri )
 587               call utqtri ( f1fhp+2, daux, daux3,
 588      >                      coonoe, somare, aretri )
 589               do 2522 , nrofon = 1 , nbfonc
 590                 daux = vatren(nrofon,prftrn(f1cn))
 591      >               + vatren(nrofon,prftrn(f2cn))
 592      >               + vatren(nrofon,prftrn(f3cn))
 593                 vatrtt(nrofon,f1fcp) = daux1 * daux / daux0
 594                 vatrtt(nrofon,f2fcp) = daux2 * daux / daux0
 595                 vatrtt(nrofon,f3fcp) = daux3 * daux / daux0
 596  2522         continue
 597             elseif ( mod(hetqua(fihp),100).ge.41 .and.
 598      >               mod(hetqua(fihp),100).le.44 ) then
 599               f1fhp = filqua(fihp)
 600               f1fcp = nqusca(f1fhp)
 601               f2fcp = nqusca(f1fhp+1)
 602               f3fcp = nqusca(f1fhp+2)
 603 c
 604               prfcap(f1fcp) = 1
 605               prfcap(f2fcp) = 1
 606               prfcap(f3fcp) = 1
 607               call utqqua ( f1fhp  , daux, daux1,
 608      >                      coonoe, somare, arequa )
 609               call utqqua ( f1fhp+1, daux, daux2,
 610      >                      coonoe, somare, arequa )
 611               call utqqua ( f1fhp+2, daux, daux3,
 612      >                      coonoe, somare, arequa )
 613               do 2523 , nrofon = 1 , nbfonc
 614                 daux = vatren(nrofon,prftrn(f1cn))
 615      >               + vatren(nrofon,prftrn(f2cn))
 616      >               + vatren(nrofon,prftrn(f3cn))
 617                 vafott(nrofon,f1fcp) = daux1 * daux / daux0
 618                 vafott(nrofon,f2fcp) = daux2 * daux / daux0
 619                 vafott(nrofon,f3fcp) = daux3 * daux / daux0
 620  2523         continue
 621             else
 622               codret = codret + 1
 623               write (ulsort,texte(langue,4)) 'n+1', fihp
 624               write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 625               write (ulsort,texte(langue,7)) etan
 626             endif
 627 c
 628   252     continue
 629 c
 630         endif
 631 c
 632 c 2.6. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en
 633 c          trois quadrangles
 634 c             c'est ce qui se passe quand un decoupage de conformite
 635 c             est supprime au debut des algorithmes d'adaptation. il y
 636 c             a du deraffinement dans la zone qui induisait le decoupage
 637 c             de conformite et raffinement sur une autre zone.
 638 c             On donne la valeur moyenne de la fonction sur les trois
 639 c             anciens fils a chaque nouveau fils.
 640 c             remarque : on pourrait certainement faire mieux, avec des
 641 c                        moyennes ponderees en fonction du recouvrement
 642 c                        des anciens et nouveaux fils. c'est trop
 643 c                        complique pour que cela vaille le coup.
 644 c             remarque : cela arrive seulement avec du deraffinement.
 645 c
 646 c           .................         .................
 647 c           .      . .      .         .       .       .
 648 c           .     .   .     .         .       .       .
 649 c           .    .     .    .         .       .       .
 650 c           .   .       .   .  ===>   .........       .
 651 c           .  .         .  .         .         .     .
 652 c           . .           . .         .           .   .
 653 c           ..             ..         .             . .
 654 c           .................         .................
 655 c
 656       elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then
 657 cgn      write(ulsort,*)'... quadrangle coupe en 3 quadrangles'
 658 c
 659         f1hp = filqua(quhnp1)
 660         f1cp = nqusca(f1hp)
 661         f2cp = nqusca(f1hp+1)
 662         f3cp = nqusca(f1hp+2)
 663         prfcap(f1cp) = 1
 664         prfcap(f2cp) = 1
 665         prfcap(f3cp) = 1
 666 c
 667         if ( typint.eq.0 ) then
 668 c
 669           do 261 , nrofon = 1 , nbfonc
 670             daux = unstr * ( vatren(nrofon,prftrn(f1cn))
 671      >                     + vatren(nrofon,prftrn(f2cn))
 672      >                     + vatren(nrofon,prftrn(f3cn)) )
 673             vafott(nrofon,f1cp) = daux
 674             vafott(nrofon,f2cp) = daux
 675             vafott(nrofon,f3cp) = daux
 676   261     continue
 677 c
 678         else
 679 c
 680           call utqqua ( f1hp  , daux, daux1, coonoe, somare, arequa )
 681           call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
 682           call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa )
 683           daux0 = daux1 + daux2 + daux3
 684           daux1 = daux1 / daux0
 685           daux2 = daux2 / daux0
 686           daux3 = daux3 / daux0
 687           do 262 , nrofon = 1 , nbfonc
 688             daux = vatren(nrofon,prftrn(f1cn))
 689      >           + vatren(nrofon,prftrn(f2cn))
 690      >           + vatren(nrofon,prftrn(f3cn))
 691             vafott(nrofon,f1cp) = daux1 * daux
 692             vafott(nrofon,f2cp) = daux2 * daux
 693             vafott(nrofon,f3cp) = daux3 * daux
 694   262     continue
 695 c
 696         endif
 697
 698 c 2.7. ==> aucun autre etat sur le quadrangle courant n'est possible
 699 c
 700       else
 701 c
 702         coderr = 1
 703         write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1
 704 c
 705       endif
 706 c
 707       endif
 708 c
 709 c====
 710 c 3. la fin
 711 c====
 712 c
 713       if ( coderr.ne.0 ) then
 714 c
 715       write (ulsort,texte(langue,1)) 'Sortie', nompro
 716       write (ulsort,texte(langue,2)) coderr
 717       codret = codret + coderr
 718 c
 719       endif
 720 c
 721 #ifdef _DEBUG_HOMARD_
 722       write (ulsort,texte(langue,1)) 'Sortie', nompro
 723       call dmflsh (iaux)
 724 #endif
 725 c
 726       end