src/tool/AP_Conversion/pcshe0.F

   1       subroutine pcshe0 ( nbfonc, typint, deraff,
   2      >                    prfcan, prfcap,
   3      >                    coonoe,
   4      >                    somare,
   5      >                    aretri,
   6      >                    arequa,
   7      >                    tritet, cotrte, aretet,
   8      >                    quahex, coquhe, arehex,
   9      >                    facpyr, cofapy, arepyr,
  10      >                    hethex, anchex, filhex, fhpyte,
  11      >                    nbanhe, anfihe, anpthe,
  12      >                    nheeca, nhesca,
  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                       HExaedres - 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 . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  77 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  78 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  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 . hethex . e   . nbheto . historique de l'etat des hexaedres        .
  83 c . filhex . e   . nbheto . premier fils des hexaedres                .
  84 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  85 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  86 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  87 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  88 c . nbanhe . e   .   1    . nombre de hexaedres decoupes par          .
  89 c .        .     .        . conformite sur le maillage avant adaptation.
  90 c . anfihe . e   . nbanhe . tableau filhex du maillage de l'iteration n.
  91 c . anpthe . e   .  2**   . tableau fhpyte du maillage de l'iteration n.
  92 c . nheeca . e   .    *   . numero des hexaedres dans le calcul entree .
  93 c . nhesca . e   . rsheto . numero des hexaedres 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 = 'PCSHE0' )
 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 "nombhe.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 quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 172       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 173 c
 174       integer hethex(nbheto), anchex(*)
 175       integer filhex(nbheto), fhpyte(2,nbheco)
 176       integer nbanhe, anfihe(nbanhe), anpthe(2,*)
 177       integer nheeca(reheto), nhesca(rsheto)
 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     hehn   = HExaedre courant en numerotation Homard a l'it. N
 200 c     hehnp1 = HExaedre courant en numerotation Homard a l'it. N+1
 201 c
 202       integer hehn, hehnp1
 203 c
 204 c     etan   = ETAt de l'hexaedre a l'iteration N
 205 c     etanp1 = ETAt de l'hexaedre a l'iteration N+1
 206 c
 207       integer etan, etanp1
 208 c
 209       integer nfhexp, nfpyrp, nftetp
 210       integer ficp(3,18)
 211       integer nfhexn, nfpyrn, nftetn
 212       integer ficn(3,18)
 213 c
 214       double precision propor(18)
 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 hexaedres du maillage HOMARD n+1
 240 c    on trie en fonction de l'etat de l'hexaedre 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 , nbheto
 248 c
 249 c 2.1. ==> caracteristiques de l'hexaedre :
 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         hehnp1 = iaux
 256         if ( deraff ) then
 257           hehn = anchex(hehnp1)
 258         else
 259           hehn = hehnp1
 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 hexaedre est actif.
 265 c      etat = 8 : l'hexaedre est coupe en 8.
 266 c      etat >= 11 : l'hexaedre est coupe par conformite
 267 c
 268         etanp1 = mod(hethex(hehnp1),1000)
 269         etan   = (hethex(hehnp1)-etanp1) / 1000
 270 #ifdef _DEBUG_HOMARD_
 271         write (ulsort,*) '=========================================='
 272         write (ulsort,90002)  mess14(langue,1,6), hehnp1
 273         write (ulsort,90002) '. hehn   =', hehn
 274         write (ulsort,90002) '. etan   =', etan
 275         write (ulsort,90002) '. etanp1 =', etanp1
 276 #endif
 277 c
 278 c 2.1.3. ==> prealables a l'iteration n
 279 c
 280         if ( etan.ne.5 .and. etan.ne.9 ) then
 281 c
 282 c 2.1.3.1. ==> numerotation des fils
 283 c
 284 #ifdef _DEBUG_HOMARD_
 285           write (ulsort,texte(langue,3)) 'PCSEHY n', nompro
 286 #endif
 287           call pcsehy ( nfhexn, nfpyrn, nftetn, ficn,
 288      >                  hehn, etan,
 289      >                  anfihe, anpthe,
 290      >                  nheeca, nteeca, npyeca,
 291      >                  ulsort, langue, codret )
 292 c
 293         endif
 294 c
 295 c 2.1.4. ==> prealables a l'iteration n+1
 296 c
 297         if ( etanp1.ne.5 .and. etanp1.ne.9 ) then
 298 c
 299 c 2.1.4.1. ==> numerotation des fils
 300 c
 301 #ifdef _DEBUG_HOMARD_
 302           write (ulsort,texte(langue,3)) 'PCSEHY n+1', nompro
 303 #endif
 304           call pcsehy ( nfhexp, nfpyrp, nftetp, ficp,
 305      >                  hehnp1, etanp1,
 306      >                  filhex, fhpyte,
 307      >                  nhesca, ntesca, npysca,
 308      >                  ulsort, langue, codret )
 309 c
 310 c 2.1.4.2. ==> en mode extensif, calcul des proportions
 311 c
 312           if ( typint.gt.0 ) then
 313 c
 314 #ifdef _DEBUG_HOMARD_
 315           write (ulsort,texte(langue,3)) 'PCSEHZ', nompro
 316 #endif
 317             call pcsehz ( propor,
 318      >                    hehnp1, etanp1,
 319      >                    coonoe, somare, aretri, arequa,
 320      >                    tritet, cotrte, aretet,
 321      >                    quahex, coquhe, arehex,
 322      >                    facpyr, cofapy, arepyr,
 323      >                    filhex, fhpyte,
 324      >                    ulsort, langue, codret )
 325 c
 326           endif
 327 c
 328         endif
 329 c
 330         endif
 331 c
 332 c 2.2. ==> Examen des differents etats
 333 c
 334         if ( codret.eq.0 ) then
 335 c
 336 c=======================================================================
 337 c 2.2.1. ==> etan = 0 : l'hexaedre etait actif
 338 c=======================================================================
 339 c
 340         if ( etan.eq.0 ) then
 341 c
 342 #ifdef _DEBUG_HOMARD_
 343           write (ulsort,texte(langue,3)) 'PCSEH0', nompro
 344 #endif
 345 c
 346           call pcseh0 ( etan, etanp1, hehn, hehnp1, typint,
 347      >                  prfcan, prfcap,
 348      >                  nfhexp, nfpyrp, nftetp, ficp, propor,
 349      >                  nheeca, nhesca,
 350      >                  nbfonc, vafoen, vafott,
 351      >                  vatett, prftep,
 352      >                  vapytt, prfpyp,
 353      >                  ulsort, langue, codret )
 354 cgn          write (ulsort,*) 'retour de PCSEH0'
 355 c
 356 c=======================================================================
 357 c 2.2.2. ==> l'hexaedre etait coupe en conformite
 358 c=======================================================================
 359 c
 360       elseif ( etan.ge.11 ) then
 361 c
 362 #ifdef _DEBUG_HOMARD_
 363           write (ulsort,texte(langue,3)) 'PCSEH1', nompro
 364 #endif
 365 c
 366           call pcseh1 ( etan, etanp1, hehn, hehnp1, typint,
 367      >                  prfcap,
 368      >                  nfpyrn, nftetn, ficn,
 369      >                  nfpyrp, nftetp, ficp, propor,
 370      >                  coonoe,
 371      >                  somare,
 372      >                  aretri,
 373      >                  arequa,
 374      >                  tritet, cotrte, aretet,
 375      >                  quahex, coquhe, arehex,
 376      >                  facpyr, cofapy, arepyr,
 377      >                  hethex, filhex, fhpyte,
 378      >                          nhesca,
 379      >                  ntesca,
 380      >                  npysca,
 381      >                  nbfonc, vafott,
 382      >                  vateen, vatett,
 383      >                  prften, prftep,
 384      >                  vapyen, vapytt,
 385      >                  prfpyn, prfpyp,
 386      >                  ulsort, langue, codret )
 387 c
 388 c=======================================================================
 389 c 2.2.3. ==> etan = 8 : le hexaedre etait coupe en 8 hexaedres
 390 c=======================================================================
 391 c
 392         elseif ( etan.eq.8 ) then
 393 c
 394 #ifdef _DEBUG_HOMARD_
 395           write (ulsort,texte(langue,3)) 'PCSEH8', nompro
 396 #endif
 397 c
 398           call pcseh8 ( etanp1, hehnp1, typint,
 399      >                  prfcan, prfcap,
 400      >                  ficn,
 401      >                  nfpyrp, nftetp, ficp, propor,
 402      >                  nhesca,
 403      >                  nbfonc, vafoen, vafott,
 404      >                          vatett,
 405      >                          prftep,
 406      >                          vapytt,
 407      >                          prfpyp,
 408      >                  ulsort, langue, codret )
 409 c
 410         endif
 411 c
 412         endif
 413 c
 414    20 continue
 415 c
 416       endif
 417 c
 418 c====
 419 c 3. la fin
 420 c====
 421 c
 422       if ( codret.ne.0 ) then
 423 c
 424 #include "envex2.h"
 425 c
 426       write (ulsort,texte(langue,1)) 'Sortie', nompro
 427       write (ulsort,texte(langue,2)) codret
 428 c
 429       endif
 430 c
 431 #ifdef _DEBUG_HOMARD_
 432       write (ulsort,texte(langue,1)) 'Sortie', nompro
 433       call dmflsh (iaux)
 434 #endif
 435 c
 436       end