src/tool/AP_Conversion/pcs2te.F

   1       subroutine pcs2te ( nbfop2, profho, vap2ho,
   2      >                    tritet, cotrte, aretet,
   3      >                    hettet, filtet,
   4      >                    somare, np2are,
   5      >                    aretri )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    aPres adaptation - Conversion de Solution -
  27 c     -                 -             -
  28 c    interpolation p2 sur les noeuds - decoupage des TEtraedres
  29 c                   -                                --
  30 c ______________________________________________________________________
  31 c attention : il faut passer ce programme avant le traitement des
  32 c             nouveaux noeuds sur les triangles coupes, sinon les
  33 c             valeurs sur les noeuds des diagonales seront inconnues
  34 c remarque : on devrait optimiser cela car si le tetraedre etait dans
  35 c            un etat de decoupage de conformite similaire, on recalcule
  36 c            une valeur qui est deja presente
  37 c remarque : pcs2te et pcsite sont des clones
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  43 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  44 c .        .     .        . 0 : l'entite est absente du profil         .
  45 c .        .     .        . 1 : l'entite est presente dans le profil   .
  46 c . vap2ho . es  . nbfop2*. variables p2 numerotation homard           .
  47 c .        .     . nbnoto .                                            .
  48 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  49 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  50 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  51 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  52 c . filtet . e   . nbteto . premier fils des tetraedres                .
  53 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  54 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  55 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  56 c ______________________________________________________________________
  57 c
  58 c====
  59 c 0. declarations et dimensionnement
  60 c====
  61 c
  62 c 0.1. ==> generalites
  63 c
  64       implicit none
  65       save
  66 c
  67 #include "fractc.h"
  68 #include "fractf.h"
  69 c
  70 c 0.2. ==> communs
  71 c
  72 #include "nombno.h"
  73 #include "nombar.h"
  74 #include "nombtr.h"
  75 #include "nombte.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       integer nbfop2
  80       integer profho(nbnoto)
  81       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
  82       integer hettet(nbteto), filtet(nbteto)
  83       integer somare(2,nbarto), np2are(nbarto)
  84       integer aretri(nbtrto,3)
  85 c
  86       double precision vap2ho(nbfop2,*)
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer iaux
  91       integer letetr, adiag
  92       integer sm, nuv
  93       integer listar(6), listno(10)
  94 c
  95       logical afaire
  96 c ______________________________________________________________________
  97 c
  98 #include "impr03.h"
  99 cgn       write (1,90002) 'PCS2TE, nbfop2', nbfop2
 100 c
 101       do 10 , letetr = 1, nbteto
 102 c
 103 c====
 104 c 1. interpolation p2 pour un tetraedre qui vent d'etre decoupe
 105 c    les seuls cas interessants sont ceux ou un noeud est cree a
 106 c    l'interieur du tetraedre, donc quand il y a une diagonale.
 107 c====
 108 c
 109         iaux = letetr
 110         call pcs0te ( iaux, profho,
 111      >                tritet, cotrte, aretet,
 112      >                hettet, filtet,
 113      >                aretri,
 114      >                somare, np2are,
 115      >                afaire, listar, listno, adiag )
 116 c
 117 c====
 118 c 2. le tetraedre vient d'etre decoupe et le champ est present
 119 c    interpolation au noeud milieu de la diagonale
 120 c====
 121 c
 122         if ( afaire ) then
 123 c
 124           sm = np2are(adiag)
 125           profho(sm) = 1
 126 cgn        write(1,90002) 'dans pcs2te, f1hp =', f1hp
 127 cgn        write(1,90002) 'sm =', sm
 128 c
 129 c           interpolation p2 c
 130 c
 131 c           interpolee (ui,i=1,10) = -1/8 (ui,i=1,4) + 1/4 (ui,i=5,10)
 132 c
 133           do 22 , nuv = 1, nbfop2
 134 c
 135             vap2ho(nuv,sm) =
 136      >      unsqu * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6))
 137      >              + vap2ho(nuv,listno(7)) + vap2ho(nuv,listno(8))
 138      >              + vap2ho(nuv,listno(9)) + vap2ho(nuv,listno(10)) )
 139      >    - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(2))
 140      >              + vap2ho(nuv,listno(3)) + vap2ho(nuv,listno(4)) )
 141 cgn        write(1,90014) sm, vap2ho(nuv,sm)
 142 c
 143    22     continue
 144 c
 145         endif
 146 c
 147    10 continue
 148 c
 149       end