src/tool/AP_Conversion/pcseq1.F

   1       subroutine pcseq1 ( etan, etanp1, quhn, quhnp1, typint,
   2      >                    prfcan, prfcap,
   3      >                    coonoe,
   4      >                    somare,
   5      >                    arequa, hetqua, filqua,
   6      >                    nbanqu, anfiqu,
   7      >                    nqueca, nqusca,
   8      >                    aretri,
   9      >                            ntrsca,
  10      >                    nbfonc, vafoen, vafott,
  11      >                            vatrtt,
  12      >                            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 21-22
  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 . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  69 c .        .     .        . 0 : l'entite est absente du profil         .
  70 c .        .     .        . i : l'entite est au rang i dans le profil  .
  71 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  72 c .        .     .        . 0 : l'entite est absente du profil         .
  73 c .        .     .        . 1 : l'entite est presente dans le profil   .
  74 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  75 c .        .     . * sdim .                                            .
  76 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  77 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  78 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  79 c . filqua . e   . nbquto . premier fils des quadrangles               .
  80 c . nbanqu . e   .   1    . nombre de quadrangles decoupes par         .
  81 c .        .     .        . conformite sur le maillage avant adaptation.
  82 c . anfiqu . e   . nbanqu . tableau filqua du maillage de l'iteration n.
  83 c . nqueca . e   .   *    . nro des quadrangles dans le calcul en ent. .
  84 c . nqusca . e   . rsquto . numero des quadrangles du calcul           .
  85 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  86 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  87 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  88 c . vafoen . e   . nbfonc*. variables en entree de l'adaptation        .
  89 c .        .     .    *   .                                            .
  90 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  91 c .        .     .    *   .                                            .
  92 c . vatrtt .   a . nbfonc*. tableau temporaire de la solution pour     .
  93 c .        .     .    *   . les triangles de conformite                .
  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 = 'PCSEQ1' )
 116 c
 117 #include "nblang.h"
 118 #include "fracta.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 prfcan(*), prfcap(*)
 136       integer somare(2,nbarto)
 137       integer arequa(nbquto,4), hetqua(nbquto)
 138       integer filqua(nbquto)
 139       integer nbanqu, anfiqu(nbanqu)
 140       integer nqueca(requto), nqusca(rsquto)
 141       integer aretri(nbtrto,3)
 142       integer ntrsca(rstrto)
 143       integer prftrp(*)
 144 c
 145       double precision coonoe(nbnoto,sdim)
 146       double precision vafoen(nbfonc,*)
 147       double precision vafott(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
 172       integer f1hn
 173       integer f1cn, f2cn
 174 c
 175 c     f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1
 176 c     f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1
 177 c     f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1
 178 c     f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1
 179 c
 180       integer f1fhp, f1fcp, f2fcp, f3fcp
 181 c
 182       integer coderr
 183       integer nrofon
 184       integer iaux
 185 c
 186       double precision daux
 187       double precision daux0, daux1, daux2, daux3
 188 c
 189       integer nbmess
 190       parameter ( nbmess = 10 )
 191       character*80 texte(nblang,nbmess)
 192 c
 193 c 0.5. ==> initialisations
 194 c ______________________________________________________________________
 195 c
 196 c====
 197 c 1. initialisations
 198 c====
 199 c
 200 #include "pcimp0.h"
 201 #include "impr01.h"
 202 #include "impr03.h"
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,1)) 'Entree', nompro
 206       call dmflsh (iaux)
 207 #endif
 208 c
 209       texte(1,4) =
 210      >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)'
 211       texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)'
 212 c
 213       texte(2,4) =
 214      >'(''Current quadrangle : # at iteration '',a3,''     : '',i10)'
 215       texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)'
 216 c
 217       coderr = 0
 218 c
 219 c 1.2. ==> on repere les numeros dans le calcul pour les fils
 220 c          a l'iteration n
 221 c
 222       f1hn = anfiqu(quhn)
 223       f1cn = nqueca(f1hn)
 224       f2cn = nqueca(f1hn+1)
 225 c
 226       if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then
 227 c
 228 c====
 229 c 2. le quadrangle etait coupe en 2 quadrangles
 230 c====
 231 c 2.1. ==> etanp1 = 0 : le quadrangle est actif ; il est reactive.
 232 c          on lui attribue la valeur moyenne des deux anciens fils.
 233 c          remarque : cela arrive seulement avec du deraffinement.
 234 c           .................         .................
 235 c           .               .         .               .
 236 c           .               .         .               .
 237 c           .               .         .               .
 238 c           .................  ===>   .               .
 239 c           .               .         .               .
 240 c           .               .         .               .
 241 c           .               .         .               .
 242 c           .................         .................
 243 c
 244       if ( etanp1.eq.0 ) then
 245 cgn      write(ulsort,*)'... quadrangle reactive'
 246 c
 247         qucnp1 = nqusca(quhnp1)
 248         prfcap(qucnp1) = 1
 249 c
 250         if ( typint.eq.0 ) then
 251           daux1 = unsde
 252         else
 253           daux1 = 1.d0
 254         endif
 255         do 21 , nrofon = 1 , nbfonc
 256           daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 257      >                   + vafoen(nrofon,prfcan(f2cn)) )
 258 cgn            write(ulsort,90004) 'daux', daux
 259           vafott(nrofon,qucnp1) = daux
 260    21   continue
 261 c
 262 c 2.2. ==> etanp1 = etan : le quadrangle est decoupe en
 263 c          deux quadrangles selon le meme decoupage.
 264 c             c'est ce qui se passe quand un decoupage de conformite
 265 c             est supprime au debut des algorithmes d'adaptation,
 266 c             puis reproduit a la creation du maillage car les
 267 c             quadrangles autour n'ont pas change entre les deux
 268 c             iterations.
 269 c             le fils prend la valeur de la fonction sur l'ancien
 270 c             fils qui etait au meme endroit. comme la procedure de
 271 c             numerotation est la meme (voir cmcdqu), le premier fils
 272 c             est toujours le meme, le 2nd egalement.
 273 c             on prendra alors la valeur sur le fils de rang identique
 274 c             a l'iteration n.
 275 c           .................         .................
 276 c           .               .         .               .
 277 c           .               .         .               .
 278 c           .               .         .               .
 279 c           .................  ===>   .................
 280 c           .               .         .               .
 281 c           .               .         .               .
 282 c           .               .         .               .
 283 c           .................         .................
 284 c
 285       elseif ( etanp1.eq.etan ) then
 286 cgn      write(ulsort,*)'... quadrangle coupe en 2 ; meme decoupage'
 287 c
 288         f1hp = filqua(quhnp1)
 289         f1cp = nqusca(f1hp)
 290         f2cp = nqusca(f1hp+1)
 291         prfcap(f1cp) = 1
 292         prfcap(f2cp) = 1
 293         do 22 , nrofon = 1 , nbfonc
 294           vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn))
 295           vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn))
 296    22   continue
 297 cgn        write(ulsort,90002)'f1cp, f2cp', f1cp, f2cp
 298 c
 299 c 2.3. ==> etanp1 = 21/22 : le quadrangle est decoupe en
 300 c          deux quadrangles selon un autre decoupage.
 301 c             On donne la valeur moyenne de la fonction sur les deux
 302 c             anciens fils a chaque nouveau fils.
 303 c           .................         .................
 304 c           .               .         .       .       .
 305 c           .               .         .       .       .
 306 c           .               .         .       .       .
 307 c           .................  ===>   .       .       .
 308 c           .               .         .       .       .
 309 c           .               .         .       .       .
 310 c           .               .         .       .       .
 311 c           .................         .................
 312       elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then
 313 cgn      write(ulsort,*)'... quadrangle coupe en 2 ; autre decoupage'
 314 c
 315         f1hp = filqua(quhnp1)
 316         f1cp = nqusca(f1hp)
 317         f2cp = nqusca(f1hp+1)
 318         prfcap(f1cp) = 1
 319         prfcap(f2cp) = 1
 320 c
 321         if ( typint.eq.0 ) then
 322           do 231 , nrofon = 1 , nbfonc
 323             daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 324      >                     + vafoen(nrofon,prfcan(f2cn)) )
 325 cgn              write(ulsort,90004) 'daux', daux
 326             vafott(nrofon,f1cp) = daux
 327             vafott(nrofon,f2cp) = daux
 328   231     continue
 329         else
 330           call utqqua ( f1hp  , daux, daux1, coonoe, somare, arequa )
 331           call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
 332           daux0 = daux1 + daux2
 333           daux1 = daux1 / daux0
 334           daux2 = daux2 / daux0
 335           do 232 , nrofon = 1 , nbfonc
 336             daux = vafoen(nrofon,prfcan(f1cn))
 337      >           + vafoen(nrofon,prfcan(f2cn))
 338             vafott(nrofon,f1cp) = daux1 * daux
 339             vafott(nrofon,f2cp) = daux2 * daux
 340 cgn            write(ulsort,92010) daux
 341   232     continue
 342         endif
 343 c
 344 c 2.4. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle est decoupe en
 345 c          trois triangles.
 346 c             remarque : cela arrive seulement avec du deraffinement.
 347 c
 348 c           .................         .................
 349 c           .               .         ..             ..
 350 c           .               .         . .           . .
 351 c           .               .         .  .         .  .
 352 c           .................  ===>   .   .       .   .
 353 c           .               .         .    .     .    .
 354 c           .               .         .     .   .     .
 355 c           .               .         .      . .      .
 356 c           .................         .................
 357 c
 358       elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
 359 cgn      write(ulsort,*)'... quadrangle coupe en 3 triangles'
 360 c
 361         f1hp = -filqua(quhnp1)
 362         f1cp = ntrsca(f1hp)
 363         f2cp = ntrsca(f1hp+1)
 364         f3cp = ntrsca(f1hp+2)
 365         prftrp(f1cp) = 1
 366         prftrp(f2cp) = 1
 367         prftrp(f3cp) = 1
 368 c
 369         if ( typint.eq.0 ) then
 370 c
 371           do 241 , nrofon = 1 , nbfonc
 372             daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 373      >                     + vafoen(nrofon,prfcan(f2cn)) )
 374 cgn            write(ulsort,90004) 'daux', daux
 375             vatrtt(nrofon,f1cp) = daux
 376             vatrtt(nrofon,f2cp) = daux
 377             vatrtt(nrofon,f3cp) = daux
 378   241     continue
 379 c
 380         else
 381 c
 382           call utqtri ( f1hp  , daux, daux1, coonoe, somare, aretri )
 383           call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri )
 384           call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri )
 385           daux0 = daux1 + daux2 + daux3
 386           daux1 = daux1 / daux0
 387           daux2 = daux2 / daux0
 388           daux3 = daux3 / daux0
 389           do 242 , nrofon = 1 , nbfonc
 390             daux = vafoen(nrofon,prfcan(f1cn))
 391      >           + vafoen(nrofon,prfcan(f2cn))
 392             vatrtt(nrofon,f1cp) = daux1 * daux
 393             vatrtt(nrofon,f2cp) = daux2 * daux
 394             vatrtt(nrofon,f3cp) = daux3 * daux
 395   242     continue
 396 c
 397         endif
 398 c
 399 c 2.5. ==> etanp1 = 4 : le quadrangle est decoupe en quatre.
 400 c             c'est ce qui se passe quand un decoupage de conformite
 401 c             est supprime au debut des algorithmes d'adaptation. il y
 402 c             a ensuite raffinement du quadrangle. qui plus est, par
 403 c             suite de la regle des ecarts de niveau, on peut avoir
 404 c             induit un decoupage de conformite sur un ou plusieurs
 405 c             des fils. Ce ou ces fils sont obligatoirement du cote du
 406 c             precedent point de non conformite. Ils ne peuvent pas etre
 407 c             des decoupages en 2 car une arte interne ne peut pas avoir
 408 c             ete coupee puisqu'elle n'existait pas.
 409 c
 410 c             On donne la valeur moyenne de la fonction sur les trois
 411 c             anciens fils a chaque nouveau fils.
 412 c             remarque : on pourrait certainement faire mieux, avec des
 413 c                        moyennes ponderees en fonction du recouvrement
 414 c                        des anciens et nouveaux fils. c'est trop
 415 c                        complique pour que cela vaille le coup.
 416 c
 417 c           .................         .................
 418 c           .               .         .       .       .
 419 c           .               .         .       .       .
 420 c           .               .         .       .       .
 421 c           .................  ===>   .................
 422 c           .               .         .       .       .
 423 c           .               .         .       .       .
 424 c           .               .         .       .       .
 425 c           .................         .................
 426 c
 427 c
 428 c           .................         .................
 429 c           .               .         .  . .  .       .
 430 c           .               .         . .   . .       .
 431 c           .               .         ..     ..       .
 432 c           .................  ===>   .................
 433 c           .               .         .       .       .
 434 c           .               .         .       .       .
 435 c           .               .         .       .       .
 436 c           .................         .................
 437 c
 438 c
 439 c           .................         .................
 440 c           .               .         .  .    .       .
 441 c           .               .         ....    .       .
 442 c           .               .         .     . .       .
 443 c           .................  ===>   .................
 444 c           .               .         .       .       .
 445 c           .               .         .       .       .
 446 c           .               .         .       .       .
 447 c           .................         .................
 448 c
 449 c
 450 c       On parcourt chacun des 4 quadrangles fils et on distingue
 451 c       le cas ou il est actif et le cas ou il est coupe en 3 triangles
 452 c       ou en 3 quadrangles
 453 c
 454       elseif ( etanp1.eq.4 ) then
 455 cgn      write(ulsort,*)'... quadrangle coupe en 4 quadrangles'
 456 c
 457         f1hp = filqua(quhnp1)
 458         if ( typint.eq.0 ) then
 459 c
 460           do 251 , nrofon = 1 , nbfonc
 461 c
 462             daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 463      >                     + vafoen(nrofon,prfcan(f2cn)) )
 464 cgn            write(ulsort,90004) 'daux', daux
 465 c
 466             do 2511 , iaux = 0 , 3
 467               fihp = f1hp + iaux
 468 cgn             write (ulsort,texte(langue,4)) 'n+1', fihp
 469 cgn             write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 470               if ( mod(hetqua(fihp),100).eq.0 ) then
 471                 ficp = nqusca(fihp)
 472                 vafott(nrofon,ficp) = daux
 473                 prfcap(ficp) = 1
 474               elseif ( mod(hetqua(fihp),100).ge.31 .and.
 475      >                 mod(hetqua(fihp),100).le.34 ) then
 476                 f1fhp = -filqua(fihp)
 477                 f1fcp = ntrsca(f1fhp)
 478                 f2fcp = ntrsca(f1fhp+1)
 479                 f3fcp = ntrsca(f1fhp+2)
 480 c
 481                 prftrp(f1fcp) = 1
 482                 prftrp(f2fcp) = 1
 483                 prftrp(f3fcp) = 1
 484                 vatrtt(nrofon,f1fcp) = daux
 485                 vatrtt(nrofon,f2fcp) = daux
 486                 vatrtt(nrofon,f3fcp) = daux
 487               elseif ( mod(hetqua(fihp),100).ge.41 .and.
 488      >                 mod(hetqua(fihp),100).le.44 ) then
 489                 f1fhp = filqua(fihp)
 490                 f1fcp = nqusca(f1fhp)
 491                 f2fcp = nqusca(f1fhp+1)
 492                 f3fcp = nqusca(f1fhp+2)
 493 c
 494                 prfcap(f1fcp) = 1
 495                 prfcap(f2fcp) = 1
 496                 prfcap(f3fcp) = 1
 497                 vafott(nrofon,f1fcp) = daux
 498                 vafott(nrofon,f2fcp) = daux
 499                 vafott(nrofon,f3fcp) = daux
 500              else
 501                 codret = codret + 1
 502                 write (ulsort,texte(langue,4)) 'n+1', fihp
 503                 write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 504                 write (ulsort,texte(langue,7)) etan
 505               endif
 506  2511       continue
 507 c
 508   251     continue
 509 c
 510         else
 511 c
 512           call utqqua ( quhn, daux, daux0, coonoe, somare, arequa )
 513 c
 514           do 252 , iaux = 0 , 3
 515 c
 516             fihp = f1hp + iaux
 517             if ( mod(hetqua(fihp),100).eq.0 ) then
 518               ficp = nqusca(fihp)
 519               prfcap(ficp) = 1
 520               call utqqua ( fihp, daux, daux1, coonoe, somare, arequa )
 521               do 2521 , nrofon = 1 , nbfonc
 522                 daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 523      >                         + vafoen(nrofon,prfcan(f2cn)) ) / daux0
 524                 vafott(nrofon,ficp) = daux
 525  2521         continue
 526             elseif ( mod(hetqua(fihp),100).ge.31 .and.
 527      >               mod(hetqua(fihp),100).le.34 ) then
 528               f1fhp = -filqua(fihp)
 529               f1fcp = ntrsca(f1fhp)
 530               f2fcp = ntrsca(f1fhp+1)
 531               f3fcp = ntrsca(f1fhp+2)
 532               prftrp(f1fcp) = 1
 533               prftrp(f2fcp) = 1
 534               prftrp(f3fcp) = 1
 535               call utqtri ( f1fhp  , daux, daux1,
 536      >                      coonoe, somare, aretri )
 537               call utqtri ( f1fhp+1, daux, daux2,
 538      >                      coonoe, somare, aretri )
 539               call utqtri ( f1fhp+2, daux, daux3,
 540      >                      coonoe, somare, aretri )
 541               do 2522 , nrofon = 1 , nbfonc
 542                 daux = vafoen(nrofon,prfcan(f1cn))
 543      >               + vafoen(nrofon,prfcan(f2cn))
 544                 vatrtt(nrofon,f1fcp) = daux1 * daux / daux0
 545                 vatrtt(nrofon,f2fcp) = daux2 * daux / daux0
 546                 vatrtt(nrofon,f3fcp) = daux3 * daux / daux0
 547  2522         continue
 548             elseif ( mod(hetqua(fihp),100).ge.41 .and.
 549      >               mod(hetqua(fihp),100).le.44 ) then
 550               f1fhp = filqua(fihp)
 551               f1fcp = nqusca(f1fhp)
 552               f2fcp = nqusca(f1fhp+1)
 553               f3fcp = nqusca(f1fhp+2)
 554 c
 555               prfcap(f1fcp) = 1
 556               prfcap(f2fcp) = 1
 557               prfcap(f3fcp) = 1
 558               call utqqua ( f1fhp  , daux, daux1,
 559      >                      coonoe, somare, arequa )
 560               call utqqua ( f1fhp+1, daux, daux2,
 561      >                      coonoe, somare, arequa )
 562               call utqqua ( f1fhp+2, daux, daux3,
 563      >                      coonoe, somare, arequa )
 564               do 2523 , nrofon = 1 , nbfonc
 565                 daux = vafoen(nrofon,prfcan(f1cn))
 566      >               + vafoen(nrofon,prfcan(f2cn))
 567                 vafott(nrofon,f1fcp) = daux1 * daux / daux0
 568                 vafott(nrofon,f2fcp) = daux2 * daux / daux0
 569                 vafott(nrofon,f3fcp) = daux3 * daux / daux0
 570  2523         continue
 571             else
 572               codret = codret + 1
 573               write (ulsort,texte(langue,4)) 'n+1', fihp
 574               write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp)
 575               write (ulsort,texte(langue,7)) etan
 576             endif
 577 c
 578   252     continue
 579 c
 580         endif
 581 c
 582 c 2.6. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en
 583 c          trois quadrangles
 584 c             c'est ce qui se passe quand un decoupage de conformite
 585 c             est supprime au debut des algorithmes d'adaptation. il y
 586 c             a du deraffinement dans la zone qui induisait le decoupage
 587 c             de conformite et raffinement sur une autre zone.
 588 c             On donne la valeur moyenne de la fonction sur les trois
 589 c             anciens fils a chaque nouveau fils.
 590 c             remarque : on pourrait certainement faire mieux, avec des
 591 c                        moyennes ponderees en fonction du recouvrement
 592 c                        des anciens et nouveaux fils. c'est trop
 593 c                        complique pour que cela vaille le coup.
 594 c             remarque : cela arrive seulement avec du deraffinement.
 595 c
 596 c           .................         .................
 597 c           .               .         .       .       .
 598 c           .               .         .       .       .
 599 c           .               .         .       .       .
 600 c           .................  ===>   .........       .
 601 c           .               .         .         .     .
 602 c           .               .         .           .   .
 603 c           .               .         .             . .
 604 c           .................         .................
 605 c
 606       elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then
 607 cgn      write(ulsort,*)'... quadrangle coupe en 3 quadrangles'
 608 c
 609         f1hp = filqua(quhnp1)
 610         f1cp = nqusca(f1hp)
 611         f2cp = nqusca(f1hp+1)
 612         f3cp = nqusca(f1hp+2)
 613         prfcap(f1cp) = 1
 614         prfcap(f2cp) = 1
 615         prfcap(f3cp) = 1
 616 c
 617 cgn            write(*,91010) f1cp,f2cp
 618         if ( typint.eq.0 ) then
 619 c
 620           do 261 , nrofon = 1 , nbfonc
 621             daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 622      >                     + vafoen(nrofon,prfcan(f2cn)) )
 623 cgn            write(ulsort,90004) 'daux', daux
 624             vafott(nrofon,f1cp) = daux
 625             vafott(nrofon,f2cp) = daux
 626             vafott(nrofon,f3cp) = daux
 627 cgn              write(*,92010) daux
 628   261     continue
 629 c
 630         else
 631 c
 632           call utqqua ( f1hp  , daux, daux1, coonoe, somare, arequa )
 633           call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
 634           call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa )
 635           daux0 = daux1 + daux2 + daux3
 636           daux1 = daux1 / daux0
 637           daux2 = daux2 / daux0
 638           daux3 = daux3 / daux0
 639           do 262 , nrofon = 1 , nbfonc
 640             daux = vafoen(nrofon,prfcan(f1cn))
 641      >           + vafoen(nrofon,prfcan(f2cn))
 642 cgn            write(ulsort,90004) 'unsqu*daux', unsqu*daux
 643 cgn            write(ulsort,90004) 'trshu*daux', trshu*daux
 644             vafott(nrofon,f1cp) = daux1 * daux
 645             vafott(nrofon,f2cp) = daux2 * daux
 646             vafott(nrofon,f3cp) = daux3 * daux
 647 cgn              write(*,92010) daux
 648   262     continue
 649 c
 650         endif
 651 c
 652 c 2.7. ==> aucun autre etat sur le quadrangle courant n'est possible
 653 c
 654       else
 655 c
 656         coderr = 1
 657         write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1
 658 c
 659       endif
 660 c
 661       endif
 662 c
 663 c====
 664 c 3. la fin
 665 c====
 666 c
 667       if ( coderr.ne.0 ) then
 668 c
 669       write (ulsort,texte(langue,1)) 'Sortie', nompro
 670       write (ulsort,texte(langue,2)) coderr
 671       codret = codret + coderr
 672 c
 673       endif
 674 c
 675 #ifdef _DEBUG_HOMARD_
 676       write (ulsort,texte(langue,1)) 'Sortie', nompro
 677       call dmflsh (iaux)
 678 #endif
 679 c
 680       end