src/tool/AP_Conversion/pcs0pe.F

   1       subroutine pcs0pe ( lepent, profho,
   2      >                    hetpen, facpen, cofape, filpen, fppyte,
   3      >                    somare, np2are,
   4      >                    aretri, arequa,
   5      >                    tritet, cotrte,
   6      >                    facpyr, cofapy,
   7      >                    afaire, listar, listno, typdec, etanp1,
   8      >                    noeumi )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    aPres adaptation - Conversion de Solution -
  30 c     -                 -             -
  31 c    interpolation p2 sur les noeuds - phase 0
  32 c                                            -
  33 c    decoupage des PEntaedres
  34 c                  --
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . lepent . e   .    1   . pentaedre a examiner                       .
  40 c . profho . e   .   *    . pour chaque entite en numerotation homard :.
  41 c .        .     .        . 0 : l'entite est absente du profil         .
  42 c .        .     .        . 1 : l'entite est presente dans le profil   .
  43 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  44 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  45 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  46 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  47 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  48 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  49 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  50 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  51 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  52 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  53 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  54 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  55 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  56 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  57 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  58 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  59 c . afaire .  s  .    1   . vrai si l'interpolation est a faire        .
  60 c . listar .  s  .    9   . liste des aretes du pentaedre              .
  61 c . listno .  s  .   15   . liste des noeuds du pentaedre              .
  62 c . typdec .  s  .    1   . type de decoupage                          .
  63 c . etanp1 .  s  . 1      . etat du pentaedre a l'iteration N+1        .
  64 c . noeumi .  s  . 1      . numero du noeud milieu                     .
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 0. declarations et dimensionnement
  69 c====
  70 c
  71 c 0.1. ==> generalites
  72 c
  73       implicit none
  74       save
  75 c
  76 c 0.2. ==> communs
  77 c
  78 #include "nombno.h"
  79 #include "nombar.h"
  80 #include "nombtr.h"
  81 #include "nombqu.h"
  82 #include "nombte.h"
  83 #include "nombpy.h"
  84 #include "nombpe.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       integer lepent
  89       integer profho(nbnoto)
  90       integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
  91       integer filpen(nbpeto), fppyte(2,nbpeco)
  92       integer somare(2,nbarto), np2are(nbarto)
  93       integer aretri(nbtrto,3)
  94       integer arequa(nbquto,4)
  95       integer tritet(nbtecf,4), cotrte(nbtecf,4)
  96       integer facpyr(nbpycf,5), cofapy(nbpycf,5)
  97       integer listar(9), listno(15)
  98       integer typdec, etanp1
  99       integer noeumi
 100 c
 101       logical afaire
 102 c
 103 c 0.4. ==> variables locales
 104 c
 105       integer iaux
 106 c
 107 c     etan   = ETAt du pentaedre a l'iteration N
 108 c
 109       integer etan
 110 c ______________________________________________________________________
 111 c
 112 #include "impr03.h"
 113 c
 114 c====
 115 c 1. les seuls cas interessants sont ceux ou un noeud est cree a
 116 c    l'interieur du pentaedre, donc quand il y a une arete interne
 117 c====
 118 c
 119       etanp1 = mod(hetpen(lepent),100)
 120       etan   = (hetpen(lepent)-etanp1) / 100
 121 cgn      write(1,90001) 'etats du penta', lepent,etan,etanp1
 122 cgn      write(1,90002) 'faces', (facpen(lepent,iaux),iaux=1,5)
 123 cgn      write(1,90002) 'codes', (cofape(lepent,iaux),iaux=1,5)
 124 c
 125 c     type de decoupage
 126 c
 127       typdec = 1
 128 c    . l'eventuel noeud central
 129 c       decoupage selon 2 aretes tria/tria
 130 c       decoupage selon 1 face triangulaire
 131       if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
 132      >     ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
 133         typdec = typdec*2
 134       endif
 135 c
 136 c    . d'un milieu de faces a un autre (en 8)
 137       if ( ( etanp1.eq.80 ) .and. ( etanp1.ne.etan ) ) then
 138         typdec = typdec*3
 139       endif
 140 c
 141 c    . du centre aux milieux d'aretes
 142 c       decoupage selon 2 aretes tria/tria
 143 c       decoupage selon 1 face triangulaire
 144       if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
 145      >     ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
 146         typdec = typdec*5
 147       endif
 148 c
 149 c    . du centre aux sommets
 150 c       decoupage selon 2 aretes tria/tria
 151 c       decoupage selon 1 face triangulaire
 152       if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or.
 153      >     ( etanp1.ge.51 .and. etanp1.le.52 ) ) then
 154         typdec = typdec*7
 155       endif
 156 c
 157 c    . d'un milieu d'arete a un autre (aretes tria+quad)
 158       if ( etanp1.ge.21 .and. etanp1.le.26 ) then
 159         typdec = typdec*11
 160       endif
 161 c
 162 c    . d'un milieu d'arete a un sommet (selon 1 arete tria)
 163       if ( etanp1.ge. 1 .and. etanp1.le. 6 ) then
 164         typdec = typdec*13
 165       endif
 166 c
 167 c    . d'un milieu de face a un sommet (selon 1 face quad)
 168       if ( etanp1.ge.43 .and. etanp1.le.45 ) then
 169         typdec = typdec*17
 170       endif
 171 c
 172 cgn      write(1,90002) 'typdec',typdec
 173 c
 174 c====
 175 c 2. Caracteristiques du pentaedre
 176 c====
 177 c
 178       if ( typdec.gt.1 ) then
 179 c
 180 c 2.1. ==> reperage des 9 aretes du pentaedre
 181 c
 182         call utarpe ( lepent,
 183      >                nbquto, nbpeto,
 184      >                arequa, facpen, cofape,
 185      >                listar )
 186 cgn        write(1,90002) 'listar', listar
 187 c
 188 c 2.2. ==> recuperation des 6 noeuds sommets
 189 c
 190         call utsope ( somare, listar, listno )
 191 cgn        write(1,90002) 'listno sommets', (listno(iaux),iaux=1,6))
 192 c
 193 c 2.3. ==> recuperation des 9 noeuds milieux
 194 c
 195         do 23 , iaux = 1 , 9
 196           listno(6+iaux) = np2are(listar(iaux))
 197    23   continue
 198 cgn        write(1,90002) 'listno milieux', (listno(iaux),iaux=7,15))
 199 c
 200       endif
 201 c
 202 c====
 203 c 3. on verifie que le champ est present sur tous les noeuds
 204 c    du pentaedre
 205 c====
 206 c
 207       if ( typdec.gt.1 ) then
 208 c
 209         afaire = .true.
 210         do 31  , iaux = 1 , 15
 211           if ( profho(listno(iaux)).eq.0 ) then
 212             afaire = .false.
 213             goto 32
 214           endif
 215    31   continue
 216 c
 217    32   continue
 218 c
 219       else
 220 c
 221         afaire = .false.
 222 c
 223       endif
 224 cgn      write(1,*) 'afaire', afaire
 225 c
 226 c====
 227 c 4. S'il faudra interpoler avec l'eventuel noeud central :
 228 c====
 229 c
 230       if ( afaire ) then
 231 c
 232         if ( mod(typdec,2).eq.0 .or.
 233      >       mod(typdec,5).eq.0 .or.
 234      >       mod(typdec,7).eq.0 ) then
 235 c
 236           iaux = lepent
 237           call utnmpe ( iaux, noeumi,
 238      >                  somare, aretri, arequa,
 239      >                  tritet, cotrte,
 240      >                  facpen, cofape, filpen, fppyte,
 241      >                  facpyr, cofapy )
 242 c
 243         endif
 244 c
 245       endif
 246 c
 247       end