src/tool/AP_Conversion/pcset2.F

   1       subroutine pcset2 ( etan, etanp1, tehn, tehnp1, typint,
   2      >                    prfcan, prfcap,
   3      >                    hettet, filtet, nbante, anfite,
   4      >                    nteeca, ntesca,
   5      >                    nbfonc, vafoen, vafott,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    aPres adaptation - Conversion de Solution Elements de volume -
  28 c     -                 -             -        -
  29 c                       Tetraedres d'etat anterieur 2
  30 c                       -                           -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . etan   . e   .    1   . ETAt du tetraedre a l'iteration N          .
  36 c . etanp1 . e   .    1   . ETAt du tetraedre a l'iteration N+1        .
  37 c . tehn   . e   .    1   . TEtraedre courant en numerotation Homard   .
  38 c .        .     .        . a l'iteration N                            .
  39 c . tehnp1 . e   .    1   . TEtraedre courant en numerotation Homard   .
  40 c .        .     .        . a l'iteration N+1                          .
  41 c . typint . e   .   1    . type d'interpolation                       .
  42 c .        .     .        .  0, si automatique                         .
  43 c .        .     .        .  elements : 0 si intensif, sans orientation.
  44 c .        .     .        .             1 si extensif, sans orientation.
  45 c .        .     .        .             2 si intensif, avec orientation.
  46 c .        .     .        .             3 si extensif, avec orientation.
  47 c .        .     .        .  noeuds : 1 si degre 1                     .
  48 c .        .     .        .           2 si degre 2                     .
  49 c .        .     .        .           3 si iso-P2                      .
  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 . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  57 c . filtet . e   . nbteto . premier fils des tetraedres                .
  58 c . nbante . e   .   1    . nombre de tetraedres decoupes par   .
  59 c .        .     .        . conformite sur le maillage avant adaptation.
  60 c . anfite . e   . nbante . tableau filtet du maillage de l'iteration n
  61 c . nteeca . e   . reteto . numero des tetraedres dans le calcul entree.
  62 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
  63 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  64 c . vafoen . e   . nbfonc*. variables en entree de l'adaptation        .
  65 c .        .     . nbeven .                                            .
  66 c . vafott . es  . nbfonc*. variables en sortie de l'adaptation        .
  67 c .        .     . nbevso .                                            .
  68 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  69 c . langue . e   .    1   . langue des messages                        .
  70 c .        .     .        . 1 : francais, 2 : anglais                  .
  71 c . codret . es  .    1   . code de retour des modules                 .
  72 c .        .     .        . 0 : pas de probleme                        .
  73 c .        .     .        . 1 : probleme                               .
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 0. declarations et dimensionnement
  78 c====
  79 c
  80 c 0.1. ==> generalites
  81 c
  82       implicit none
  83       save
  84 c
  85       character*6 nompro
  86       parameter ( nompro = 'PCSET2' )
  87 c
  88 #include "nblang.h"
  89 #include "fracta.h"
  90 #include "fractc.h"
  91 #include "fractf.h"
  92 #include "fractg.h"
  93 #include "fracth.h"
  94 c
  95 c 0.2. ==> communs
  96 c
  97 #include "nombte.h"
  98 #include "nombsr.h"
  99 #include "nomber.h"
 100 c
 101 c 0.3. ==> arguments
 102 c
 103       integer etan, etanp1, tehn, tehnp1
 104       integer typint
 105       integer nbfonc
 106       integer prfcan(*), prfcap(*)
 107       integer hettet(nbteto), filtet(nbteto)
 108       integer nbante
 109       integer anfite(nbante)
 110       integer nteeca(reteto), ntesca(rsteto)
 111 c
 112       double precision vafoen(nbfonc,*)
 113       double precision vafott(nbfonc,*)
 114 c
 115       integer ulsort, langue, codret
 116 c
 117 c 0.4. ==> variables locales
 118 c
 119 c     tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1
 120 c
 121       integer tecnp1
 122 c
 123 c     f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1
 124 c     fihp = Fils ieme u tetraedre en numerotation Homard a l'it. N+1
 125 c     f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1
 126 c     f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1
 127 c     f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1
 128 c     f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1
 129 c
 130       integer f1hp, fihp
 131       integer f1cp, f2cp, f3cp, f4cp
 132 c
 133 c     f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N
 134 c     f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N
 135 c     f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N
 136 c
 137       integer f1hn
 138       integer f1cn, f2cn
 139 c
 140 c     f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1
 141 c     f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1
 142 c     f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1
 143 c     f4fcp = Fils 4eme du Fils en numerotation Calcul a l'it. N+1
 144 c
 145       integer f1fcp, f2fcp, f3fcp, f4fcp
 146 c
 147       integer nrofon
 148       integer coderr
 149 c
 150       integer iaux
 151       integer lglist, nrlist
 152       integer list(30)
 153 c
 154       double precision daux
 155       double precision daux1
 156 c
 157       integer nbmess
 158       parameter ( nbmess = 10 )
 159       character*80 texte(nblang,nbmess)
 160 c
 161 c 0.5. ==> initialisations
 162 c ______________________________________________________________________
 163 c
 164 c====
 165 c 1. initialisations
 166 c====
 167 c
 168 #include "impr01.h"
 169 c
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,texte(langue,1)) 'Entree', nompro
 172       call dmflsh (iaux)
 173 #endif
 174 c
 175       texte(1,4) =
 176      >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)'
 177       texte(1,5) =
 178      >'(  ''                  etat a l''''iteration '',a3,''   : '',i4)'
 179 c
 180       texte(2,4) =
 181      >'(/,''Current tetrahedron : # at iteration '',a3,''     : '',i10)'
 182       texte(2,5) =
 183      > '(  ''                     status at iteration '',a3,'' : '',i4)'
 184 c
 185       coderr = 0
 186 c
 187 c 1.2. ==> on repere les numeros dans le calcul pour ses deux fils
 188 c          a l'iteration n
 189 c
 190       f1hn = anfite(tehn)
 191       f1cn = nteeca(f1hn)
 192       f2cn = nteeca(f1hn+1)
 193 c
 194       if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then
 195 c
 196 c====
 197 c 2. Le tetraedre etait coupe en 2
 198 c    On explore tous les etats du tetraedre a l'iteration n+1
 199 c====
 200 c
 201 c 2.1. ==> etanp1 = 0 : le tetraedre est reactive.
 202 c             remarque : cela arrive seulement avec du deraffinement.
 203 c
 204       if ( etanp1.eq.0 ) then
 205 c
 206         tecnp1 = ntesca(tehnp1)
 207         prfcap(tecnp1) = 1
 208         if ( typint.eq.0 ) then
 209           daux1 = unsde
 210         else
 211           daux1 = 1.d0
 212         endif
 213         do 21 , nrofon = 1, nbfonc
 214           daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 215      >                   + vafoen(nrofon,prfcan(f2cn)) )
 216           vafott(nrofon,tecnp1) = daux
 217    21   continue
 218 c
 219 c 2.1. ==> etanp1 = etan : le tetraedre est decoupe en deux
 220 c                       selon le meme decoupage.
 221 c             c'est ce qui se passe quand un decoupage de conformite
 222 c             est supprime au debut des algorithmes d'adaptation,
 223 c             puis reproduit a la creation du maillage car les faces
 224 c             autour n'ont pas change entre les deux iterations.
 225 c             le fils prend la valeur de la fonction sur l'ancien
 226 c             fils qui etait au meme endroit. comme la procedure de
 227 c             numerotation est la meme (voir cmcdte), le premier fils
 228 c             est toujours le meme, le second egalement. on prendra
 229 c             alors la valeur sur le fils de rang identique a
 230 c             l'iteration n.
 231 c
 232       elseif ( etanp1.eq.etan ) then
 233 c
 234         f1hp = filtet(tehnp1)
 235         f1cp = ntesca(f1hp)
 236         f2cp = ntesca(f1hp+1)
 237         prfcap(f1cp) = 1
 238         prfcap(f2cp) = 1
 239         do 22 , nrofon = 1, nbfonc
 240           vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn))
 241           vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn))
 242    22   continue
 243 cgn        write(22,7777) f1cp,f2cp
 244 cgn        write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp
 245 c
 246 c 2.3. ==> etanp1 = 21, ..., 26 et different de etan :
 247 c          le tetraedre est encore decoupe en 2 par un autre decoupage.
 248 c             c'est ce qui se passe quand un decoupage de conformite
 249 c             est supprime au debut des algorithmes d'adaptation. il y
 250 c             a du deraffinement dans la zone qui induisait le decoupage
 251 c             de conformite et raffinement sur une autre zone.
 252 c             on donne la valeur moyenne de la fonction sur les deux
 253 c             anciens fils a chaque nouveau fils.
 254 c             remarque : on pourrait certainement faire mieux, avec des
 255 c                        moyennes ponderees en fonction du recouvrement
 256 c                        des anciens et nouveaux fils. c'est trop
 257 c                        complique pour que cela vaille le coup.
 258 c             remarque : cela arrive seulement avec du deraffinement.
 259 c
 260       elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then
 261 c
 262         f1hp = filtet(tehnp1)
 263         f1cp = ntesca(f1hp)
 264         f2cp = ntesca(f1hp+1)
 265         prfcap(f1cp) = 1
 266         prfcap(f2cp) = 1
 267         do 23 , nrofon = 1, nbfonc
 268           daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 269      >                   + vafoen(nrofon,prfcan(f2cn)) )
 270           vafott(nrofon,f1cp) = daux
 271           vafott(nrofon,f2cp) = daux
 272    23   continue
 273 cgn        write(23,7777) f1cp,f2cp
 274 cgn        write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp
 275 c
 276 c 2.4. ==> etanp1 = 41, 42, 43 ou 44 : le tetraedre est
 277 c                      decoupe en quatre par une face.
 278 c 2.5. ==> etanp1 = 45, 46 ou 47 : le tetraedre est
 279 c                      decoupe en quatre par une diagonale.
 280 c             c'est ce qui se passe quand un decoupage de conformite
 281 c             est supprime au debut des algorithmes d'adaptation, puis
 282 c             remis differement car l'environnement a change.
 283 c             on donne la valeur moyenne de la fonction sur les deux
 284 c             anciens fils a chaque nouveau fils.
 285 c             remarque : on pourrait certainement faire mieux, avec des
 286 c                        moyennes ponderees en fonction du recouvrement
 287 c                        des anciens et nouveaux fils. c'est trop
 288 c                        complique pour que cela vaille le coup.
 289 c
 290       elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then
 291 c
 292         f1hp = filtet(tehnp1)
 293         f1cp = ntesca(f1hp)
 294         f2cp = ntesca(f1hp+1)
 295         f3cp = ntesca(f1hp+2)
 296         f4cp = ntesca(f1hp+3)
 297         prfcap(f1cp) = 1
 298         prfcap(f2cp) = 1
 299         prfcap(f3cp) = 1
 300         prfcap(f4cp) = 1
 301         if ( typint.eq.0 ) then
 302           daux1 = unsde
 303         else
 304           daux1 = unsqu
 305         endif
 306         do 24 , nrofon = 1, nbfonc
 307           daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 308      >                   + vafoen(nrofon,prfcan(f2cn)) )
 309           vafott(nrofon,f1cp) = daux
 310           vafott(nrofon,f2cp) = daux
 311           vafott(nrofon,f3cp) = daux
 312           vafott(nrofon,f4cp) = daux
 313    24   continue
 314 cgn        write(24,7777) f1cp,f2cp,f3cp,f4cp
 315 cgn        write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp,f3cp,f4cp
 316 c
 317 c 2.6. ==> etanp1 = 85, 86 ou 87 : le tetraedre est
 318 c                      decoupe en huit par une diagonale.
 319 c             c'est ce qui se passe quand un decoupage de conformite
 320 c             est supprime au debut des algorithmes d'adaptation, puis
 321 c             le tetraedre a ete decoupe en standard.
 322 c             on donne la valeur moyenne de la fonction sur les deux
 323 c             anciens fils a chaque nouveau fils.
 324 c             attention : il est possible que les fils sur les bords
 325 c                         soient decoupes par de la conformite. Il faut
 326 c                         alors transmettre la valeur a leurs 2 ou 4
 327 c                         fils.
 328 c             attention : ce n'est pas comme en 2D ; il faut examiner
 329 c                         tous les fils, car par contamination de faces
 330 c                         coupees en 2, les fils centraux peuvent etre
 331 c                         decoupes.
 332 c             remarque : on pourrait certainement faire mieux, avec des
 333 c                        moyennes ponderees en fonction du recouvrement
 334 c                        des anciens et nouveaux fils. c'est trop
 335 c                        complique pour que cela vaille le coup.
 336 c
 337       elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then
 338 c
 339         f1hp = filtet(tehnp1)
 340         if ( typint.eq.0 ) then
 341 c
 342           lglist = 0
 343           do 250 , nrlist = 1 , 8
 344             fihp = f1hp+nrlist-1
 345             iaux = mod(hettet(fihp),100)
 346             if ( iaux.eq.0 ) then
 347               lglist = lglist + 1
 348               list(lglist) = ntesca(fihp)
 349             elseif ( iaux.ge.21 .and. iaux.le.26 ) then
 350               lglist = lglist + 1
 351               list(lglist) = ntesca(filtet(fihp))
 352               lglist = lglist + 1
 353               list(lglist) = ntesca(filtet(fihp)+1)
 354             elseif ( iaux.ge.41 .and. iaux.le.47 ) then
 355               lglist = lglist + 1
 356               list(lglist) = ntesca(filtet(fihp))
 357               lglist = lglist + 1
 358               list(lglist) = ntesca(filtet(fihp)+1)
 359               lglist = lglist + 1
 360               list(lglist) = ntesca(filtet(fihp)+2)
 361               lglist = lglist + 1
 362               list(lglist) = ntesca(filtet(fihp)+3)
 363             else
 364               coderr = 1
 365             endif
 366   250     continue
 367 c
 368           do 260 , nrlist = 1 , lglist
 369             prfcap(list(nrlist)) = 1
 370   260     continue
 371 c
 372           do 270 , nrofon = 1, nbfonc
 373             daux = unsde * ( vafoen(nrofon,prfcan(f1cn))
 374      >                     + vafoen(nrofon,prfcan(f2cn)) )
 375             do 2701 , nrlist = 1 , lglist
 376               vafott(nrofon,list(nrlist)) = daux
 377  2701       continue
 378   270     continue
 379 c
 380         else
 381 c
 382           do 251 , nrlist = 1 , 8
 383 c
 384             fihp = f1hp+nrlist-1
 385             iaux = mod(hettet(fihp),100)
 386             if ( iaux.eq.0 ) then
 387               f1cp = ntesca(fihp)
 388               prfcap(f1cp) = 1
 389               do 2511 , nrofon = 1, nbfonc
 390                 daux = unshu * ( vafoen(nrofon,prfcan(f1cn))
 391      >                         + vafoen(nrofon,prfcan(f2cn)) )
 392                 vafott(nrofon,f1cp) = daux
 393  2511         continue
 394             elseif ( iaux.ge.21 .and. iaux.le.26 ) then
 395               f1fcp = ntesca(filtet(fihp))
 396               f2fcp = ntesca(filtet(fihp)+1)
 397               prfcap(f1fcp) = 1
 398               prfcap(f2fcp) = 1
 399               do 2512 , nrofon = 1, nbfonc
 400                 daux = unssz * ( vafoen(nrofon,prfcan(f1cn))
 401      >                         + vafoen(nrofon,prfcan(f2cn)) )
 402                 vafott(nrofon,f1fcp) = daux
 403                 vafott(nrofon,f2fcp) = daux
 404  2512         continue
 405             elseif ( iaux.ge.41 .and. iaux.le.47 ) then
 406               f1fcp = ntesca(filtet(fihp))
 407               f2fcp = ntesca(filtet(fihp)+1)
 408               f3fcp = ntesca(filtet(fihp)+2)
 409               f4fcp = ntesca(filtet(fihp)+3)
 410               prfcap(f1fcp) = 1
 411               prfcap(f2fcp) = 1
 412               prfcap(f3fcp) = 1
 413               prfcap(f4fcp) = 1
 414               do 2513 , nrofon = 1, nbfonc
 415                 daux = unstr2 * ( vafoen(nrofon,prfcan(f1cn))
 416      >                          + vafoen(nrofon,prfcan(f2cn)) )
 417                 vafott(nrofon,f1fcp) = daux
 418                 vafott(nrofon,f2fcp) = daux
 419                 vafott(nrofon,f3fcp) = daux
 420                 vafott(nrofon,f4fcp) = daux
 421  2513         continue
 422             else
 423               coderr = 1
 424             endif
 425 c
 426   251     continue
 427 c
 428         endif
 429 c
 430 cgn        write(26,7777) (list(nrlist),nrlist = 1 , lglist)
 431 cgn        write(ulsort,7777) f1cn,f2cn,-1,
 432 cgn     >                     (list(nrlist),nrlist = 1 , lglist)
 433 cgn7777   format(I3)
 434 c
 435 c 2.7. ==> aucun autre etat sur le tetraedre courant
 436 c                       n'est possible
 437 c
 438       else
 439 c
 440         coderr = 1
 441         write (ulsort,texte(langue,4)) 'n  ', tehn
 442         write (ulsort,texte(langue,5)) 'n  ', etan
 443         write (ulsort,texte(langue,4)) 'n+1', tehnp1
 444         write (ulsort,texte(langue,5)) 'n+1', etanp1
 445 c
 446       endif
 447 c
 448       endif
 449 c
 450 c====
 451 c 3. la fin
 452 c====
 453 c
 454       if ( coderr.ne.0 ) then
 455 c
 456         write (ulsort,texte(langue,1)) 'Sortie', nompro
 457       write (ulsort,texte(langue,2)) coderr
 458       codret = codret + 1
 459 c
 460       endif
 461 c
 462       end