src/tool/AP_Conversion/pcsipe.F

   1       subroutine pcsipe ( nbfop2, profho, vap2ho,
   2      >                    hetpen, facpen, cofape, filpen, fppyte,
   3      >                    somare, np2are,
   4      >                    aretri, arequa,
   5      >                    tritet, cotrte,
   6      >                    facpyr, cofapy,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    aPres adaptation - Conversion de Solution -
  29 c     -                 -             -
  30 c    interpolation iso/p2 sur les noeuds - decoupage des PEntaedres
  31 c                  -                                     --
  32 c remarque : on devrait optimiser cela car si le pentaedre etait dans
  33 c            un etat de decoupage similaire, on recalcule une valeur
  34 c            qui est deja presente
  35 c remarque : pcsipe et pcsipe sont des clones
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  41 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  42 c .        .     .        . 0 : l'entite est absente du profil         .
  43 c .        .     .        . 1 : l'entite est presente dans le profil   .
  44 c . vap2ho . es  . nbfop2*. variables p1 numerotation homard           .
  45 c .        .     . nbnoto .                                            .
  46 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  47 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  48 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  49 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  50 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  51 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  52 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  53 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  54 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  55 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  56 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  57 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  58 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  59 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  60 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  61 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  62 c . langue . e   .    1   . langue des messages                        .
  63 c .        .     .        . 1 : francais, 2 : anglais                  .
  64 c . codret . es  .    1   . code de retour des modules                 .
  65 c .        .     .        . 0 : pas de probleme                        .
  66 c .        .     .        . 1 : probleme                               .
  67 c ______________________________________________________________________
  68 c
  69 c====
  70 c 0. declarations et dimensionnement
  71 c====
  72 c
  73 c 0.1. ==> generalites
  74 c
  75       implicit none
  76       save
  77 c
  78       character*6 nompro
  79       parameter ( nompro = 'PCSIPE' )
  80 c
  81 #include "nblang.h"
  82 #include "fracte.h"
  83 c
  84 c 0.2. ==> communs
  85 c
  86 #include "envex1.h"
  87 #include "nombar.h"
  88 #include "nombtr.h"
  89 #include "nombqu.h"
  90 #include "nombte.h"
  91 #include "nombpy.h"
  92 #include "nombpe.h"
  93 c
  94 c 0.3. ==> arguments
  95 c
  96       integer nbfop2
  97       integer profho(*)
  98       integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
  99       integer filpen(nbpeto), fppyte(2,nbpeco)
 100       integer somare(2,nbarto), np2are(nbarto)
 101       integer aretri(nbtrto,3)
 102       integer arequa(nbquto,4)
 103       integer tritet(nbtecf,4), cotrte(nbtecf,4)
 104       integer facpyr(nbpycf,5), cofapy(nbpycf,5)
 105 c
 106       double precision vap2ho(nbfop2,*)
 107 c
 108       integer ulsort, langue, codret
 109 c
 110 c 0.4. ==> variables locales
 111 c
 112       integer iaux, jaux
 113       integer lepent
 114       integer typdec, etanp1
 115       integer sm, nuv
 116       integer listar(9), listno(15)
 117       integer nbarco
 118       integer nuaret(15)
 119 c
 120       logical afaire
 121 c
 122       double precision daux
 123 c
 124       integer nbmess
 125       parameter ( nbmess = 10 )
 126       character*80 texte(nblang,nbmess)
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 1. initialisations
 131 c====
 132 c
 133 c 1.1. ==> messages
 134 c
 135 #include "impr01.h"
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138       write (ulsort,texte(langue,1)) 'Entree', nompro
 139       call dmflsh (iaux)
 140 #endif
 141 c
 142 #include "impr03.h"
 143 c
 144       codret = 0
 145 c
 146       do 100 , jaux = 1, nbpeto
 147 c
 148         lepent = jaux
 149 c
 150 c====
 151 c 2. recherche des types d'interpolations a faire
 152 c====
 153 c
 154         if ( codret.eq.0 ) then
 155 c
 156 #ifdef _DEBUG_HOMARD_
 157         write(ulsort,texte(langue,3)) 'PCS0PE', nompro
 158 #endif
 159         call pcs0pe ( lepent, profho,
 160      >                hetpen, facpen, cofape, filpen, fppyte,
 161      >                somare, np2are,
 162      >                aretri, arequa,
 163      >                tritet, cotrte,
 164      >                facpyr, cofapy,
 165      >                afaire, listar, listno, typdec, etanp1, sm )
 166 cgn      write(ulsort,90002) 'typdec',typdec
 167 c
 168         endif
 169 c
 170         if ( afaire ) then
 171 c
 172 c====
 173 c 3. L'eventuel noeud central
 174 c       decoupage selon 2 aretes tria/tria
 175 c       decoupage selon 1 face traingulaire
 176 c====
 177 c
 178         if ( codret.eq.0 ) then
 179 c
 180         if ( mod(typdec,2).eq.0 ) then
 181 c
 182           profho(sm) = 1
 183 c
 184 c         formule iso-p2 :
 185 c         interpolation = moyenne des valeurs sur les noeuds au milieu
 186 c                         des aretes du pentaedre
 187 c
 188           do 31 , nuv = 1, nbfop2
 189 c
 190             daux = 0.d0
 191             do 311 , iaux = 9 , 15
 192               daux = daux + vap2ho(nuv,listno(iaux))
 193   311       continue
 194             vap2ho(nuv,sm) = unssix * daux
 195 cgn        write(ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 196 c
 197    31     continue
 198 c
 199         endif
 200 c
 201         endif
 202 c
 203 c====
 204 c 4. Recuperation des aretes internes
 205 c====
 206 c
 207         if ( codret.eq.0 ) then
 208 c
 209         iaux = 1
 210 c
 211 c 4.1. ==> Du centre aux milieux d'aretes
 212 c            (selon 2 aretes tri ou 1 face tri)
 213 c
 214         if ( mod(typdec,5).eq.0 ) then
 215           iaux = iaux*3
 216         endif
 217 c
 218 c 4.2. ==> Du centre aux sommets
 219 c           (selon 2 aretes tri ou 1 face tri)
 220 c
 221         if ( mod(typdec,7).eq.0 ) then
 222           iaux = iaux*2
 223         endif
 224 c
 225 c 4.3. ==> Entre les milieux de faces
 226 c            D'un milieu d'arete a un autre
 227 c            D'un milieu d'arete a un sommet
 228 c            D'un milieu de face a un sommet
 229 c
 230         if ( mod(typdec,3).eq.0 .or.
 231      >       mod(typdec,11).eq.0 .or.
 232      >       mod(typdec,13).eq.0 .or.
 233      >       mod(typdec,17).eq.0 ) then
 234           iaux = iaux*5
 235         endif
 236 c
 237 c 4.4. ==> Les aretes
 238 c
 239 #ifdef _DEBUG_HOMARD_
 240         write(ulsort,texte(langue,3)) 'UTAIPE', nompro
 241 #endif
 242         call utaipe ( lepent, iaux,
 243      >                hetpen, facpen, filpen, fppyte,
 244      >                aretri,
 245      >                tritet, cotrte,
 246      >                nbarco, nuaret,
 247      >                ulsort, langue, codret )
 248 c
 249         endif
 250 c
 251 c====
 252 c 5. Les valeurs
 253 c====
 254 c
 255         if ( codret.eq.0 ) then
 256 cgn      write(ulsort,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco)
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259         write(ulsort,texte(langue,3)) 'PCSI00', nompro
 260 #endif
 261         call pcsi00 ( nbfop2, profho, vap2ho,
 262      >                somare, np2are,
 263      >                nbarco, nuaret )
 264 c
 265         endif
 266 c
 267         endif
 268 c
 269   100 continue
 270 c
 271 c====
 272 c 6. 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