src/tool/AP_Conversion/pcequ2.F

   1       subroutine pcequ2 ( nbfonc, ngauss, deraff,
   2      >                    prfcan, prfcap,
   3      >                    hetqua, ancqua, filqua,
   4      >                    nbanqu, anfiqu, anhequ,
   5      >                    nqueca, nqusca,
   6      >                    nbantr, anfatr,
   7      >                    ntreca, ntrsca,
   8      >                    vafoen, vafott,
   9      >                    vatren, vatrtt,
  10      >                    prftrn, prftrp,
  11      >                    ulsort, langue, codret )
  12 c
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c    aPres adaptation - Conversion de solution - aux noeuds par Element
  33 c     -                 -                                       -
  34 c                       QUadrangles - degre 2
  35 c                       --                  -
  36 c ______________________________________________________________________
  37 c
  38 c remarque : cette interpolation suppose que l'on est en presence de
  39 c            variables intensives. C'est-a-dire independantes de la
  40 c            taille de la maille.
  41 c            Une densite par exemple mais pas une masse.
  42 c ______________________________________________________________________
  43 c .        .     .        .                                            .
  44 c .  nom   . e/s . taille .           description                      .
  45 c .____________________________________________________________________.
  46 c . nbfonc . e   .    1   . nombre de fonctions aux points de Gauss    .
  47 c . ngauss . e   .   1    . nbre de points de Gauss des fonctions pg   .
  48 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  49 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  50 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  51 c .        .     .        . 0 : l'entite est absente du profil         .
  52 c .        .     .        . i : l'entite est au rang i dans le profil  .
  53 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  54 c .        .     .        . 0 : l'entite est absente du profil         .
  55 c .        .     .        . 1 : l'entite est presente dans le profil   .
  56 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  57 c . filqua . e   . nbquto . premier fils des quadrangles               .
  58 c . nbanqu . e   .   1    . nombre de quadrangles decoupes par         .
  59 c .        .     .        . conformite sur le maillage avant adaptation.
  60 c . anfiqu . e   . nbanqu . tableau filqua du maillage de l'iteration n.
  61 c . anhequ . e   . nbanqu . tableau hetqua du maillage de l'iteration n.
  62 c . nqueca . e   .   *    . nro des quadrangles dans le calcul en ent. .
  63 c . nqusca . e   . rsquto . numero des quadrangles du calcul           .
  64 c . nbantr . e   .   1    . nombre de triangles issus du decoupage par .
  65 c .        .     .        . conformite sur le maillage avant adaptation.
  66 c . anfatr . e   . nbantr . tableau famtri du maillage de l'iteration n.
  67 c . ntreca . e   .   *    . nro des triangles dans le calcul en entree .
  68 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  69 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  70 c .        .     .    *   .                                            .
  71 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  72 c .        .     .    *   .                                            .
  73 c . vatren .   e . nbfonc*. variables en entree de l'adaptation pour   .
  74 c .        .     .    *   . les triangles de conformite                .
  75 c . vatrtt .   a . nbfonc*. tableau temporaire de la solution pour     .
  76 c .        .     .    *   . les triangles de conformite                .
  77 c . prftrn . es  .   *    . En numero du calcul a l'iteration n   :    .
  78 c .        .     .        . 0 : le triangle est absent du profil       .
  79 c .        .     .        . 1 : le triangle est present dans le profil .
  80 c . prftrp . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  81 c .        .     .        . 0 : le triangle est absent du profil       .
  82 c .        .     .        . 1 : le triangle est present dans le profil .
  83 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  84 c . langue . e   .    1   . langue des messages                        .
  85 c .        .     .        . 1 : francais, 2 : anglais                  .
  86 c . codret . es  .    1   . code de retour des modules                 .
  87 c .        .     .        . 0 : pas de probleme                        .
  88 c .        .     .        . 1 : probleme                               .
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 0. declarations et dimensionnement
  93 c====
  94 c
  95 c 0.1. ==> generalites
  96 c
  97       implicit none
  98       save
  99 c
 100       character*6 nompro
 101       parameter ( nompro = 'PCEQU2' )
 102 c
 103 #include "nblang.h"
 104 c
 105       integer nbnoqu
 106       parameter ( nbnoqu = 8 )
 107       integer nbnotr
 108       parameter ( nbnotr = 6 )
 109 c
 110 #include "fracta.h"
 111 #include "fractb.h"
 112 #include "fractc.h"
 113 #include "fractf.h"
 114 #include "fractg.h"
 115 #include "fracth.h"
 116 c
 117 c 0.2. ==> communs
 118 c
 119 #include "envex1.h"
 120 c
 121 #include "nombqu.h"
 122 #include "nombsr.h"
 123 #include "nomber.h"
 124 c
 125 c 0.3. ==> arguments
 126 c
 127       integer nbfonc
 128       integer ngauss
 129       integer prfcan(*), prfcap(*)
 130       integer hetqua(nbquto), ancqua(*)
 131       integer filqua(nbquto)
 132       integer nbanqu, anfiqu(nbanqu), anhequ(nbanqu)
 133       integer nbantr, anfatr(nbantr)
 134       integer nqueca(requto), nqusca(rsquto)
 135       integer ntreca(retrto), ntrsca(rstrto)
 136       integer prftrn(*), prftrp(*)
 137 c
 138       double precision vafoen(nbfonc,nbnoqu,*)
 139       double precision vafott(nbfonc,nbnoqu,*)
 140       double precision vatren(nbfonc,nbnotr,*)
 141       double precision vatrtt(nbfonc,nbnotr,*)
 142 c
 143       logical deraff
 144 c
 145       integer ulsort, langue, codret
 146 c
 147 c 0.4. ==> variables locales
 148 c
 149       integer iaux
 150 c
 151 c     qucn   = QUadrangle courant en numerotation Calcul a l'it. N
 152 c     qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1
 153 c     quhn   = QUadrangle courant en numerotation Homard a l'it. N
 154 c     quhnp1 = QUadrangle courant en numerotation Homard a l'it. N+1
 155 c
 156       integer qucn, qucnp1, quhn, quhnp1
 157 c
 158 c     f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1
 159 c     fihp = Fils ieme du triangle en numerotation Homard a l'it. N+1
 160 c     f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1
 161 c     f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1
 162 c     f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1
 163 c     f4cp = Fils 4eme du quadrangle en numerotation Calcul a l'it. N+1
 164 c
 165       integer f1hp, f1fhp
 166       integer f1cp, f2cp, f3cp, f4cp
 167       integer f1fcp, f2fcp, f3fcp
 168 c
 169 c     f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N
 170 c     f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N
 171 c     f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N
 172 c     f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N
 173 c     f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N
 174 c
 175       integer f1hn
 176       integer f1cn, f2cn, f3cn, f4cn
 177 c
 178 c
 179       integer prqucn, prf1cn, prf2cn, prf3cn, prf4cn
 180 c
 181 c     etan   = ETAt du quadrangle a l'iteration N
 182 c     etanp1 = ETAt du quadrangle a l'iteration N+1
 183 c
 184       integer etan, etanp1
 185 c
 186 c     qi   = numero local du i-eme noeud du quadrangle, en fonction
 187 c           de l'orientation
 188       integer q1,  q2,   q3,   q4,   q5,   q6, q7, q8
 189       integer q1t, q2t,  q3t,  q4t,  q5t,  q6t
 190       integer q1tp,q2tp, q3tp, q4tp, q5tp, q6tp
 191
 192       integer g1, g2, g3, d1, d2, d3
 193       integer pf, prfg2n, prfg1n, prfg3n, prfd2n, prfd1n, prfd3n
 194 c
 195       integer nrofon
 196 c
 197       integer nbmess
 198       parameter ( nbmess = 10 )
 199       character*80 texte(nblang,nbmess)
 200 c
 201 c 0.5. ==> initialisations
 202 c ______________________________________________________________________
 203 c
 204 c====
 205 c 1. initialisations
 206 c====
 207 c
 208 #include "pcimp0.h"
 209 #include "impr01.h"
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,texte(langue,1)) 'Entree', nompro
 213       call dmflsh (iaux)
 214       write(ulsort,*) 'nbfonc, ngauss, nbquto = ',nbfonc, ngauss, nbquto
 215       write(ulsort,*) 'nbnotr, nbnoqu = ',nbnotr, nbnoqu
 216 #endif
 217 c
 218       texte(1,4) =
 219      >'(/,''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)'
 220       texte(1,5) =
 221      > '(  ''                etat a l''''iteration '',a3,''   : '',i4)'
 222 c
 223       texte(2,4) =
 224      >'(/,''Current quadrangle : # at iteration '',a3,''     : '',i10)'
 225       texte(2,5) =
 226      > '(  ''              status at iteration '',a3,'' : '',i4)'
 227 c
 228       codret = 0
 229 cgn      print 1789, (nqusca(iaux),iaux=1,rsquto)
 230 cgn 1789 format(10i4)
 231 c
 232 c====
 233 c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1
 234 c    on trie en fonction de l'etat du quadrcangle dans le maillage n
 235 c    on numerote les paragraphes en fonction de la documentation, a
 236 c    savoir : le paragraphe doc.n.p traite de la mise a jour de solution
 237 c    pour un quadrangle dont l'etat est passe de n a p.
 238 c    les autres paragraphes sont numerotes classiquement
 239 c====
 240 c
 241       if ( nbfonc.ne.0 ) then
 242 c
 243       do 20 , quhnp1 = 1 , nbquto
 244 c
 245         if ( codret.eq.0 ) then
 246 c
 247 c 2.1. ==> caracteristiques du quadrangle :
 248 c 2.1.1. ==> son numero homard dans le maillage precedent
 249 c
 250         if ( deraff ) then
 251           quhn = ancqua(quhnp1)
 252         else
 253           quhn = quhnp1
 254         endif
 255 c
 256 c 2.1.2. ==> l'historique de son etat
 257 c          On rappelle que l'etat vaut :
 258 c          etan = 0 : le quadrangle etait actif
 259 c          etan = 4 : le quadrangle etait coupe en 4 ; il y a eu
 260 c                     deraffinement.
 261 c          etan = 55 : le quadrangle n'existait pas ; il a ete produit
 262 c                      par un decoupage.
 263 c          etan = 31, 32, 33, 34 : le quadrangle etait coupe en 3
 264 c                                  triangles ; il y a eu deraffinement.
 265 c
 266         etanp1 = mod(hetqua(quhnp1),100)
 267         etan   = (hetqua(quhnp1)-etanp1) / 100
 268 c
 269 cgn        write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1
 270 c
 271 c 2.1.3. ==> les numeros locaux des noeuds
 272 c
 273         q1 = 1
 274         q2 = 2
 275         q3 = 3
 276         q4 = 4
 277         q5 = 5
 278         q6 = 6
 279         q7 = 7
 280         q8 = 8
 281 cgn            print *,'qi =',q1,q2,q3,q4,q5,q6,q7,q8
 282 c
 283
 284 c=======================================================================
 285 c doc.0.p. ==> etan = 0 : le quadrangle etait actif
 286 c=======================================================================
 287 c
 288         if ( etan.eq.0 ) then
 289 c
 290 c         on repere son ancien numero dans le calcul
 291 c
 292           qucn = nqueca(quhn)
 293           prqucn = prfcan(qucn)
 294 c
 295           if ( prqucn.gt.0 ) then
 296 c
 297 cgn          print 1789,(vafoen(nrofon,iaux,qucn), iaux = 1 , nbnoqu)
 298 cgn 1789 format('  Valeurs anciennes  :  ',5g12.5)
 299 c
 300 c doc.0.0. ===> etanp1 = 0 : le quadrangle etait actif et l'est encore ;
 301 c               il est inchange
 302 c
 303 c           .................         .................
 304 c           .               .         .               .
 305 c           .               .         .               .
 306 c           .               .         .               .
 307 c           .               .  ===>   .               .
 308 c           .               .         .               .
 309 c           .               .         .               .
 310 c           .               .         .               .
 311 c           .................         .................
 312 c
 313           if ( etanp1.eq.0 ) then
 314 c
 315             qucnp1 = nqusca(quhnp1)
 316             prfcap(qucnp1) = 1
 317 c
 318             do 221 , nrofon = 1 , nbfonc
 319 cgn      write(ulsort,7778)
 320 cgn     > (vafoen(nrofon,iaux,prfcan(qucn)),iaux = 1 , nbnoqu)
 321               do 2211 , iaux = 1 , nbnoqu
 322                 vafott(nrofon,iaux,qucnp1) =
 323      >                                vafoen(nrofon,iaux,prqucn)
 324  2211         continue
 325   221       continue
 326 cgn        write(21,7777) qucnp1
 327 cgn        write(ulsort,7777) qucn,-1,qucnp1
 328 cgn 7777   format(I3)
 329 cgn 7778   format(8g14.7)
 330 c
 331 c doc.0.1/2/3 ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle etait actif
 332 c                 et est decoupe en 3 triangles.
 333 c           .................         .................
 334 c           .               .         .      . .      .
 335 c           .               .         .     .   .     .
 336 c           .               .         .    .     .    .
 337 c           .               .  ===>   .   .       .   .
 338 c           .               .         .  .         .  .
 339 c           .               .         . .           . .
 340 c           .               .         ..             ..
 341 c           .................         .................
 342 c
 343           elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
 344 c
 345 #include "pcsqu2_1.h"
 346 c
 347 c doc.0.4/6/7/8. ==> etanp1 = 4 : le quadrangle etait actif et
 348 c                    est decoupe en 4.
 349 c           .................         .................
 350 c           .               .         .       .       .
 351 c           .               .         .       .       .
 352 c           .               .         .       .       .
 353 c           .               .  ===>   .................
 354 c           .               .         .       .       .
 355 c           .               .         .       .       .
 356 c           .               .         .       .       .
 357 c           .................         .................
 358 c
 359           elseif ( etanp1.eq.4 ) then
 360 c
 361 #include "pcsqu2_2.h"
 362
 363 c doc.0.erreur. ==> aucun autre etat sur le quadrangle courant n'est
 364 c                   possible
 365 c
 366           else
 367 c
 368             codret = codret + 1
 369             write (ulsort,texte(langue,4)) 'n  ', quhn
 370             write (ulsort,texte(langue,5)) 'n  ', etan
 371             write (ulsort,texte(langue,4)) 'n+1', quhnp1
 372             write (ulsort,texte(langue,5)) 'n+1', etanp1
 373 c
 374           endif
 375 c
 376           endif
 377 c
 378 c=======================================================================
 379 c doc.1/2/3.p. ==> etan = 31, 32, 33 ou 34 : le quadrangle etait coupe
 380 c                  en 3 triangles
 381 c=======================================================================
 382 c
 383         elseif ( etan.ge.31 .and. etan.le.34 ) then
 384 c
 385 cgn          print *,'etan.ge.31 .and. etan.le.34'
 386 c         on repere les numeros dans le calcul pour ses trois fils a
 387 c         l'iteration n
 388 c
 389           f1hn = -anfiqu(quhn)
 390           f1cn = ntreca(f1hn)
 391           f2cn = ntreca(f1hn+1)
 392           f3cn = ntreca(f1hn+2)
 393           prf1cn = prftrn(f1cn)
 394           prf2cn = prftrn(f2cn)
 395           prf3cn = prftrn(f3cn)
 396 c
 397           q1t = 1
 398           q2t = 2
 399           q3t = 3
 400           q4t = 4
 401           q5t = 5
 402           q6t = 6
 403 c
 404           if ( prf1cn.gt.0 .and. prf2cn.gt.0 .and.
 405      >         prf3cn.gt.0 ) then
 406 c
 407 c doc.1/2/3.0. ===> etanp1 = 0 : le quadrangle est actif. il est
 408 c                   reactive.
 409 c                   on lui attribue la valeur moyenne sur les trois
 410 c                   anciens fils.
 411 c        remarque : cela arrive seulement avec du deraffinement.
 412 c           .................         .................
 413 c           .      . .      .         .               .
 414 c           .     .   .     .         .               .
 415 c           .    .     .    .         .               .
 416 c           .   .       .   .  ===>   .               .
 417 c           .  .         .  .         .               .
 418 c           . .           . .         .               .
 419 c           ..             ..         .               .
 420 c           .................         .................
 421 c
 422           if ( etanp1.eq.0 ) then
 423 c
 424 cgn            print *,'.. etanp1.eq.0'
 425 c
 426 #include "pcsqu2_3.h"
 427 c
 428 c doc.1/2/3.1/2/3. ===> etanp1 = etan : le quadrangle est decoupe en
 429 c                       trois selon le meme decoupage.
 430 c             c'est ce qui se passe quand un decoupage de conformite
 431 c             est supprime au debut des algorithmes d'adaptation,
 432 c             puis reproduit a la creation du maillage car les
 433 c             quadrangles autour n'ont pas change entre les deux
 434 c             iterations.
 435 c             Comme la procedure de numerotation est la meme (voir
 436 c             cmcdqu), le premier fils est toujours le meme, le 2eme et
 437 c             le 3eme egalement.
 438 c             on prendra alors les valeurs sur les fils de rang
 439 c             identique a l'iteration n.
 440 c           .................         .................
 441 c           .      . .      .         .      . .      .
 442 c           .     .   .     .         .     .   .     .
 443 c           .    .     .    .         .    .     .    .
 444 c           .   .       .   .  ===>   .   .       .   .
 445 c           .  .         .  .         .  .         .  .
 446 c           . .           . .         . .           . .
 447 c           ..             ..         ..             ..
 448 c           .................         .................
 449 c
 450           elseif ( etanp1.eq.etan ) then
 451 cgn            print *,'.. etanp1.eq.etan'
 452 c
 453             f1hp = -filqua(quhnp1)
 454 c
 455             q1tp = 1
 456             q2tp = 2
 457             q3tp = 3
 458             q4tp = 4
 459             q5tp = 5
 460             q6tp = 6
 461 c
 462             f1cp = ntrsca(f1hp)
 463             f2cp = ntrsca(f1hp+1)
 464             f3cp = ntrsca(f1hp+2)
 465             prftrp(f1cp) = 1
 466             prftrp(f2cp) = 1
 467             prftrp(f3cp) = 1
 468 c
 469             do 232 , nrofon = 1 , nbfonc
 470 c
 471               vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q1t,prf1cn)
 472               vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q2t,prf1cn)
 473               vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf1cn)
 474               vatrtt(nrofon,q4tp,f1cp) = vatren(nrofon,q4t,prf1cn)
 475               vatrtt(nrofon,q5tp,f1cp) = vatren(nrofon,q5t,prf1cn)
 476               vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf1cn)
 477 c
 478               vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf2cn)
 479               vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q2t,prf2cn)
 480               vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q3t,prf2cn)
 481               vatrtt(nrofon,q4tp,f2cp) = vatren(nrofon,q4t,prf2cn)
 482               vatrtt(nrofon,q5tp,f2cp) = vatren(nrofon,q5t,prf2cn)
 483               vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q6t,prf2cn)
 484 c
 485               vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q1t,prf3cn)
 486               vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q2t,prf3cn)
 487               vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q3t,prf3cn)
 488               vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q4t,prf3cn)
 489               vatrtt(nrofon,q5tp,f3cp) = vatren(nrofon,q5t,prf3cn)
 490               vatrtt(nrofon,q6tp,f3cp) = vatren(nrofon,q6t,prf3cn)
 491 c
 492   232       continue
 493 c
 494 c doc.1/2/3.perm(1/2/3). ===> etanp1 = 31, 32, 33 ou 34 et different de
 495 c                             etan : le quadrangle est encore decoupe
 496 c                             en trois, mais par un autre decoupage.
 497 c             c'est ce qui se passe quand un decoupage de conformite
 498 c             est supprime au debut des algorithmes d'adaptation. il y
 499 c             a du deraffinement dans la zone qui induisait le decoupage
 500 c             de conformite et raffinement sur une autre zone.
 501 cc             remarque : cela arrive seulement avec du deraffinement.
 502 c
 503 c           .................         .................
 504 c           .      . .      .         ..             ..
 505 c           .     .   .     .         . .           . .
 506 c           .    .     .    .         .  .         .  .
 507 c           .   .       .   .  ===>   .   .       .   .
 508 c           .  .         .  .         .    .     .    .
 509 c           . .           . .         .     .   .     .
 510 c           ..             ..         .      . .      .
 511 c           .................         .................
 512 c
 513           elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
 514 c
 515 cgn            print *,'.. etanp1.ge.31 .and. etanp1.le.34'
 516 #include "pcsqu2_4.h"
 517 c
 518 c doc.1/2/3.4/6/7/8. ===> etanp1 = 4 : le quadrangle est
 519 c                         decoupe en quatre.
 520 c             c'est ce qui se passe quand un decoupage de conformite
 521 c             est supprime au debut des algorithmes d'adaptation. il y
 522 c             a ensuite raffinement du quadrangle. qui plus est, par
 523 c             suite de la regle des ecarts de niveau, on peut avoir
 524 c             induit un decoupage de conformite sur l'un des fils.
 525 c
 526 c           .................         .................
 527 c           .      . .      .         .       .       .
 528 c           .     .   .     .         .       .       .
 529 c           .    .     .    .         .       .       .
 530 c           .   .       .   .  ===>   .................
 531 c           .  .         .  .         .       .       .
 532 c           . .           . .         .       .       .
 533 c           ..             ..         .       .       .
 534 c           .................         .................
 535 c
 536 c
 537           elseif ( etanp1.eq.4 ) then
 538 c
 539 cgn            print *,'.. etanp1.eq.4'
 540 c
 541 #include "pcsqu2_5.h"
 542 c
 543 c doc.1/2/3.erreur. ==> aucun autre etat sur le quadrangle courant
 544 c                       n'est possible
 545 c
 546           else
 547 c
 548             codret = codret + 1
 549             write (ulsort,texte(langue,4)) 'n  ', quhn
 550             write (ulsort,texte(langue,5)) 'n  ', etan
 551             write (ulsort,texte(langue,4)) 'n+1', quhnp1
 552             write (ulsort,texte(langue,5)) 'n+1', etanp1
 553 c
 554           endif
 555 c
 556           endif
 557 c
 558 c=======================================================================
 559 c doc.4. ==> le quadrangle etait coupe en 4 :
 560 c=======================================================================
 561 c
 562         elseif ( etan.eq.4 ) then
 563 c
 564 c         on repere les numeros dans le calcul pour ses quatre fils
 565 c         a l'iteration n
 566 c
 567           f1hn = anfiqu(quhn)
 568           f1cn = nqueca(f1hn)
 569           f2cn = nqueca(f1hn+1)
 570           f3cn = nqueca(f1hn+2)
 571           f4cn = nqueca(f1hn+3)
 572           prf1cn = prfcan(f1cn)
 573           prf2cn = prfcan(f2cn)
 574           prf3cn = prfcan(f3cn)
 575           prf4cn = prfcan(f4cn)
 576 c
 577           if ( prf1cn.gt.0 .and. prf2cn.gt.0 .and.
 578      >         prf3cn.gt.0 .and. prf4cn.gt.0 ) then
 579 c
 580 c doc.4.0. ===> etanp1 = 0 : le quadrangle est actif ; il est reactive.
 581 c               remarque : cela arrive seulement avec du deraffinement.
 582 c           .................         .................
 583 c           .       .       .         .               .
 584 c           .       .       .         .               .
 585 c           .       .       .         .               .
 586 c           .................  ===>   .               .
 587 c           .       .       .         .               .
 588 c           .       .       .         .               .
 589 c           .       .       .         .               .
 590 c           .................         .................
 591 c
 592           if ( etanp1.eq.0 ) then
 593 c
 594             qucnp1 = nqusca(quhnp1)
 595             prfcap(qucnp1) = 1
 596 c
 597             do 241 , nrofon = 1 , nbfonc
 598 c
 599               vafott(nrofon,q1,qucnp1) = vafoen(nrofon,q1,prf1cn)
 600               vafott(nrofon,q2,qucnp1) = vafoen(nrofon,q1,prf2cn)
 601               vafott(nrofon,q3,qucnp1) = vafoen(nrofon,q1,prf3cn)
 602               vafott(nrofon,q4,qucnp1) = vafoen(nrofon,q1,prf4cn)
 603               vafott(nrofon,q5,qucnp1) =
 604      >                          unsde*(vafoen(nrofon,q2,prf1cn)+
 605      >                                 vafoen(nrofon,q4,prf2cn))
 606               vafott(nrofon,q6,qucnp1) =
 607      >                          unsde*(vafoen(nrofon,q2,prf2cn)+
 608      >                                 vafoen(nrofon,q4,prf3cn))
 609               vafott(nrofon,q7,qucnp1) =
 610      >                          unsde*(vafoen(nrofon,q2,prf3cn)+
 611      >                                 vafoen(nrofon,q4,prf4cn))
 612               vafott(nrofon,q8,qucnp1) =
 613      >                          unsde*(vafoen(nrofon,q2,prf4cn)+
 614      >                                 vafoen(nrofon,q4,prf1cn))
 615 c
 616   241       continue
 617 c
 618 c doc.4.1/2/3. ===> etanp1 = 31, 32, 33 ou 34 : le quadrangle est
 619 c             decoupe en trois.
 620 c             remarque : cela arrive seulement avec du deraffinement.
 621 c           .................         .................
 622 c           .       .       .         .      . .      .
 623 c           .       .       .         .     .   .     .
 624 c           .       .       .         .    .     .    .
 625 c           .................  ===>   .   .       .   .
 626 c           .       .       .         .  .         .  .
 627 c           .       .       .         . .           . .
 628 c           .       .       .         ..             ..
 629 c           .................         .................
 630 c
 631           elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
 632 cgn            print *,'etanp1.ge.31 .and. etanp1.le.34'
 633 c
 634 #include "pcsqu2_6.h"
 635 c
 636           elseif ( etanp1.eq.4 .or. etanp1.eq.99 ) then
 637 c
 638             codret = codret
 639 c
 640           else
 641 c
 642             codret = codret + 1
 643             write (ulsort,texte(langue,4)) 'n  ', quhn
 644             write (ulsort,texte(langue,5)) 'n  ', etan
 645             write (ulsort,texte(langue,4)) 'n+1', quhnp1
 646             write (ulsort,texte(langue,5)) 'n+1', etanp1
 647           endif
 648 c
 649           endif
 650 c
 651 c=======================================================================
 652 c doc.4. ==> le quadrangle etait coupe en 4 et au moins un de ses
 653 c            fils etait lui-meme decoupe :
 654 c=======================================================================
 655 c
 656         elseif ( etan.eq.99 ) then
 657 c
 658 #include "pcsqu2_7.h"
 659 c
 660         endif
 661 c
 662         endif
 663 c
 664    20 continue
 665 c
 666       endif
 667 c
 668 c====
 669 c 3. la fin
 670 c====
 671 c
 672 cgn      do 922 , nrofon = 1 , nbfonc
 673 cgn        print *,'fonction numero ', nrofon
 674 cgn        iaux = 0
 675 cgn        do 9222 , quhnp1 = 1 , nbtrto
 676 cgn           if ( mod(hettri(quhnp1),100).eq.0 ) then
 677 cgn           iaux = iaux+1
 678 cgn          print 1788,quhnp1,
 679 cgn     >     (vafott(nrofon,nugaus,iaux), nugaus = 1 , ngauss)
 680 cgn           endif
 681 cgn 9222   continue
 682 cgn  922 continue
 683 c
 684       if ( codret.ne.0 ) then
 685 c
 686 #include "envex2.h"
 687 c
 688       write (ulsort,texte(langue,1)) 'Sortie', nompro
 689       write (ulsort,texte(langue,2)) codret
 690 c
 691       endif
 692 c
 693 #ifdef _DEBUG_HOMARD_
 694       write (ulsort,texte(langue,1)) 'Sortie', nompro
 695       call dmflsh (iaux)
 696 #endif
 697 c
 698       end
 699