src/tool/AP_Conversion/pcseh8.F

   1       subroutine pcseh8 ( etanp1, hehnp1, typint,
   2      >                    prfcan, prfcap,
   3      >                    ficn,
   4      >                    nfpyrp, nftetp, ficp, propor,
   5      >                    nhesca,
   6      >                    nbfonc, vafoen, vafott,
   7      >                            vatett,
   8      >                            prftep,
   9      >                            vapytt,
  10      >                            prfpyp,
  11      >                    ulsort, langue, codret )
  12 c ______________________________________________________________________
  13 c
  14 c                             H O M A R D
  15 c
  16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  17 c
  18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  19 c aupres des huissiers de justice Simart et Lavoir a Clamart
  20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  21 c aupres des huissiers de justice
  22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  23 c
  24 c    HOMARD est une marque deposee d'Electricite de France
  25 c
  26 c Copyright EDF 1996
  27 c Copyright EDF 1998
  28 c Copyright EDF 2002
  29 c Copyright EDF 2020
  30 c ______________________________________________________________________
  31 c
  32 c    aPres adaptation - Conversion de Solution Elements de volume -
  33 c     -                 -             -        -
  34 c                       Hexaedres d'etat anterieur 80
  35 c                       -                          -
  36 c remarque : pcseh8 et pcsep8 sont des clones
  37 c ______________________________________________________________________
  38 c .        .     .        .                                            .
  39 c .  nom   . e/s . taille .           description                      .
  40 c .____________________________________________________________________.
  41 c . etanp1 . e   .    1   . ETAt du hexaedre a l'iteration N+1         .
  42 c . hehnp1 . e   .    1   . Hexaedre courant en numerotation Homard    .
  43 c .        .     .        . a l'iteration N+1                          .
  44 c . typint . e   .   1    . type d'interpolation                       .
  45 c .        .     .        .  0, si automatique                         .
  46 c .        .     .        .  elements : 0 si intensif, sans orientation.
  47 c .        .     .        .             1 si extensif, sans orientation.
  48 c .        .     .        .             2 si intensif, avec orientation.
  49 c .        .     .        .             3 si extensif, avec orientation.
  50 c .        .     .        .  noeuds : 1 si degre 1                     .
  51 c .        .     .        .           2 si degre 2                     .
  52 c .        .     .        .           3 si iso-P2                      .
  53 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  54 c .        .     .        . 0 : l'entite est absente du profil         .
  55 c .        .     .        . i : l'entite est au rang i dans le profil  .
  56 c . prfcap . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  57 c .        .     .        . 0 : l'entite est absente du profil         .
  58 c .        .     .        . 1 : l'entite est presente dans le profil   .
  59 c . ficn   . e   .  3,18  . fils en numerotation du calcul n           .
  60 c .        .     .        . 1 : hexaedres                              .
  61 c .        .     .        . 2 : pyramides                              .
  62 c .        .     .        . 3 : tetraedres                             .
  63 c . nfpyrp . e   .    1   . nombre de fils pyramides n+1               .
  64 c . nftetp . e   .    1   . nombre de fils tetraedres n+1              .
  65 c . ficp   . e   .  3,18  . fils en numerotation du calcul n+1         .
  66 c .        .     .        . 1 : hexaedres                              .
  67 c .        .     .        . 2 : pyramides                              .
  68 c .        .     .        . 3 : tetraedres                             .
  69 c . nhesca . e   . rsheto . numero des hexaedres dans le calcul sortie .
  70 c . nbfonc . e   .    1   . nombre de fonctions elements de volume     .
  71 c . vafoen . e   . nbfonc*. variables en entree de l'adaptation        .
  72 c .        .     . nbeven .                                            .
  73 c . vafott . es  . nbfonc*. variables en sortie de l'adaptation        .
  74 c .        .     . nbevso .                                            .
  75 c . vatett .   a . nbfonc*. tableau temporaire de la solution pour     .
  76 c .        .     .    *   . les tetraedres                             .
  77 c . prftep . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  78 c .        .     .        . 0 : le tetraedre est absent du profil      .
  79 c .        .     .        . 1 : le tetraedre est present dans le profil.
  80 c . vapytt .   a . nbfonc*. tableau temporaire de la solution pour     .
  81 c .        .     .    *   . les pyramides                              .
  82 c . prfpyp . es  .   *    . En numero du calcul a l'iteration n+1 :    .
  83 c .        .     .        . 0 : la pyramide est absente du profil      .
  84 c .        .     .        . 1 : la pyramide est presente dans le profil
  85 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  86 c . langue . e   .    1   . langue des messages                        .
  87 c .        .     .        . 1 : francais, 2 : anglais                  .
  88 c . codret . es  .    1   . code de retour des modules                 .
  89 c .        .     .        . 0 : pas de probleme                        .
  90 c .        .     .        . 1 : probleme                               .
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 0. declarations et dimensionnement
  95 c====
  96 c
  97 c 0.1. ==> generalites
  98 c
  99       implicit none
 100       save
 101 c
 102       character*6 nompro
 103       parameter ( nompro = 'PCSEH8' )
 104 c
 105 #include "nblang.h"
 106 #include "fractf.h"
 107 c
 108 c 0.2. ==> communs
 109 c
 110 #include "nombsr.h"
 111 c
 112 c 0.3. ==> arguments
 113 c
 114       integer etanp1, hehnp1
 115       integer typint
 116       integer nbfonc
 117       integer prfcan(*), prfcap(*)
 118 c
 119       integer ficn(3,18)
 120       integer nfpyrp, nftetp
 121       integer ficp(3,18)
 122 c
 123       integer nhesca(rsheto)
 124       integer prftep(*)
 125       integer prfpyp(*)
 126 c
 127       double precision propor(18)
 128       double precision vafoen(nbfonc,*)
 129       double precision vafott(nbfonc,*)
 130       double precision vatett(nbfonc,*)
 131       double precision vapytt(nbfonc,*)
 132 c
 133       integer ulsort, langue, codret
 134 c
 135 c 0.4. ==> variables locales
 136 c
 137       integer iaux
 138       integer hecnp1
 139       integer nrofon
 140 c
 141       logical afaire
 142 c
 143       double precision daux
 144 c
 145       integer nbmess
 146       parameter ( nbmess = 10 )
 147       character*80 texte(nblang,nbmess)
 148 c
 149 c 0.5. ==> initialisations
 150 c ______________________________________________________________________
 151 c
 152 c====
 153 c 1. initialisations
 154 c====
 155 c
 156 #include "impr01.h"
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,1)) 'Entree', nompro
 160       call dmflsh (iaux)
 161 #endif
 162 #include "impr03.h"
 163 c
 164       codret = 0
 165 c
 166 c====
 167 c 2. seulement si des valeurs existent
 168 c====
 169 c
 170       afaire = .true.
 171 c
 172       do 21 , iaux = 1 , 8
 173         if ( prfcan(ficn(1,iaux)).eq.0 ) then
 174           afaire = .false.
 175         endif
 176    21 continue
 177 c
 178       if ( afaire ) then
 179 c
 180 c====
 181 c 3. L'hexaedre etait coupe en 8 hexaedres
 182 c====
 183 c 3.1. ==> etanp1 = 0 : l'hexaedre est reactive.
 184 c          on lui attribue la valeur moyenne sur les huit anciens fils.
 185 c          remarque : cela arrive seulement avec du deraffinement.
 186 c====
 187 c
 188 cgn      write(ulsort,90002) 'etanp1', etanp1
 189       if ( etanp1.eq.0 ) then
 190 c
 191         hecnp1 = nhesca(hehnp1)
 192         prfcap(hecnp1) = 1
 193 c
 194         if ( typint.eq.0 ) then
 195 c
 196           do 310 , nrofon = 1, nbfonc
 197 c
 198             daux = 0.d0
 199             do 3101 , iaux = 1 , 8
 200               daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux)))
 201  3101       continue
 202 c
 203             vafott(nrofon,hecnp1) = daux * unshu
 204 c
 205   310     continue
 206 c
 207         else
 208 c
 209           do 311 , nrofon = 1, nbfonc
 210 c
 211             daux = 0.d0
 212             do 3111 , iaux = 1 , 8
 213               daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux)))
 214  3111       continue
 215 c
 216             vafott(nrofon,hecnp1) = daux
 217 c
 218   311     continue
 219 c
 220         endif
 221 c
 222 c 3.2. ==> un decoupage de conformite
 223 c
 224       elseif ( etanp1.ge.11 ) then
 225 c
 226         if ( typint.eq.0 ) then
 227 c
 228           do 320 , nrofon = 1, nbfonc
 229 c
 230             daux = 0.d0
 231             do 3201 , iaux = 1 , 8
 232               daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux)))
 233  3201       continue
 234             daux = daux * unshu
 235 c
 236             do 3203 , iaux = 1 , nfpyrp
 237               vapytt(nrofon,ficp(2,iaux)) = daux
 238  3203       continue
 239             do 3204 , iaux = 1 , nftetp
 240               vatett(nrofon,ficp(3,iaux)) = daux
 241  3204       continue
 242 c
 243   320     continue
 244 c
 245         else
 246 c
 247           do 321 , nrofon = 1, nbfonc
 248 c
 249             daux = 0.d0
 250             do 3211 , iaux = 1 , 8
 251               daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux)))
 252  3211       continue
 253 c
 254             do 3213 , iaux = 1 , nfpyrp
 255               vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux)
 256  3213       continue
 257             do 3214 , iaux = 1 , nftetp
 258               vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp)
 259  3214       continue
 260 c
 261   321     continue
 262 c
 263         endif
 264 c
 265       endif
 266 c
 267 c====
 268 c 4. affectation des profils
 269 c====
 270 c
 271       if ( codret.eq.0 ) then
 272 c
 273       do 42 , iaux = 1 , nfpyrp
 274         prfpyp(ficp(2,iaux)) = 1
 275    42 continue
 276 c
 277       do 43 , iaux = 1 , nftetp
 278         prftep(ficp(3,iaux)) = 1
 279    43 continue
 280 c
 281       endif
 282 c
 283       endif
 284 c
 285 c====
 286 c 5. la fin
 287 c====
 288 c
 289       if ( codret.ne.0 ) then
 290 c
 291       write (ulsort,texte(langue,1)) 'Sortie', nompro
 292       write (ulsort,texte(langue,2)) codret
 293 c
 294       endif
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,texte(langue,1)) 'Sortie', nompro
 298       call dmflsh (iaux)
 299 #endif
 300 c
 301       end