src/tool/AP_Conversion/pcsep1.F

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