src/tool/AP_Conversion/pcstrg.F

   1       subroutine pcstrg ( nbfonc, ngauss, nbnorf, typgeo, deraff,
   2      >                    prfcan, prfcap,
   3      >                    hettri, anctri,
   4      >                    filtri,
   5      >                    nbantr, anfitr,
   6      >                    ntreca, ntrsca,
   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                       TRiangles 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 . hettri . e   . nbtrto . historique de l'etat des triangles         .
  51 c . filtri . e   . nbtrto . premier fils des triangles                 .
  52 c . nbantr . e   .   1    . nombre de triangles decoupes par           .
  53 c .        .     .        . conformite sur le maillage avant adaptation.
  54 c . anfitr . e   . nbantr . tableau filtri du maillage de l'iteration n.
  55 c . ntreca . e   .   *    . nro des triangles dans le calcul en entree .
  56 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  57 c . vafoen .   e . nbfonc*. variables en entree de l'adaptation        .
  58 c .        .     . ngauss .                                            .
  59 c . vafott .   a . nbfonc*. tableau temporaire de la solution          .
  60 c .        .     . ngauss .                                            .
  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 = 'PCSTRG' )
  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 "nombtr.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 hettri(nbtrto), anctri(*)
 104       integer filtri(nbtrto)
 105       integer nbantr, anfitr(nbantr)
 106       integer ntreca(retrto), ntrsca(rstrto)
 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 c     trhn   = TRiangle courant en numerotation Homard a l'iteration N
 120 c     trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1
 121 c
 122       integer trhn, trhnp1
 123 c
 124 c     etan   = ETAt du triangle a l'iteration N
 125 c     etanp1 = ETAt du triangle a l'iteration N+1
 126 c
 127       integer etan, etanp1
 128 c
 129       integer iaux
 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       write(ulsort,*) 'nbfonc, ngauss, nbtrto = ',nbfonc, ngauss, nbtrto
 149 #endif
 150 c
 151       texte(1,4) =
 152      >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)'
 153       texte(1,5) =
 154      > '(  ''                etat a l''''iteration '',a3,''   : '',i4)'
 155 c
 156       texte(2,4) =
 157      >'(/,''Current triangle : # at iteration '',a3,''     : '',i10)'
 158       texte(2,5) =
 159      > '(  ''              status at iteration '',a3,'' : '',i4)'
 160 c
 161 #include "impr03.h"
 162 c
 163 cgn      write (ulsort,90002) 'nbfonc, ngauss, nbnorf',
 164 cgn     >                      nbfonc,ngauss,nbnorf
 165 c
 166 c====
 167 c 2. on boucle sur tous les triangles actifs du maillage HOMARD n+1
 168 c    . soit il etait deja actif dans le maillage precedent : c'est un
 169 c      transfert direct des valeurs
 170 c    . soit il ne l'etait pas : il est donc issu d'un decoupage et on va
 171 c      calculer les valeurs aux points de Gauss en fonction des valeurs
 172 c      sur les noeuds.
 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 , trhnp1 = 1 , nbtrto
 184 c
 185 c 2.1. ==> caracteristiques du triangle :
 186 c 2.1.1. ==> son numero homard dans le maillage precedent
 187 c
 188         if ( deraff ) then
 189           trhn = anctri(trhnp1)
 190         else
 191           trhn = trhnp1
 192         endif
 193 c
 194 c 2.1.3. ==> l'historique de son etat
 195 c          On rappelle que l'etat vaut :
 196 c          etan = 0 : le triangle etait actif
 197 c          etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete
 198 c                           1, 2, 3 ; il y a eu deraffinement.
 199 c          etan = 4 : le triangle etait coupe en 4 ; il y a eu
 200 c                     deraffinement.
 201 c          etan = 5 : le triangle n'existait pas ; il a ete produit par
 202 c                     un decoupage.
 203 c          etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule
 204 c                           de l'arete etan-5 pour le suivi de
 205 c                           frontiere ; il y a eu deraffinement.
 206 c
 207         etanp1 = mod(hettri(trhnp1),10)
 208         etan = (hettri(trhnp1)-etanp1) / 10
 209 cgn        write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1
 210 c
 211 c=======================================================================
 212 c etan = 0 : le triangle etait actif
 213 c=======================================================================
 214 c
 215         if ( etan.eq.0 ) then
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218           write (ulsort,texte(langue,3)) 'PCSPTZ', nompro
 219 #endif
 220 c
 221           call pcsptz ( etan, etanp1, trhn, trhnp1,
 222      >                  prfcan, prfcap,
 223      >                  filtri,
 224      >                  ntreca, ntrsca,
 225      >                  nbfonc, ngauss, vafoen, vafott,
 226      >                  ulsort, langue, codret )
 227 c
 228 c=======================================================================
 229 c etan = 1, 2, 3 : le triangle etait coupe en 2
 230 c=======================================================================
 231 c
 232         elseif ( etan.ge.1 .and. etan.le.3 ) then
 233 c
 234 #ifdef _DEBUG_HOMARD_
 235           write (ulsort,texte(langue,3)) 'PCSPTD', nompro
 236 #endif
 237 c
 238           call pcsptd ( etan, etanp1, trhn, trhnp1,
 239      >                  prfcan, prfcap,
 240      >                  hettri, filtri, nbantr, anfitr,
 241      >                  ntreca, ntrsca,
 242      >                  nbfonc, ngauss, vafoen, vafott,
 243      >                  ulsort, langue, codret )
 244 c
 245 c=======================================================================
 246 c etan = 4, 6, 7, 8 : le triangle etait coupe en 4
 247 c=======================================================================
 248 c
 249         elseif ( etan.eq.4 .or.
 250      >           ( etan.ge.6 .and. etan.le.8 ) ) then
 251 c
 252 #ifdef _DEBUG_HOMARD_
 253           write (ulsort,texte(langue,3)) 'PCSPTQ', nompro
 254 #endif
 255 c
 256           call pcsptq ( etanp1, trhn, trhnp1,
 257      >                  prfcan, prfcap,
 258      >                  filtri, nbantr, anfitr,
 259      >                  ntreca, ntrsca,
 260      >                  nbfonc, ngauss, vafoen, vafott,
 261      >                  ulsort, langue, codret )
 262 c
 263         endif
 264 c
 265    30 continue
 266 c
 267       endif
 268 c
 269       endif
 270 c
 271 c====
 272 c 4. la fin
 273 c====
 274 c
 275       if ( codret.ne.0 ) then
 276 c
 277 #include "envex2.h"
 278 c
 279       write (ulsort,texte(langue,1)) 'Sortie', nompro
 280       write (ulsort,texte(langue,2)) codret
 281 c
 282       endif
 283 c
 284 #ifdef _DEBUG_HOMARD_
 285       write (ulsort,texte(langue,1)) 'Sortie', nompro
 286       call dmflsh (iaux)
 287 #endif
 288 c
 289       end