src/tool/AP_Conversion/pcsteg.F

   1       subroutine pcsteg ( nbfonc, ngauss, nbnorf, typgeo, deraff,
   2      >                    prfcan, prfcap,
   3      >                    hettet, anctet,
   4      >                    filtet,
   5      >                    nbante, anfite,
   6      >                    nteeca, ntesca,
   7      >                    vafoen, vafott,
   8      >                    conorf, copgrf, wipg,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aPres adaptation - Conversion de Solution -
  31 c     -                 -             -
  32 c                       TEtraedres a plusieurs points de Gauss
  33 c                       --                               -
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . nbfonc . e   .    1   . nombre de fonctions aux points de Gauss    .
  39 c . ngauss . e   .   1    . nbre de points de Gauss des fonctions pg   .
  40 c . nbnorf . e   .   1    . nbre de noeuds de l'element de reference   .
  41 c . typgeo . e   .   1    . type geometrique au sens MED               .
  42 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  43 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  44 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  45 c .        .     .        . 0 : l'entite est absente du profil         .
  46 c .        .     .        . i : l'entite est au rang i dans le profil  .
  47 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  48 c .        .     .        . 0 : l'entite est absente du profil         .
  49 c .        .     .        . 1 : l'entite est presente dans le profil   .
  50 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  51 c . filtet . e   . nbteto . premier fils des tetraedres                .
  52 c . nbante . e   .   1    . nombre de tetraedres decoupes par          .
  53 c .        .     .        . conformite sur le maillage avant adaptation.
  54 c . anfite . e   . nbante . tableau filtet du maillage de l'iteration n.
  55 c . nteeca . e   .    *   . numero des tetraedres dans le calcul entree.
  56 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
  57 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  58 c .        .     .    *   .                                            .
  59 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  60 c .        .     .    *   .                                            .
  61 c . conorf . e   .  sdim* . coordonnees des noeuds de l'element de     .
  62 c .        .     . nbnorf . reference                                  .
  63 c . copgrf . e   .  sdim* . coordonnees des points de Gauss            .
  64 c .        .     . ngauss . de l'element de reference                  .
  65 c . wipg   .  a  . nbnorf*. fonctions de forme exprimees aux points de .
  66 c .        .     . ngauss . Gauss                                      .
  67 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  68 c . langue . e   .    1   . langue des messages                        .
  69 c .        .     .        . 1 : francais, 2 : anglais                  .
  70 c . codret . es  .    1   . code de retour des modules                 .
  71 c .        .     .        . 0 : pas de probleme                        .
  72 c .        .     .        . 1 : probleme                               .
  73 c ______________________________________________________________________
  74 c
  75 c====
  76 c 0. declarations et dimensionnement
  77 c====
  78 c
  79 c 0.1. ==> generalites
  80 c
  81       implicit none
  82       save
  83 c
  84       character*6 nompro
  85       parameter ( nompro = 'PCSTEG' )
  86 c
  87 #include "nblang.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 c
  93 #include "envca1.h"
  94 #include "nombte.h"
  95 #include "nombsr.h"
  96 #include "nomber.h"
  97 c
  98 c 0.3. ==> arguments
  99 c
 100       integer nbfonc
 101       integer ngauss, nbnorf, typgeo
 102       integer prfcan(*), prfcap(*)
 103       integer hettet(nbteto), anctet(*)
 104       integer filtet(nbteto)
 105       integer nbante, anfite(nbante)
 106       integer nteeca(reteto), ntesca(rsteto)
 107 c
 108       double precision vafoen(nbfonc,ngauss,*)
 109       double precision vafott(nbfonc,ngauss,*)
 110       double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss)
 111       double precision wipg(nbnorf,ngauss)
 112 c
 113       logical deraff
 114 c
 115       integer ulsort, langue, codret
 116 c
 117 c 0.4. ==> variables locales
 118 c
 119       integer iaux
 120 c
 121 c     tehn   = TEtraedre courant en numerotation Homard a l'it. N
 122 c     tehnp1 = TEtraedre courant en numerotation Homard a l'it. N+1
 123 c
 124       integer tehn, tehnp1
 125 c
 126 c     etan   = ETAt du tetraedre a l'iteration N
 127 c     etanp1 = ETAt du tetraedre a l'iteration N+1
 128 c
 129       integer etan, etanp1
 130 c
 131       integer nbmess
 132       parameter ( nbmess = 10 )
 133       character*80 texte(nblang,nbmess)
 134 c
 135 c 0.5. ==> initialisations
 136 c ______________________________________________________________________
 137 c
 138 c====
 139 c 1. initialisations
 140 c====
 141 c
 142 #include "pcimp0.h"
 143 #include "impr01.h"
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,1)) 'Entree', nompro
 147       call dmflsh (iaux)
 148 #endif
 149 #include "impr03.h"
 150 cgn      write (ulsort,*) 'prfcan en entree de '//nompro
 151 cgn      write (ulsort,91020) (prfcan(iaux),iaux=1,17)
 152 cgn      write (ulsort,*) 'nteeca en entree de '//nompro
 153 cgn      write (ulsort,91020) (nteeca(iaux),iaux=1,5)
 154 cgn      write (ulsort,*) 'vafoen en entree de '//nompro
 155 cgn      do 111 , etan = 1 , nbfonc
 156 cgn      write (ulsort,90002) 'composante',etan
 157 cgn      do 1111 , etanp1 = 1 , 8
 158 cgn        write (ulsort,92010) (vafoen(etan,etanp1,iaux),iaux=1,5)
 159 cgn 1111 continue
 160 cgn  111 continue
 161 c
 162       codret = 0
 163 c
 164 c====
 165 c 2. on boucle sur tous les tetraedres du maillage HOMARD n+1
 166 c    on trie en fonction de l'etat du tetraedre dans le maillage n
 167 c    on numerote les paragraphes en fonction de la documentation, a
 168 c    savoir : le paragraphe doc.n.p traite de la mise a jour de solution
 169 c    pour un tetraedre dont l'etat est passe de n a p.
 170 c    les autres paragraphes sont numerotes classiquement
 171 c    remarque : on a scinde en plusieurs programmes pour pouvoir passer
 172 c    les options de compilation optimisees.
 173 c====
 174 c
 175 #ifdef _DEBUG_HOMARD_
 176       write (ulsort,*) '3. Boucle ; codret = ', codret
 177 #endif
 178 c
 179       if ( codret.eq.0 ) then
 180 c
 181       if ( nbfonc.ne.0 ) then
 182 c
 183       do 30 , tehnp1 = 1 , nbteto
 184 c
 185 c 2.1. ==> caracteristiques du tetraedre :
 186 c 2.1.1. ==> son numero homard dans le maillage precedent
 187 c
 188         if ( deraff ) then
 189           tehn = anctet(tehnp1)
 190         else
 191           tehn = tehnp1
 192         endif
 193 c
 194 c 2.1.2. ==> l'historique de son etat
 195 c          On rappelle que l'etat vaut :
 196 c      etan = 0 : le tetraedre etait actif.
 197 c      etan = 21, ..., 26 : le tetraedre etait coupe en 2 selon
 198 c                           l'arete 1, ..., 6 ; il y a eu deraffinement.
 199 c      etan = 41, ..., 44 : le tetraedre etait coupe en 4 selon la
 200 c                           face 1, ..., 4 ; il y a eu deraffinement.
 201 c      etan = 45, 46, 47 : le tetraedre etait coupe en 4 selon la
 202 c                          diagonale 1-6, 2-5, 3-4 ; il y a eu
 203 c                          deraffinement.
 204 c      etan = 55 : le tetraedre n'existait pas ; il a ete produit par
 205 c                  un decoupage.
 206 c      etan = 85, 86, 87 : le tetraedre etait coupe en 8 selon la
 207 c                          diagonale 1-6, 2-5, 3-4 ; il y a eu
 208 c                          deraffinement.
 209 c
 210         etanp1 = mod(hettet(tehnp1),100)
 211         etan   = (hettet(tehnp1)-etanp1) / 100
 212 c
 213 cgn        write (ulsort,1792) 'Tetraedre', tehn, etan, tehnp1, etanp1
 214 c
 215 c=======================================================================
 216 c doc.0.p. ==> etan = 0 : le tetraedre etait actif
 217 c=======================================================================
 218 c
 219         if ( etan.eq.0 ) then
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222           write (ulsort,texte(langue,3)) 'PCSPT0', nompro
 223 #endif
 224 c
 225           call pcspt0 ( etan, etanp1, tehn, tehnp1,
 226      >                  prfcan, prfcap,
 227      >                  filtet,
 228      >                  nteeca, ntesca,
 229      >                  nbfonc, ngauss, vafoen, vafott,
 230      >                  ulsort, langue, codret )
 231 c
 232 c=======================================================================
 233 c doc.21-26.p. ==> etan = 21, ..., 26 : le tetraedre etait coupe en 2
 234 c=======================================================================
 235 c
 236         elseif ( etan.ge.21 .and. etan.le.26 ) then
 237 c
 238 #ifdef _DEBUG_HOMARD_
 239           write (ulsort,texte(langue,3)) 'PCSPT2', nompro
 240 #endif
 241 c
 242           call pcspt2 ( etan, etanp1, tehn, tehnp1,
 243      >                  prfcan, prfcap,
 244      >                  hettet, filtet, nbante, anfite,
 245      >                  nteeca, ntesca,
 246      >                  nbfonc, ngauss, vafoen, vafott,
 247      >                  ulsort, langue, codret )
 248 c
 249 c=======================================================================
 250 c doc.41-44.p. ==> etan = 41, ..., 44 : le tetraedre etait coupe en 4
 251 c                  selon la face 1, 2, 3, 4
 252 c doc.45-47.p. ==> etan = 45, 46, 47 : le tetraedre etait coupe en 4
 253 c                  selon une diagonale
 254 c=======================================================================
 255 c
 256         elseif ( etan.ge.41 .and. etan.le.47 ) then
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259           write (ulsort,texte(langue,3)) 'PCSPT4', nompro
 260 #endif
 261 c
 262           call pcspt4 ( etan, etanp1, tehn, tehnp1,
 263      >                  prfcan, prfcap,
 264      >                  hettet, filtet, nbante, anfite,
 265      >                  nteeca, ntesca,
 266      >                  nbfonc, ngauss, vafoen, vafott,
 267      >                  ulsort, langue, codret )
 268 c
 269 c=======================================================================
 270 c doc.85-87.p. ==> etan = 85, 86, 87 : le tetraedre etait coupe en 8
 271 c                  selon une diagonale
 272 c=======================================================================
 273 c
 274         elseif ( etan.ge.85 .and. etan.le.87 ) then
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277           write (ulsort,texte(langue,3)) 'PCSPT8', nompro
 278 #endif
 279 c
 280           call pcspt8 ( etanp1, tehn, tehnp1,
 281      >                  prfcan, prfcap,
 282      >                  filtet, nbante, anfite,
 283      >                  nteeca, ntesca,
 284      >                  nbfonc, ngauss, vafoen, vafott,
 285      >                  ulsort, langue, codret )
 286 c
 287         endif
 288 c
 289    30 continue
 290 c
 291       endif
 292 c
 293       endif
 294 c
 295 c====
 296 c 4. la fin
 297 c====
 298 c
 299       if ( codret.ne.0 ) then
 300 c
 301 #include "envex2.h"
 302 c
 303       write (ulsort,texte(langue,1)) 'Sortie', nompro
 304       write (ulsort,texte(langue,2)) codret
 305 c
 306       endif
 307 c
 308 #ifdef _DEBUG_HOMARD_
 309       write (ulsort,texte(langue,1)) 'Sortie', nompro
 310       call dmflsh (iaux)
 311 #endif
 312 c
 313       end