src/tool/AP_Conversion/pcspe0.F

   1       subroutine pcspe0 ( nbfonc, typint, deraff,
   2      >                    prfcan, prfcap,
   3      >                    coonoe,
   4      >                    somare,
   5      >                    aretri,
   6      >                    arequa,
   7      >                    tritet, cotrte, aretet,
   8      >                    facpen, cofape, arepen,
   9      >                    facpyr, cofapy, arepyr,
  10      >                    hetpen, ancpen, filpen, fppyte,
  11      >                    nbanpe, anfipe, anptpe,
  12      >                    npeeca, npesca,
  13      >                    nteeca, ntesca,
  14      >                    npyeca, npysca,
  15      >                    vafoen, vafott,
  16      >                    vateen, vatett,
  17      >                    prften, prftep,
  18      >                    vapyen, vapytt,
  19      >                    prfpyn, prfpyp,
  20      >                    ulsort, langue, codret )
  21 c ______________________________________________________________________
  22 c
  23 c                             H O M A R D
  24 c
  25 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  26 c
  27 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  28 c aupres des huissiers de justice Simart et Lavoir a Clamart
  29 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  30 c aupres des huissiers de justice
  31 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  32 c
  33 c    HOMARD est une marque deposee d'Electricite de France
  34 c
  35 c Copyright EDF 1996
  36 c Copyright EDF 1998
  37 c Copyright EDF 2002
  38 c Copyright EDF 2020
  39 c ______________________________________________________________________
  40 c
  41 c    aPres adaptation - Conversion de Solution -
  42 c     -                 -             -
  43 c                       PEntaedres - solution P0
  44 c                       --                    -
  45 c remarque : pcshe0 et pcspe0 sont des clones
  46 c ______________________________________________________________________
  47 c .        .     .        .                                            .
  48 c .  nom   . e/s . taille .           description                      .
  49 c .____________________________________________________________________.
  50 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  51 c . typint . e   .   1    . type d'interpolation                       .
  52 c .        .     .        .  0, si automatique                         .
  53 c .        .     .        .  elements : 0 si intensif, sans orientation.
  54 c .        .     .        .             1 si extensif, sans orientation.
  55 c .        .     .        .             2 si intensif, avec orientation.
  56 c .        .     .        .             3 si extensif, avec orientation.
  57 c .        .     .        .  noeuds : 1 si degre 1                     .
  58 c .        .     .        .           2 si degre 2                     .
  59 c .        .     .        .           3 si iso-P2                      .
  60 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  61 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  62 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  63 c .        .     .        . 0 : l'entite est absente du profil         .
  64 c .        .     .        . i : l'entite est au rang i dans le profil  .
  65 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  66 c .        .     .        . 0 : l'entite est absente du profil         .
  67 c .        .     .        . 1 : l'entite est presente dans le profil   .
  68 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  69 c .        .     . * sdim .                                            .
  70 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  71 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  72 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  73 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  74 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  75 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  76 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  77 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  78 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  79 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  80 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  81 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  82 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  83 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  84 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  85 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  86 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  87 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  88 c . nbanpe . e   .   1    . nombre de pentaedres decoupes par          .
  89 c .        .     .        . conformite sur le maillage avant adaptation.
  90 c . anfipe . e   . nbanpe . tableau filpen du maillage de l'iteration n.
  91 c . anptpe . e   .  2**   . tableau fppyte du maillage de l'iteration n.
  92 c . npeeca . e   .    *   . numero des pentaedres dans le calcul entree.
  93 c . npesca . e   . rspeto . numero des pentaedres dans le calcul sortie.
  94 c . nteeca . e   .    *   . numero des tetraedres dans le calcul entree.
  95 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
  96 c . npyeca . e   .    *   . numero des pyramides dans le calcul entree .
  97 c . npysca . e   . rspyto . numero des pyramides dans le calcul sortie .
  98 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  99 c .        .     .    *   .                                            .
 100 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
 101 c .        .     .    *   .                                            .
 102 c . vateen . e   . nbfonc*. variables en entree de l'adaptation pour   .
 103 c .        .     .    *   . les tetraedres                             .
 104 c . vatett .   a . nbfonc*. tableau temporaire de la solution pour     .
 105 c .        .     .    *   . les tetraedres                             .
 106 c . prften . es  .   *    . En numero du calcul a l'iteration n   :    .
 107 c .        .     .        . 0 : le tetraedre est absent du profil      .
 108 c .        .     .        . 1 : le tetraedre est present dans le profil.
 109 c . prftep . es  .   *    . En numero du calcul a l'iteration n+1 :    .
 110 c .        .     .        . 0 : le tetraedre est absent du profil      .
 111 c .        .     .        . 1 : le tetraedre est present dans le profil.
 112 c . vapyen . e   . nbfonc*. variables en entree de l'adaptation pour   .
 113 c .        .     .    *   . les pyramides                              .
 114 c . vapytt .   a . nbfonc*. tableau temporaire de la solution pour     .
 115 c .        .     .    *   . les pyramides                              .
 116 c . prfpyn . es  .   *    . En numero du calcul a l'iteration n   :    .
 117 c .        .     .        . 0 : la pyramide est absente du profil      .
 118 c .        .     .        . 1 : la pyramide est presente dans le profil.
 119 c . prfpyp . es  .   *    . En numero du calcul a l'iteration n+1 :    .
 120 c .        .     .        . 0 : la pyramide est absente du profil      .
 121 c .        .     .        . 1 : la pyramide est presente dans le profil
 122 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 123 c . langue . e   .    1   . langue des messages                        .
 124 c .        .     .        . 1 : francais, 2 : anglais                  .
 125 c . codret . es  .    1   . code de retour des modules                 .
 126 c .        .     .        . 0 : pas de probleme                        .
 127 c .        .     .        . 1 : probleme                               .
 128 c ______________________________________________________________________
 129 c
 130 c====
 131 c 0. declarations et dimensionnement
 132 c====
 133 c
 134 c 0.1. ==> generalites
 135 c
 136       implicit none
 137       save
 138 c
 139       character*6 nompro
 140       parameter ( nompro = 'PCSPE0' )
 141 c
 142 #include "nblang.h"
 143 #include "fracti.h"
 144 c
 145 c 0.2. ==> communs
 146 c
 147 #include "envex1.h"
 148 #include "impr02.h"
 149 c
 150 #include "envca1.h"
 151 #include "nombno.h"
 152 #include "nombar.h"
 153 #include "nombtr.h"
 154 #include "nombqu.h"
 155 #include "nombte.h"
 156 #include "nombpe.h"
 157 #include "nombpy.h"
 158 #include "nombsr.h"
 159 #include "nomber.h"
 160 c
 161 c 0.3. ==> arguments
 162 c
 163       integer nbfonc
 164       integer typint
 165       integer prfcan(*), prfcap(*)
 166 c
 167       integer somare(2,nbarto)
 168       integer aretri(nbtrto,3)
 169       integer arequa(nbquto,4)
 170       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 171       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 172       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 173 c
 174       integer hetpen(nbpeto), ancpen(*)
 175       integer filpen(nbpeto), fppyte(2,nbpeco)
 176       integer nbanpe, anfipe(nbanpe), anptpe(2,*)
 177       integer npeeca(repeto), npesca(rspeto)
 178       integer nteeca(reteto), ntesca(rsteto)
 179       integer npyeca(repyto), npysca(rspyto)
 180       integer prften(*), prftep(*)
 181       integer prfpyn(*), prfpyp(*)
 182 c
 183       double precision coonoe(nbnoto,sdim)
 184       double precision vafoen(nbfonc,*)
 185       double precision vafott(nbfonc,*)
 186       double precision vateen(nbfonc,*)
 187       double precision vatett(nbfonc,*)
 188       double precision vapyen(nbfonc,*)
 189       double precision vapytt(nbfonc,*)
 190 c
 191       logical deraff
 192 c
 193       integer ulsort, langue, codret
 194 c
 195 c 0.4. ==> variables locales
 196 c
 197       integer iaux
 198 c
 199 c     pehn   = PEntaedre courant en numerotation Homard a l'it. N
 200 c     pehnp1 = PEntaedre courant en numerotation Homard a l'it. N+1
 201 c
 202       integer pehn, pehnp1
 203 c
 204 c     etan   = ETAt du pentaedre a l'iteration N
 205 c     etanp1 = ETAt du pentaedre a l'iteration N+1
 206 c
 207       integer etan, etanp1
 208 c
 209       integer nfpenp, nfpyrp, nftetp
 210       integer ficp(3,11)
 211       integer nfpenn, nfpyrn, nftetn
 212       integer ficn(3,11)
 213 c
 214       double precision propor(11)
 215 c
 216       integer nbmess
 217       parameter ( nbmess = 10 )
 218       character*80 texte(nblang,nbmess)
 219 c
 220 c 0.5. ==> initialisations
 221 c ______________________________________________________________________
 222 c
 223 c====
 224 c 1. initialisations
 225 c====
 226 c
 227 #include "impr01.h"
 228 c
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,1)) 'Entree', nompro
 231       call dmflsh (iaux)
 232 #endif
 233 c
 234 #include "impr03.h"
 235 c
 236       codret = 0
 237 c
 238 c====
 239 c 2. on boucle sur tous les pentaedres du maillage HOMARD n+1
 240 c    on trie en fonction de l'etat de du pentaedre dans le maillage n
 241 c    remarque : on a scinde en plusieurs programmes pour pouvoir passer
 242 c    les options de compilation optimisees.
 243 c====
 244 c
 245       if ( nbfonc.ne.0 ) then
 246 c
 247       do 20 , iaux = 1 , nbpeto
 248 c
 249 c 2.1. ==> caracteristiques du pentaedre :
 250 c
 251         if ( codret.eq.0 ) then
 252 c
 253 c 2.1.1. ==> son numero homard dans le maillage precedent
 254 c
 255         pehnp1 = iaux
 256         if ( deraff ) then
 257           pehn = ancpen(pehnp1)
 258         else
 259           pehn = pehnp1
 260         endif
 261 c
 262 c 2.1.2. ==> l'historique de son etat
 263 c          On rappelle que l'etat vaut :
 264 c      etat = 0 : le pentaedre est actif.
 265 c      etat =  1, ..., 6  : le pentaedre est coupe en 2 pyramides et
 266 c                           1 tetraedre selon l'arete 1, ..., 6.
 267 c      etat = 17, ..., 19 : le pentaedre est coupe en 1 pyramide et
 268 c                           2 tetraedres selon l'arete 7, 8, 9.
 269 c      etat = 21, ..., 26 : le pentaedre est coupe en 6 tetraedres.
 270 c      etat = 31, ..., 36 : le pentaedre est coupe en 1 pyramide et
 271 c                           10 tetraedres.
 272 c      etat = 43, ..., 45 : le pentaedre est coupe en 4 pyramides et
 273 c                           2 tetraedres.
 274 c      etat = 51, 52      : le pentaedre est coupe en 11 tetraedres.
 275 c      etat = 55 : le pentaedre n'existait pas ; il a ete produit par
 276 c                  un decoupage.
 277 c      etat = 80 : le pentaedre est coupe en 8.
 278 c
 279         etanp1 = mod(hetpen(pehnp1),100)
 280         etan   = (hetpen(pehnp1)-etanp1) / 100
 281 #ifdef _DEBUG_HOMARD_
 282         write (ulsort,*) '=========================================='
 283         write (ulsort,90002)  mess14(langue,1,7), pehnp1
 284         write (ulsort,90002) 'pehn  ', pehn
 285         write (ulsort,90002) 'etan  ', etan
 286         write (ulsort,90002) 'etanp1', etanp1
 287 cgn        if ( pehn.eq.0 ) stop
 288 #endif
 289 c
 290 c 2.1.3. ==> prealables a l'iteration n
 291 c
 292         if ( etan.ne.55 .and. etan.ne.99 ) then
 293 c
 294 c 2.1.3.1. ==> numerotation des fils
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297           write (ulsort,texte(langue,3)) 'PCSEPY n', nompro
 298 #endif
 299           call pcsepy ( nfpenn, nfpyrn, nftetn, ficn,
 300      >                  pehn, etan,
 301      >                  anfipe, anptpe,
 302      >                  npeeca, nteeca, npyeca,
 303      >                  ulsort, langue, codret )
 304 c
 305         endif
 306 c
 307 c 2.1.4. ==> prealables a l'iteration n+1
 308 c
 309         if ( etanp1.ne.55 .and. etanp1.ne.99 ) then
 310 c
 311 c 2.1.4.1. ==> numerotation des fils
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314           write (ulsort,texte(langue,3)) 'PCSEPY n+1', nompro
 315 #endif
 316           call pcsepy ( nfpenp, nfpyrp, nftetp, ficp,
 317      >                  pehnp1, etanp1,
 318      >                  filpen, fppyte,
 319      >                  npesca, ntesca, npysca,
 320      >                  ulsort, langue, codret )
 321 c
 322 c 2.1.4.2. ==> en mode extensif, calcul des proportions
 323 c
 324           if ( typint.gt.0 ) then
 325 c
 326 #ifdef _DEBUG_HOMARD_
 327           write (ulsort,texte(langue,3)) 'PCSEPZ', nompro
 328 #endif
 329             call pcsepz ( propor,
 330      >                    pehnp1, etanp1,
 331      >                    coonoe, somare, aretri, arequa,
 332      >                    tritet, cotrte, aretet,
 333      >                    facpen, cofape, arepen,
 334      >                    facpyr, cofapy, arepyr,
 335      >                    filpen, fppyte,
 336      >                    ulsort, langue, codret )
 337 c
 338           endif
 339 c
 340         endif
 341 c
 342         endif
 343 c
 344 c 2.2. ==> Examen des differents etats
 345 c
 346         if ( codret.eq.0 ) then
 347 c
 348 c=======================================================================
 349 c 2.2.1 ==> etan = 0 : le pentaedre etait actif
 350 c=======================================================================
 351 c
 352         if ( etan.eq.0 ) then
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355           write (ulsort,texte(langue,3)) 'PCSEP0', nompro
 356 #endif
 357 c
 358           call pcsep0 ( etan, etanp1, pehn, pehnp1, typint,
 359      >                  prfcan, prfcap,
 360      >                  nfpenp, nfpyrp, nftetp, ficp, propor,
 361      >                  npeeca, npesca,
 362      >                  nbfonc, vafoen, vafott,
 363      >                  vatett, prftep,
 364      >                  vapytt, prfpyp,
 365      >                  ulsort, langue, codret )
 366 cgn          write (ulsort,*) 'retour de PCSEH0'
 367 c
 368 c=======================================================================
 369 c 2.2.2. ==> le pentaedre etait coupe en conformite
 370 c=======================================================================
 371 c
 372         elseif ( ( etan.ge.1 .and. etan.le.6 ) .or.
 373      >           ( etan.ge.17 .and. etan.le.19 ) .or.
 374      >           ( etan.ge.21 .and. etan.le.26 ) .or.
 375      >           ( etan.ge.31 .and. etan.le.36 ) .or.
 376      >           ( etan.ge.43 .and. etan.le.45 ) .or.
 377      >           ( etan.ge.51 .and. etan.le.52 ) ) then
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380           write (ulsort,texte(langue,3)) 'PCSEP1', nompro
 381 #endif
 382 c
 383           call pcsep1 ( etan, etanp1, pehn, pehnp1, typint,
 384      >                  prfcap,
 385      >                  nfpyrn, nftetn, ficn,
 386      >                  nfpyrp, nftetp, ficp, propor,
 387      >                  coonoe,
 388      >                  somare,
 389      >                  aretri,
 390      >                  arequa,
 391      >                  tritet, cotrte, aretet,
 392      >                  facpen, cofape, arepen,
 393      >                  facpyr, cofapy, arepyr,
 394      >                  hetpen, filpen, fppyte,
 395      >                          npesca,
 396      >                  ntesca,
 397      >                  npysca,
 398      >                  nbfonc, vafott,
 399      >                  vateen, vatett,
 400      >                  prften, prftep,
 401      >                  vapyen, vapytt,
 402      >                  prfpyn, prfpyp,
 403      >                  ulsort, langue, codret )
 404 c
 405 c
 406 c=======================================================================
 407 c 2.2.3. ==> etan = 80 : le pentaedre etait coupe en 8 pentaedres
 408 c=======================================================================
 409 c
 410         elseif ( etan.eq.80 ) then
 411 c
 412 #ifdef _DEBUG_HOMARD_
 413           write (ulsort,texte(langue,3)) 'PCSEP8', nompro
 414 #endif
 415 c
 416           call pcsep8 ( etanp1, pehnp1, typint,
 417      >                  prfcan, prfcap,
 418      >                  ficn,
 419      >                  nfpyrp, nftetp, ficp, propor,
 420      >                  npesca,
 421      >                  nbfonc, vafoen, vafott,
 422      >                          vatett,
 423      >                          prftep,
 424      >                          vapytt,
 425      >                          prfpyp,
 426      >                  ulsort, langue, codret )
 427 c
 428         endif
 429 c
 430         endif
 431 c
 432    20 continue
 433 c
 434       endif
 435 c
 436 c====
 437 c 3. la fin
 438 c====
 439 c
 440       if ( codret.ne.0 ) then
 441 c
 442 #include "envex2.h"
 443 c
 444       write (ulsort,texte(langue,1)) 'Sortie', nompro
 445       write (ulsort,texte(langue,2)) codret
 446 c
 447       endif
 448 c
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,texte(langue,1)) 'Sortie', nompro
 451       call dmflsh (iaux)
 452 #endif
 453 c
 454       end