src/tool/AP_Conversion/pcseh1.F

   1       subroutine pcseh1 ( etan, etanp1, hehn, hehnp1, typint,
   2      >                    prfcap,
   3      >                    nfpyrn, nftetn, ficn,
   4      >                    nfpyrp, nftetp, ficp, propor,
   5      >                    coonoe,
   6      >                    somare,
   7      >                    aretri,
   8      >                    arequa,
   9      >                    tritet, cotrte, aretet,
  10      >                    quahex, coquhe, arehex,
  11      >                    facpyr, cofapy, arepyr,
  12      >                    hethex, filhex, fhpyte,
  13      >                            nhesca,
  14      >                    ntesca,
  15      >                    npysca,
  16      >                    nbfonc, vafott,
  17      >                    vateen, vatett,
  18      >                    prften, prftep,
  19      >                    vapyen, vapytt,
  20      >                    prfpyn, prfpyp,
  21      >                    ulsort, langue, codret )
  22 c ______________________________________________________________________
  23 c
  24 c                             H O M A R D
  25 c
  26 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  27 c
  28 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  29 c aupres des huissiers de justice Simart et Lavoir a Clamart
  30 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  31 c aupres des huissiers de justice
  32 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  33 c
  34 c    HOMARD est une marque deposee d'Electricite de France
  35 c
  36 c Copyright EDF 1996
  37 c Copyright EDF 1998
  38 c Copyright EDF 2002
  39 c Copyright EDF 2020
  40 c ______________________________________________________________________
  41 c
  42 c    aPres adaptation - Conversion de Solution Elements de volume -
  43 c     -                 -             -        -
  44 c                       Hexaedres - decoupage par conformite avant
  45 c                       -
  46 c remarque : pcseh1 et pcsep1 sont des clones
  47 c ______________________________________________________________________
  48 c .        .     .        .                                            .
  49 c .  nom   . e/s . taille .           description                      .
  50 c .____________________________________________________________________.
  51 c . etan   . e   .    1   . ETAt de l'hexaedre a l'iteration N         .
  52 c . etanp1 . e   .    1   . ETAt de l'hexaedre a l'iteration N+1       .
  53 c . hehn   . e   .    1   . Hexaedre courant en numerotation Homard    .
  54 c .        .     .        . a l'iteration N                            .
  55 c . hehnp1 . e   .    1   . Hexaedre courant en numerotation Homard    .
  56 c .        .     .        . a l'iteration N+1                          .
  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 . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  67 c .        .     .        . 0 : l'entite est absente du profil         .
  68 c .        .     .        . 1 : l'entite est presente dans le profil   .
  69 c . nfpyrn . e   .    1   . nombre de fils pyramides n                 .
  70 c . nftetn . e   .    1   . nombre de fils tetraedres n                .
  71 c . ficn   . e   .  3,18  . fils en numerotation du calcul n           .
  72 c .        .     .        . 1 : hexaedres                              .
  73 c .        .     .        . 2 : pyramides                              .
  74 c .        .     .        . 3 : tetraedres                             .
  75 c . nfpyrp . e   .    1   . nombre de fils pyramides n+1               .
  76 c . nftetp . e   .    1   . nombre de fils tetraedres n+1              .
  77 c . ficp   . e   .  3,18  . fils en numerotation du calcul n+1         .
  78 c .        .     .        . 1 : hexaedres                              .
  79 c .        .     .        . 2 : pyramides                              .
  80 c .        .     .        . 3 : tetraedres                             .
  81 c . propor . e   .   18   . proportion de volume entre fils et pere    .
  82 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  83 c .        .     . * sdim .                                            .
  84 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  85 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  86 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  87 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  88 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  89 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  90 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  91 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  92 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  93 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  94 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  95 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  96 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  97 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  98 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  99 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
 100 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
 101 c . nhesca . e   . rsheto . numero des hexaedres dans le calcul sortie .
 102 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
 103 c . npysca . e   . rspyto . numero des pyramides dans le calcul sortie .
 104 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
 105 c . vafott . es  . nbfonc*. variables en sortie de l'adaptation        .
 106 c .        .     . nbevso .                                            .
 107 c . vateen . e   . nbfonc*. variables en entree de l'adaptation pour   .
 108 c .        .     .    *   . les tetraedres                             .
 109 c . vatett .   a . nbfonc*. tableau temporaire de la solution pour     .
 110 c .        .     .    *   . les tetraedres                             .
 111 c . prften . es  .   *    . En numero du calcul a l'iteration n   :    .
 112 c .        .     .        . 0 : le tetraedre est absent du profil      .
 113 c .        .     .        . 1 : le tetraedre est present dans le profil.
 114 c . prftep . es  .   *    . En numero du calcul a l'iteration n+1 :    .
 115 c .        .     .        . 0 : le tetraedre est absent du profil      .
 116 c .        .     .        . 1 : le tetraedre est present dans le profil.
 117 c . vapyen . e   . nbfonc*. variables en entree de l'adaptation pour   .
 118 c .        .     .    *   . les pyramides                              .
 119 c . vapytt .   a . nbfonc*. tableau temporaire de la solution pour     .
 120 c .        .     .    *   . les pyramides                              .
 121 c . prfpyn . es  .   *    . En numero du calcul a l'iteration n   :    .
 122 c .        .     .        . 0 : la pyramide est absente du profil      .
 123 c .        .     .        . 1 : la pyramide est presente dans le profil.
 124 c . prfpyp . es  .   *    . En numero du calcul a l'iteration n+1 :    .
 125 c .        .     .        . 0 : la pyramide est absente du profil      .
 126 c .        .     .        . 1 : la pyramide est presente dans le profil
 127 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 128 c . langue . e   .    1   . langue des messages                        .
 129 c .        .     .        . 1 : francais, 2 : anglais                  .
 130 c . codret . es  .    1   . code de retour des modules                 .
 131 c .        .     .        . 0 : pas de probleme                        .
 132 c .        .     .        . 1 : probleme                               .
 133 c ______________________________________________________________________
 134 c
 135 c====
 136 c 0. declarations et dimensionnement
 137 c====
 138 c
 139 c 0.1. ==> generalites
 140 c
 141       implicit none
 142       save
 143 c
 144       character*6 nompro
 145       parameter ( nompro = 'PCSEH1' )
 146 c
 147 #include "nblang.h"
 148 c
 149 c 0.2. ==> communs
 150 c
 151 #include "envca1.h"
 152 #include "nombno.h"
 153 #include "nombar.h"
 154 #include "nombtr.h"
 155 #include "nombqu.h"
 156 #include "nombte.h"
 157 #include "nombhe.h"
 158 #include "nombpy.h"
 159 #include "nombsr.h"
 160 c
 161 c 0.3. ==> arguments
 162 c
 163       integer etan, etanp1, hehn, hehnp1
 164       integer typint
 165       integer nbfonc
 166       integer prfcap(*)
 167 c
 168       integer nfpyrn, nftetn
 169       integer ficn(3,18)
 170       integer nfpyrp, nftetp
 171       integer ficp(3,18)
 172 c
 173       integer somare(2,nbarto)
 174       integer aretri(nbtrto,3)
 175       integer arequa(nbquto,4)
 176       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 177       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 178       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 179 c
 180       integer hethex(nbheto), filhex(nbheto), fhpyte(2,nbheco)
 181       integer nhesca(rsheto)
 182       integer ntesca(rsteto)
 183       integer npysca(rspyto)
 184       integer prften(*), prftep(*)
 185       integer prfpyn(*), prfpyp(*)
 186 c
 187       double precision propor(18)
 188       double precision coonoe(nbnoto,sdim)
 189       double precision vafott(nbfonc,*)
 190       double precision vateen(nbfonc,*)
 191       double precision vatett(nbfonc,*)
 192       double precision vapyen(nbfonc,*)
 193       double precision vapytt(nbfonc,*)
 194 c
 195       integer ulsort, langue, codret
 196 c
 197 c 0.4. ==> variables locales
 198 c
 199       integer iaux
 200 c
 201       integer hecnp1
 202       integer f1hp
 203 c
 204       integer nrofon
 205 c
 206       logical afaire
 207 c
 208       double precision daux
 209       double precision daux1
 210 c
 211       integer nbmess
 212       parameter ( nbmess = 10 )
 213       character*80 texte(nblang,nbmess)
 214 c
 215 c 0.5. ==> initialisations
 216 c ______________________________________________________________________
 217 c
 218 c====
 219 c 1. initialisations
 220 c====
 221 c
 222 #include "impr01.h"
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,1)) 'Entree', nompro
 226       call dmflsh (iaux)
 227 #endif
 228 #include "impr03.h"
 229 c
 230       codret = 0
 231 c
 232 c====
 233 c 2. seulement si des valeurs existent
 234 c====
 235 c
 236       afaire = .true.
 237 c
 238       do 21 , iaux = 1 , nfpyrn
 239         if ( prfpyn(ficn(2,iaux)).eq.0 ) then
 240           afaire = .false.
 241         endif
 242    21 continue
 243 c
 244       do 22 , iaux = 1 , nftetn
 245         if ( prften(ficn(3,iaux)).eq.0 ) then
 246           afaire = .false.
 247         endif
 248    22 continue
 249 c
 250       if ( afaire ) then
 251 c
 252 cgn      write(ulsort,90002) 'etanp1', etanp1
 253 cgn      write(ulsort,90002) 'hehnp1', hehnp1
 254 cgn      write(ulsort,90002) 'nfpyrn, nftetn', nfpyrn, nftetn
 255       daux1 = 1.d0 / dble(nfpyrn+nftetn)
 256 c
 257 c====
 258 c 3. L'hexaedre etait coupe en conformite
 259 c====
 260 c 3.1. ==> etanp1 = 0 : l'hexaedre est reactive.
 261 c          0n lui attribue la valeur moyenne ou totale sur les
 262 c          anciens fils.
 263 c        remarque : cela arrive seulement avec du deraffinement.
 264 c
 265       if ( etanp1.eq.0 ) then
 266 cgn        write(ulsort,*) '... l''hexaedre est reactive'
 267 c
 268         hecnp1 = nhesca(hehnp1)
 269         prfcap(hecnp1) = 1
 270 c
 271         if ( typint.eq.0 ) then
 272 c
 273           do 310 , nrofon = 1 , nbfonc
 274 c
 275             daux = 0.d0
 276             do 3101 , iaux = 1 , nfpyrn
 277               daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
 278  3101       continue
 279             do 3102 , iaux = 1 , nftetn
 280               daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
 281  3102       continue
 282 c
 283             vafott(nrofon,hecnp1) = daux * daux1
 284 c
 285   310     continue
 286 c
 287         else
 288 c
 289           do 311 , nrofon = 1 , nbfonc
 290             daux = 0.d0
 291             do 3111 , iaux = 1 , nfpyrn
 292               daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
 293  3111       continue
 294             do 3112 , iaux = 1 , nftetn
 295               daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
 296  3112       continue
 297             vafott(nrofon,hecnp1) = daux
 298   311     continue
 299 c
 300         endif
 301 c
 302 c 3.2. ==> etanp1 = etan : l'hexaedre est decoupe selon
 303 c          le meme decoupage. Comme les conventions sont les memes,
 304 c          on remet les memes valeurs.
 305 c
 306       elseif ( etanp1.eq.etan ) then
 307 c
 308         do 32 , nrofon = 1 , nbfonc
 309           do 321 , iaux = 1 , nfpyrn
 310             vapytt(nrofon,ficp(2,iaux)) =
 311      >                             vapyen(nrofon,prfpyn(ficn(2,iaux)))
 312   321     continue
 313           do 322 , iaux = 1 , nftetn
 314             vatett(nrofon,ficp(3,iaux)) =
 315      >                             vateen(nrofon,prften(ficn(3,iaux)))
 316   322     continue
 317    32   continue
 318 c
 319 c 3.3. ==> un autre decoupage de conformite
 320 c
 321       elseif ( etanp1.ge.11 ) then
 322 c
 323         if ( typint.eq.0 ) then
 324 c
 325           do 330 , nrofon = 1 , nbfonc
 326 c
 327             daux = 0.d0
 328             do 3301 , iaux = 1 , nfpyrn
 329               daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
 330  3301       continue
 331             do 3302 , iaux = 1 , nftetn
 332               daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
 333  3302       continue
 334             daux = daux * daux1
 335 c
 336             do 3303 , iaux = 1 , nfpyrp
 337               vapytt(nrofon,ficp(2,iaux)) = daux
 338  3303       continue
 339             do 3304 , iaux = 1 , nftetp
 340               vatett(nrofon,ficp(3,iaux)) = daux
 341  3304       continue
 342 c
 343   330     continue
 344 c
 345         else
 346 c
 347           do 331 , nrofon = 1 , nbfonc
 348 c
 349             daux = 0.d0
 350             do 3311 , iaux = 1 , nfpyrn
 351               daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
 352  3311       continue
 353             do 3312 , iaux = 1 , nftetn
 354               daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
 355  3312       continue
 356 c
 357             do 3313 , iaux = 1 , nfpyrp
 358               vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux)
 359  3313       continue
 360             do 3314 , iaux = 1 , nftetp
 361               vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp)
 362  3314       continue
 363 c
 364   331     continue
 365 c
 366         endif
 367 c
 368 c 3.4. ==> etanp1 = 8 : l'hexaedre est decoupe en 8 hexaedres
 369 c             c'est ce qui se passe quand un decoupage de conformite
 370 c             est supprime au debut des algorithmes d'adaptation. il y
 371 c             a ensuite raffinement de l'hexaedre. qui plus est, par
 372 c             suite de la regle des ecarts de niveau, on peut avoir
 373 c             induit un decoupage de conformite sur 1,2,3 ou 4 des fils.
 374 c             Ce ou ces fils sont obligatoirement du cote du precedent
 375 c             point de non conformite.
 376 c
 377       elseif ( etanp1.eq.8 ) then
 378 cgn         print *,'... l''hexa est coupe en 8 hexa'
 379 c
 380         f1hp = filhex(hehnp1)
 381         daux1 = 1.d0 / dble(nfpyrn+nftetn)
 382 cgn        write(ulsort,*) 'f1hp = ', f1hp
 383         do 34 , nrofon = 1 , nbfonc
 384 c
 385           daux = 0.d0
 386           do 3401 , iaux = 1 , nfpyrn
 387             daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux)))
 388  3401     continue
 389           do 3402 , iaux = 1 , nftetn
 390             daux = daux + vateen(nrofon,prften(ficn(3,iaux)))
 391  3402     continue
 392 c
 393           iaux = nrofon
 394 #ifdef _DEBUG_HOMARD_
 395           write (ulsort,texte(langue,3)) 'PCSEH9', nompro
 396 #endif
 397           call pcseh9 ( etan, etanp1, hehn, hehnp1, typint,
 398      >                  f1hp, iaux, daux, daux1, prfcap,
 399      >                  ficp, propor,
 400      >                  coonoe, somare, aretri, arequa,
 401      >                  tritet, cotrte, aretet,
 402      >                  quahex, coquhe, arehex,
 403      >                  facpyr, cofapy, arepyr,
 404      >                  hethex, filhex, fhpyte,
 405      >                  nhesca,
 406      >                  ntesca,
 407      >                  npysca,
 408      >                  nbfonc, vafott,
 409      >                  prftep, vatett,
 410      >                  prfpyp, vapytt,
 411      >                  ulsort, langue, codret )
 412 c
 413    34   continue
 414 c
 415       endif
 416 c
 417 c====
 418 c 4. affectation des profils
 419 c    Attention : pour les fils en hexaedres, c'est fait dans pcseh9
 420 c====
 421 c
 422       if ( codret.eq.0 ) then
 423 c
 424       do 42 , iaux = 1 , nfpyrp
 425         prfpyp(ficp(2,iaux)) = 1
 426    42 continue
 427 c
 428       do 43 , iaux = 1 , nftetp
 429         prftep(ficp(3,iaux)) = 1
 430    43 continue
 431 c
 432       endif
 433 c
 434       endif
 435 c
 436 c====
 437 c 5. la fin
 438 c====
 439 c
 440       if ( codret.ne.0 ) then
 441 c
 442       write (ulsort,texte(langue,1)) 'Sortie', nompro
 443       write (ulsort,texte(langue,2)) codret
 444 c
 445       endif
 446 c
 447 #ifdef _DEBUG_HOMARD_
 448       write (ulsort,texte(langue,1)) 'Sortie', nompro
 449       call dmflsh (iaux)
 450 #endif
 451 c
 452       end