src/tool/AP_Conversion/pcsitr.F

   1       subroutine pcsitr ( nbfop2, profho, vap2ho,
   2      >                    hettri, aretri, filtri,
   3      >                    somare, np2are )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    aPres adaptation - Conversion de Solution -
  25 c     -                 -             -
  26 c    interpolation iso-p2 sur les noeuds - decoupage des TRiangles
  27 c                  -                                     --
  28 c remarque : on devrait optimiser cela car si le triangle etait dans
  29 c            un etat de decoupage similaire, on recalcule une valeur
  30 c            qui est deja presente
  31 c remarque : pcs2tr et pcsitr sont des clones
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  37 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  38 c .        .     .        . 0 : l'entite est absente du profil         .
  39 c .        .     .        . 1 : l'entite est presente dans le profil   .
  40 c . vap2ho . es  . nbfop2*. variables iso-p2 numerotation homard       .
  41 c .        .     . nbnoto .                                            .
  42 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  43 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  44 c . filtri . e   . nbtrto . premier fils des triangles                 .
  45 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  46 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  47 c ______________________________________________________________________
  48 c
  49 c====
  50 c 0. declarations et dimensionnement
  51 c====
  52 c
  53 c 0.1. ==> generalites
  54 c
  55       implicit none
  56       save
  57 c
  58 #include "fracta.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "demitr.h"
  63 #include "nombno.h"
  64 #include "nombar.h"
  65 #include "nombtr.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer nbfop2
  70       integer profho(nbnoto)
  71       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
  72       integer somare(2,nbarto), np2are(nbarto)
  73 c
  74       double precision vap2ho(nbfop2,*)
  75 c
  76 c 0.4. ==> variables locales
  77 c
  78       integer typdec
  79       integer iaux1, iaux2, iaux3
  80       integer letria, letri0
  81       integer ff, nuv, af1, af2, af3
  82       integer m1, m2, m3
  83       integer inloc
  84       integer listno(6)
  85 c
  86 c     f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1
  87 c
  88       integer f1hp
  89 c
  90       logical afaire
  91 c
  92 c 0.5. ==> initialisations
  93 c ______________________________________________________________________
  94 cgn       write (*,*) 'PCSITR'
  95 c
  96       do 10 , letri0 = 1, nbtrto
  97 c
  98         letria = letri0
  99 c
 100 cgn      write (1,90002) 'Triangle', letria
 101 c====
 102 c 1. liste des noeuds concernes et type de decoupage
 103 c====
 104 c
 105         call pcs0tr ( letria, profho,
 106      >                hettri, aretri,
 107      >                somare, np2are,
 108      >                afaire, listno, typdec )
 109 cgn      write (1,90002) 'typdec', typdec
 110 c
 111         if ( afaire ) then
 112 c
 113 c====
 114 c 2. le triangle vient d'etre decoupe en 4 triangles alors
 115 c    qu'il ne l'etait pas a l'iteration precedente
 116 c          . en standard : etat 4
 117 c          . avec bascule pour le suivi de frontiere : etat 6, 7 ou 8
 118 c    Remarque : regarder cmrdtr pour les conventions
 119 c====
 120 c
 121         if ( typdec.ge.4 ) then
 122 c
 123 c           recuperation du triangle fils aine
 124 c           c'est le central si pas de basculement
 125 c
 126           f1hp = filtri(letria)
 127 c
 128 c           recuperation des aretes internes au triangle decoupe
 129 c           . pour un decoupage standard, ce sont les trois du triangle
 130 c           central
 131 c           . avec une bascule, il y a eu modification du fils aine
 132 c           et du frere de rang connu par l'etat du triangle, inloc.
 133 c           l'arete basculee est celle commune a ces deux triangles. les
 134 c           deux autres aretes sont celles de rang inloc dans la
 135 c           description des deux triangles modifies.
 136 c
 137           if ( typdec.eq.4 ) then
 138             af1 = aretri(f1hp,1)
 139             af2 = aretri(f1hp,2)
 140             af3 = aretri(f1hp,3)
 141 c
 142           else
 143             inloc = typdec - 5
 144             af3 = 0
 145             do 21 , iaux1 = 1 , 3
 146               iaux3 = aretri(f1hp+inloc,iaux1)
 147               do 211 , iaux2 = 1 , 3
 148                 if ( iaux3.eq.aretri(f1hp,iaux2) ) then
 149                   af3 = iaux3
 150                 endif
 151   211         continue
 152    21       continue
 153             af1 = aretri(f1hp      ,inloc)
 154             af2 = aretri(f1hp+inloc,inloc)
 155           endif
 156 c
 157 c           recuperation des noeuds milieux sur ces aretes internes
 158 c
 159           m1 = np2are(af1)
 160           m2 = np2are(af2)
 161           m3 = np2are(af3)
 162           profho(m1) = 1
 163           profho(m2) = 1
 164           profho(m3) = 1
 165 c
 166 c         interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 167 c
 168           do 22 , nuv = 1, nbfop2
 169 c
 170             vap2ho(nuv,m1) =
 171      >      unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) )
 172             vap2ho(nuv,m2) =
 173      >      unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) )
 174             vap2ho(nuv,m3) =
 175      >      unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) )
 176 c
 177    22     continue
 178 c
 179 c====
 180 c 3. le triangle vient d'etre decoupe en 2
 181 c====
 182 c
 183         elseif ( typdec.eq.1 .or. typdec.eq.2 .or. typdec.eq.3 ) then
 184 c
 185 c 3.1. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 1
 186 c
 187           if ( typdec.eq.1 ) then
 188 c
 189 c         recuperation d'un triangle fils
 190 c
 191             ff = filtri(letria) + nutrde(1,2)
 192 c
 193 c         recuperation du nouveau noeud milieu
 194 c
 195             m1 = np2are(aretri(ff,3))
 196             profho(m1) = 1
 197 c
 198 c         interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 199 c
 200             do 31 , nuv = 1, nbfop2
 201 c
 202               vap2ho(nuv,m1) =
 203      >        unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) )
 204 c
 205    31       continue
 206 c
 207 c 3.2. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 2
 208 c
 209           elseif ( typdec.eq.2 ) then
 210 c
 211 c           recuperation d'un triangle fils
 212 c
 213             ff = filtri(letria) + nutrde(2,1)
 214 c
 215 c           recuperation du nouveau noeud milieu
 216 c
 217             m2 = np2are(aretri(ff,3))
 218             profho(m2) = 1
 219 c
 220 c           interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 221 c
 222             do 32 , nuv = 1, nbfop2
 223 c
 224               vap2ho(nuv,m2) =
 225      >        unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) )
 226 c
 227    32       continue
 228 c
 229 c 3.3. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 3
 230 c
 231           elseif ( typdec.eq.3 ) then
 232 c
 233 c           recuperation d'un triangle fils
 234 c
 235             ff = filtri(letria) + nutrde(3,1)
 236 c
 237 c           recuperation du nouveau noeud milieu
 238 c
 239             m3 = np2are(aretri(ff,2))
 240             profho(m3) = 1
 241 c
 242 c           interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 243 c
 244             do 33 , nuv = 1, nbfop2
 245 c
 246               vap2ho(nuv,m3) =
 247      >        unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) )
 248 c
 249    33       continue
 250 c
 251           endif
 252 c
 253         endif
 254 c
 255         endif
 256 c
 257    10 continue
 258 c
 259       end