src/tool/AP_Conversion/pcspt0.F

   1       subroutine pcspt0 ( etan, etanp1, tehn, tehnp1,
   2      >                    prfcan, prfcap,
   3      >                    filtet,
   4      >                    nteeca, ntesca,
   5      >                    nbfonc, ngauss, 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 Points de Gauss -
  28 c     -                 -             -        -
  29 c                       Tetraedres d'etat anterieur 0
  30 c                       -                           -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . etan   . e   .    1   . ETAt du tetraedre a l'iteration N          .
  36 c . etanp1 . e   .    1   . ETAt du tetraedre a l'iteration N+1        .
  37 c . tehn   . e   .    1   . TEtraedre courant en numerotation Homard   .
  38 c .        .     .        . a l'iteration N                            .
  39 c . tehnp1 . e   .    1   . TEtraedre courant en numerotation Homard   .
  40 c .        .     .        . a l'iteration N+1                          .
  41 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  42 c .        .     .        . 0 : l'entite est absente du profil         .
  43 c .        .     .        . i : l'entite est au rang i dans le profil  .
  44 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  45 c .        .     .        . 0 : l'entite est absente du profil         .
  46 c .        .     .        . 1 : l'entite est presente dans le profil   .
  47 c . filtet . e   . nbteto . premier fils des tetraedres                .
  48 c . nteeca . e   . reteto . numero des tetraedres dans le calcul entree.
  49 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
  50 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  51 c . ngauss . e   .   1    . nbre de points de Gauss des fonctions pg   .
  52 c . vafoen . e   . nbfonc*. variables en entree de l'adaptation        .
  53 c .        .     . ngauss*.                                            .
  54 c .        .     . nbeven .                                            .
  55 c . vafott . es  . nbfonc*. tableau temporaire de la solution          .
  56 c .        .     . ngauss*.                                            .
  57 c .        .     . nbevso .                                            .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c .        .     .        . 1 : probleme                               .
  64 c ______________________________________________________________________
  65 c
  66 c====
  67 c 0. declarations et dimensionnement
  68 c====
  69 c
  70 c 0.1. ==> generalites
  71 c
  72       implicit none
  73       save
  74 c
  75       character*6 nompro
  76       parameter ( nompro = 'PCSPT0' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "nombte.h"
  83 #include "nombsr.h"
  84 #include "nomber.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       integer etan, etanp1, tehn, tehnp1
  89       integer nbfonc, ngauss
  90       integer prfcan(*), prfcap(*)
  91       integer filtet(nbteto)
  92       integer nteeca(reteto), ntesca(rsteto)
  93 c
  94       double precision vafoen(nbfonc,ngauss,*)
  95       double precision vafott(nbfonc,ngauss,*)
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101 #ifdef _DEBUG_HOMARD_
 102       integer iaux
 103 #endif
 104 c
 105 c     tecn   = TEtraedre courant en numerotation du Calcul a l'it. N
 106 c     tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1
 107 c
 108       integer tecn, tecnp1
 109 c
 110 c     f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1
 111 c     f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1
 112 c     f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1
 113 c     f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1
 114 c     f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1
 115 c     f5cp = Fils 5eme du tetraedre en numerota. du Calcul a l'it. N+1
 116 c     f6cp = Fils 6eme du tetraedre en numerota. du Calcul a l'it. N+1
 117 c     f7cp = Fils 7eme du tetraedre en numerota. du Calcul a l'it. N+1
 118 c     f8cp = Fils 8eme du tetraedre en numerota. du Calcul a l'it. N+1
 119 c
 120       integer f1hp
 121       integer f1cp, f2cp, f3cp, f4cp, f5cp, f6cp, f7cp, f8cp
 122 c
 123       integer coderr
 124       integer nrofon, nugaus
 125 c
 126       double precision daux
 127       double precision daux1
 128 c
 129       integer nbmess
 130       parameter ( nbmess = 10 )
 131       character*80 texte(nblang,nbmess)
 132 c
 133 c 0.5. ==> initialisations
 134 c ______________________________________________________________________
 135 c
 136 c====
 137 c 1. initialisations
 138 c====
 139 c
 140 #include "impr01.h"
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143       write (ulsort,texte(langue,1)) 'Entree', nompro
 144       call dmflsh (iaux)
 145 #endif
 146 c
 147       texte(1,4) =
 148      >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)'
 149       texte(1,5) =
 150      >'(  ''                  etat a l''''iteration '',a3,''   : '',i4)'
 151 c
 152       texte(2,4) =
 153      >'(/,''Current tetrahedron : # at iteration '',a3,''     : '',i10)'
 154       texte(2,5) =
 155      > '(  ''                     status at iteration '',a3,'' : '',i4)'
 156 c
 157 #include "impr03.h"
 158 c
 159       coderr = 0
 160 c
 161 c 1.2. ==> on repere son ancien numero dans le calcul
 162 c
 163       tecn = nteeca(tehn)
 164 cgn        write (ulsort,texte(langue,4)) 'nca', tecn
 165 cgn        write (ulsort,*) 'prfcan(tecn)', prfcan(tecn)
 166 cgncc      if ( prfcan(tecn).eq.0 ) then
 167 cgn        write (ulsort,texte(langue,4)) 'n  ', tehn
 168 cgn        write (ulsort,texte(langue,5)) 'n  ', etan
 169 cgncc      endif
 170 c
 171 c====
 172 c 2. etan = 0 : le tetraedre etait actif
 173 c    On explore tous les etats du tetraedre a l'iteration n+1
 174 c====
 175 c
 176       if ( prfcan(tecn).gt.0 ) then
 177 c
 178 c ===> etanp1 = 0 : le tetraedre etait actif et l'est encore ;
 179 c               il est inchange
 180 c             c'est le cas le plus simple : on prend la valeur de la
 181 c             fonction associee a l'ancien numero du tetraedre.
 182 c
 183       if ( etanp1.eq.0 ) then
 184 c
 185         tecnp1 = ntesca(tehnp1)
 186         prfcap(tecnp1) = 1
 187 c
 188 cgn      write (ulsort,90002) 'tecnp1',tecnp1
 189         do 21 , nrofon = 1, nbfonc
 190           do 211 , nugaus = 1 , ngauss
 191 cgn        write (ulsort,92010) vafoen(nrofon,nugaus,prfcan(tecn))
 192             vafott(nrofon,nugaus,tecnp1) =
 193      >                                vafoen(nrofon,nugaus,prfcan(tecn))
 194   211     continue
 195    21  continue
 196 cgn        write(ulsort,91010) tecn,-1,tecnp1
 197 c
 198 c ==> etanp1 = 21, ..., 26 : le tetraedre etait actif et
 199 c                  est decoupe en 2.
 200 c            les deux fils prennent la valeur de la fonction sur le pere
 201 c
 202       elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then
 203 c
 204         f1hp = filtet(tehnp1)
 205         f1cp = ntesca(f1hp)
 206         f2cp = ntesca(f1hp+1)
 207         prfcap(f1cp) = 1
 208         prfcap(f2cp) = 1
 209         daux1 = 1.d0/dble(ngauss)
 210         do 22 , nrofon = 1, nbfonc
 211           daux = vafoen(nrofon,1,prfcan(tecn))
 212 cgn        write (ulsort,*) 'daux', daux
 213           do 221 , nugaus = 2, ngauss
 214             daux = daux + vafoen(nrofon,nugaus,prfcan(tecn))
 215   221     continue
 216           daux = daux*daux1
 217           do 222 , nugaus = 1 , ngauss
 218             vafott(nrofon,nugaus,f1cp) = daux
 219             vafott(nrofon,nugaus,f2cp) = daux
 220   222   continue
 221    22   continue
 222 cgn        write(12,91010) f1cp,f2cp
 223 cgn        write(ulsort,91010) tecn,-1,
 224 cgn     >                     f1cp,f2cp
 225 c
 226 c ==> etanp1 = 41, ... 47 : le tetraedre etait actif et est
 227 c                  decoupe en 4.
 228 c            les quatre fils prennent la valeur de la fonction sur le
 229 c            pere
 230 c
 231       elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then
 232 c
 233         f1hp = filtet(tehnp1)
 234         f1cp = ntesca(f1hp)
 235         f2cp = ntesca(f1hp+1)
 236         f3cp = ntesca(f1hp+2)
 237         f4cp = ntesca(f1hp+3)
 238         prfcap(f1cp) = 1
 239         prfcap(f2cp) = 1
 240         prfcap(f3cp) = 1
 241         prfcap(f4cp) = 1
 242         daux1 = 1.d0/dble(ngauss)
 243         do 23 , nrofon = 1, nbfonc
 244           daux = vafoen(nrofon,1,prfcan(tecn))
 245           do 231 , nugaus = 2, ngauss
 246             daux = daux + vafoen(nrofon,nugaus,prfcan(tecn))
 247   231     continue
 248           daux = daux*daux1
 249           do 232 , nugaus = 1 , ngauss
 250             vafott(nrofon,nugaus,f1cp) = daux
 251             vafott(nrofon,nugaus,f2cp) = daux
 252             vafott(nrofon,nugaus,f3cp) = daux
 253             vafott(nrofon,nugaus,f4cp) = daux
 254   232   continue
 255    23   continue
 256 cgn        write(13,91010) f1cp,f2cp,f3cp,f4cp
 257 cgn        write(ulsort,91010) tecn,-1,
 258 cgn     >                     f1cp,f2cp,f3cp,f4cp
 259 c
 260 c ==> etanp1 = 81, 86, 87 : le tetraedre etait actif et est
 261 c                  decoupe en 8.
 262 c            les huit fils prennent la valeur de la fonction sur le
 263 c            pere
 264 c
 265       elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then
 266 c
 267         f1hp = filtet(tehnp1)
 268         f1cp = ntesca(f1hp)
 269         f2cp = ntesca(f1hp+1)
 270         f3cp = ntesca(f1hp+2)
 271         f4cp = ntesca(f1hp+3)
 272         f5cp = ntesca(f1hp+4)
 273         f6cp = ntesca(f1hp+5)
 274         f7cp = ntesca(f1hp+6)
 275         f8cp = ntesca(f1hp+7)
 276         prfcap(f1cp) = 1
 277         prfcap(f2cp) = 1
 278         prfcap(f3cp) = 1
 279         prfcap(f4cp) = 1
 280         prfcap(f5cp) = 1
 281         prfcap(f6cp) = 1
 282         prfcap(f7cp) = 1
 283         prfcap(f8cp) = 1
 284         daux1 = 1.d0/dble(ngauss)
 285         do 24 , nrofon = 1, nbfonc
 286           daux = vafoen(nrofon,1,prfcan(tecn))
 287           do 241 , nugaus = 2, ngauss
 288             daux = daux + vafoen(nrofon,nugaus,prfcan(tecn))
 289   241     continue
 290           daux = daux*daux1
 291           do 242 , nugaus = 1 , ngauss
 292             vafott(nrofon,nugaus,f1cp) = daux
 293             vafott(nrofon,nugaus,f2cp) = daux
 294             vafott(nrofon,nugaus,f3cp) = daux
 295             vafott(nrofon,nugaus,f4cp) = daux
 296             vafott(nrofon,nugaus,f5cp) = daux
 297             vafott(nrofon,nugaus,f6cp) = daux
 298             vafott(nrofon,nugaus,f7cp) = daux
 299             vafott(nrofon,nugaus,f8cp) = daux
 300   242     continue
 301    24   continue
 302 cgn        write(14,91010) f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp
 303 cgn        write(ulsort,91010) tecn,-1,
 304 cgn     >                     f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp
 305 c
 306 c ==> aucun autre etat sur le tetraedre courant n'est possible
 307 c
 308       else
 309 c
 310         coderr = 1
 311         write (ulsort,texte(langue,4)) 'n  ', tehn
 312         write (ulsort,texte(langue,5)) 'n  ', etan
 313         write (ulsort,texte(langue,4)) 'n+1', tehnp1
 314         write (ulsort,texte(langue,5)) 'n+1', etanp1
 315 c
 316       endif
 317 c
 318       endif
 319 c
 320 c====
 321 c 3. la fin
 322 c====
 323 c
 324       if ( coderr.ne.0 ) then
 325 c
 326       write (ulsort,texte(langue,1)) 'Sortie', nompro
 327       write (ulsort,texte(langue,2)) coderr
 328       codret = codret + 1
 329 c
 330       endif
 331 c
 332       end