src/tool/AP_Conversion/pcset8.F

   1       subroutine pcset8 ( etanp1, tehn, tehnp1, typint,
   2      >                    prfcan, prfcap,
   3      >                    filtet, nbante, anfite,
   4      >                    nteeca, ntesca,
   5      >                    nbfonc, vafoen, vafott,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    aPres adaptation - Conversion de Solution Elements de Volume -
  28 c     -                 -             -        -           -
  29 c                       Tetraedres d'etat anterieur 8
  30 c                       -                           -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . etanp1 . e   .    1   . ETAt du tetraedre a l'iteration N+1        .
  36 c . tehn   . e   .    1   . TEtraedre courant en numerotation Homard   .
  37 c .        .     .        . a l'iteration N                            .
  38 c . tehnp1 . e   .    1   . TEtraedre courant en numerotation Homard   .
  39 c .        .     .        . a l'iteration N+1                          .
  40 c . typint . e   .   1    . type d'interpolation                       .
  41 c .        .     .        .  0, si automatique                         .
  42 c .        .     .        .  elements : 0 si intensif, sans orientation.
  43 c .        .     .        .             1 si extensif, sans orientation.
  44 c .        .     .        .             2 si intensif, avec orientation.
  45 c .        .     .        .             3 si extensif, avec orientation.
  46 c .        .     .        .  noeuds : 1 si degre 1                     .
  47 c .        .     .        .           2 si degre 2                     .
  48 c .        .     .        .           3 si iso-P2                      .
  49 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  50 c .        .     .        . 0 : l'entite est absente du profil         .
  51 c .        .     .        . i : l'entite est au rang i dans le profil  .
  52 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  53 c .        .     .        . 0 : l'entite est absente du profil         .
  54 c .        .     .        . 1 : l'entite est presente dans le profil   .
  55 c . filtet . e   . nbteto . premier fils des tetraedres                .
  56 c . nbante . e   .   1    . nombre de tetraedres decoupes par   .
  57 c .        .     .        . conformite sur le maillage avant adaptation.
  58 c . anfite . e   . nbante . tableau filtet du maillage de l'iteration n
  59 c . nteeca . e   . reteto . numero des tetraedres dans le calcul entree.
  60 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
  61 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  62 c . vafoen . e   . nbfonc*. variables en entree de l'adaptation        .
  63 c .        .     . nbeven .                                            .
  64 c . vafott . es  . nbfonc*. variables en sortie de l'adaptation        .
  65 c .        .     . nbevso .                                            .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 1 : probleme                               .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'PCSET8' )
  85 c
  86 #include "nblang.h"
  87 #include "fracta.h"
  88 #include "fractc.h"
  89 #include "fractf.h"
  90 c
  91 c 0.2. ==> communs
  92 c
  93 #include "nombte.h"
  94 #include "nombsr.h"
  95 #include "nomber.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer etanp1, tehn, tehnp1
 100       integer typint
 101       integer nbfonc
 102       integer prfcan(*), prfcap(*)
 103       integer filtet(nbteto)
 104       integer nbante
 105       integer anfite(nbante)
 106       integer nteeca(reteto), ntesca(rsteto)
 107 c
 108       double precision vafoen(nbfonc,*)
 109       double precision vafott(nbfonc,*)
 110 c
 111       integer ulsort, langue, codret
 112 c
 113 c 0.4. ==> variables locales
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       integer iaux
 117 #endif
 118 c
 119 c     tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1
 120 c
 121       integer tecnp1
 122 c
 123 c     f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1
 124 c     f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1
 125 c     f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1
 126 c     f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1
 127 c     f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1
 128
 129       integer f1hp
 130       integer f1cp, f2cp, f3cp, f4cp
 131 c
 132 c     f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N
 133 c     f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N
 134 c     f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N
 135 c     f3cn = Fils 3eme du tetraedre en numerotation du Calcul a l'it. N
 136 c     f4cn = Fils 4eme du tetraedre en numerotation du Calcul a l'it. N
 137 c     f5cn = Fils 5eme du tetraedre en numerotation du Calcul a l'it. N
 138 c     f6cn = Fils 6eme du tetraedre en numerotation du Calcul a l'it. N
 139 c     f7cn = Fils 7eme du tetraedre en numerotation du Calcul a l'it. N
 140 c     f8cn = Fils 8eme du tetraedre en numerotation du Calcul a l'it. N
 141 c
 142       integer f1hn
 143       integer f1cn, f2cn, f3cn, f4cn, f5cn, f6cn, f7cn, f8cn
 144 c
 145       integer nrofon
 146       integer coderr
 147 c
 148       double precision daux
 149       double precision daux1
 150 c
 151       integer nbmess
 152       parameter ( nbmess = 10 )
 153       character*80 texte(nblang,nbmess)
 154 c
 155 c 0.5. ==> initialisations
 156 c ______________________________________________________________________
 157 c
 158 c====
 159 c 1. initialisations
 160 c====
 161 c
 162 #include "impr01.h"
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,texte(langue,1)) 'Entree', nompro
 166       call dmflsh (iaux)
 167 #endif
 168 c
 169       coderr = 0
 170 c
 171 c 1.2. ==> on repere les numeros dans le calcul pour ses huit fils
 172 c         a l'iteration n
 173 c
 174       f1hn = anfite(tehn)
 175       f1cn = nteeca(f1hn)
 176       f2cn = nteeca(f1hn+1)
 177       f3cn = nteeca(f1hn+2)
 178       f4cn = nteeca(f1hn+3)
 179       f5cn = nteeca(f1hn+4)
 180       f6cn = nteeca(f1hn+5)
 181       f7cn = nteeca(f1hn+6)
 182       f8cn = nteeca(f1hn+7)
 183 c
 184       if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and.
 185      >     prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 .and.
 186      >     prfcan(f5cn).gt.0 .and. prfcan(f6cn).gt.0 .and.
 187      >     prfcan(f7cn).gt.0 .and. prfcan(f8cn).gt.0 ) then
 188 c
 189 c====
 190 c 2. etan = 85, 86, 87 : le tetraedre etait coupe en 8
 191 c====
 192 c
 193 c 2.1. ==> etanp1 = 0 : le tetraedre est reactive.
 194 c             remarque : cela arrive seulement avec du deraffinement.
 195 c
 196       if ( etanp1.eq.0 ) then
 197 c
 198         tecnp1 = ntesca(tehnp1)
 199         prfcap(tecnp1) = 1
 200 c
 201         if ( typint.eq.0 ) then
 202           do 210 , nrofon = 1, nbfonc
 203             daux = unshu * ( vafoen(nrofon,prfcan(f1cn))
 204      >                     + vafoen(nrofon,prfcan(f2cn))
 205      >                     + vafoen(nrofon,prfcan(f3cn))
 206      >                     + vafoen(nrofon,prfcan(f4cn))
 207      >                     + vafoen(nrofon,prfcan(f5cn))
 208      >                     + vafoen(nrofon,prfcan(f6cn))
 209      >                     + vafoen(nrofon,prfcan(f7cn))
 210      >                     + vafoen(nrofon,prfcan(f8cn)) )
 211             vafott(nrofon,tecnp1) = daux
 212  210     continue
 213         else
 214           do 211 , nrofon = 1, nbfonc
 215             daux = vafoen(nrofon,prfcan(f1cn))
 216      >           + vafoen(nrofon,prfcan(f2cn))
 217      >           + vafoen(nrofon,prfcan(f3cn))
 218      >           + vafoen(nrofon,prfcan(f4cn))
 219      >           + vafoen(nrofon,prfcan(f5cn))
 220      >           + vafoen(nrofon,prfcan(f6cn))
 221      >           + vafoen(nrofon,prfcan(f7cn))
 222      >           + vafoen(nrofon,prfcan(f8cn))
 223             vafott(nrofon,tecnp1) = daux
 224  211     continue
 225         endif
 226 cgn        write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f
 227 cgn        write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1,
 228 cgn     >                 tecnp1
 229 cgn        write(81,7777) tecnp1
 230 c
 231 c 2.2. ==> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux
 232 c             c'est ce qui se passe quand un decoupage de conformite
 233 c             est cree apres du deraffinement.
 234 c             on donne la valeur moyenne de la fonction sur les huit
 235 c             anciens fils a chaque nouveau fils.
 236 c             remarque : on pourrait certainement faire mieux, avec des
 237 c                        moyennes ponderees en fonction du recouvrement
 238 c                        des anciennes et nouvelles filles. c'est trop
 239 c                        complique pour que cela vaille le coup.
 240 c             remarque : cela arrive seulement avec du deraffinement.
 241 c
 242       elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then
 243 c
 244         f1hp = filtet(tehnp1)
 245         f1cp = ntesca(f1hp)
 246         f2cp = ntesca(f1hp+1)
 247         prfcap(f1cp) = 1
 248         prfcap(f2cp) = 1
 249         if ( typint.eq.0 ) then
 250           daux1 = unshu
 251         else
 252           daux1 = unsde
 253         endif
 254         do 22 , nrofon = 1, nbfonc
 255           daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 256      >                   + vafoen(nrofon,prfcan(f2cn))
 257      >                   + vafoen(nrofon,prfcan(f3cn))
 258      >                   + vafoen(nrofon,prfcan(f4cn))
 259      >                   + vafoen(nrofon,prfcan(f5cn))
 260      >                   + vafoen(nrofon,prfcan(f6cn))
 261      >                   + vafoen(nrofon,prfcan(f7cn))
 262      >                   + vafoen(nrofon,prfcan(f8cn)) )
 263           vafott(nrofon,f1cp) = daux
 264           vafott(nrofon,f2cp) = daux
 265    22   continue
 266 cgn        write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1,
 267 cgn     >                 f1cp,f2cp
 268 cgn        write(82,7777) f1cp,f2cp
 269 c
 270 c 2.3. ==> etanp1 = 41, ..., 44 : le tetraedre est
 271 c                      decoupe en quatre par une face.
 272 c                       etanp1 = 45, 46, 47 : le tetraedre est decoupe
 273 c                       en 4 par une diagonale
 274 c             c'est ce qui se passe quand un decoupage de conformite
 275 c             est cree apres du deraffinement.
 276 c             on donne la valeur moyenne de la fonction sur les huit
 277 c             anciens fils a chaque nouveau fils.
 278 c             remarque : on pourrait certainement faire mieux, avec des
 279 c                        moyennes ponderees en fonction du recouvrement
 280 c                        des anciens et nouveaux fils. c'est trop
 281 c                        complique pour que cela vaille le coup.
 282 c             remarque : cela arrive seulement avec du deraffinement.
 283 c
 284       elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then
 285 c
 286         f1hp = filtet(tehnp1)
 287         f1cp = ntesca(f1hp)
 288         f2cp = ntesca(f1hp+1)
 289         f3cp = ntesca(f1hp+2)
 290         f4cp = ntesca(f1hp+3)
 291         prfcap(f1cp) = 1
 292         prfcap(f2cp) = 1
 293         prfcap(f3cp) = 1
 294         prfcap(f4cp) = 1
 295         if ( typint.eq.0 ) then
 296           daux1 = unshu
 297         else
 298           daux1 = unsqu
 299         endif
 300         do 23 , nrofon = 1, nbfonc
 301           daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
 302      >                   + vafoen(nrofon,prfcan(f2cn))
 303      >                   + vafoen(nrofon,prfcan(f3cn))
 304      >                   + vafoen(nrofon,prfcan(f4cn))
 305      >                   + vafoen(nrofon,prfcan(f5cn))
 306      >                   + vafoen(nrofon,prfcan(f6cn))
 307      >                   + vafoen(nrofon,prfcan(f7cn))
 308      >                   + vafoen(nrofon,prfcan(f8cn)) )
 309           vafott(nrofon,f1cp) = daux
 310           vafott(nrofon,f2cp) = daux
 311           vafott(nrofon,f3cp) = daux
 312           vafott(nrofon,f4cp) = daux
 313   23    continue
 314 cgn        write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1,
 315 cgn     >                 f1cp,f2cp,f3cp,f4cp
 316 cgn        write(83,7777) f1cp,f2cp,f3cp,f4cp
 317 c
 318       endif
 319 c
 320       endif
 321 c
 322 c====
 323 c 3. la fin
 324 c====
 325 c
 326       if ( coderr.ne.0 ) then
 327 c
 328         write (ulsort,texte(langue,1)) 'Sortie', nompro
 329       write (ulsort,texte(langue,2)) coderr
 330       codret = codret + 1
 331 c
 332       endif
 333 c
 334       end