src/tool/AP_Conversion/pcsepz.F

   1       subroutine pcsepz ( propor,
   2      >                    lepent, etat,
   3      >                    coonoe, somare, aretri, arequa,
   4      >                    tritet, cotrte, aretet,
   5      >                    facpen, cofape, arepen,
   6      >                    facpyr, cofapy, arepyr,
   7      >                    filpen, fppyte,
   8      >                    ulsort, langue, codret )
   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 Elements de volume -
  30 c     -                 -             -        -
  31 c                       Pentaedres - calcul des proportions fils/pere
  32 c                       -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . propor .   s .   11   . proportion de volume entre fils et pere    .
  38 c . lepent . e   .    1   . hexaedre courant                           .
  39 c . etat   . e   .    1   . etat du pentaedre                          .
  40 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  41 c .        .     . * sdim .                                            .
  42 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  43 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  46 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  47 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  48 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  49 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  50 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  51 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  52 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  53 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  54 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  55 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  56 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  57 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  58 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  59 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  60 c . langue . e   .    1   . langue des messages                        .
  61 c .        .     .        . 1 : francais, 2 : anglais                  .
  62 c . codret . es  .    1   . code de retour des modules                 .
  63 c .        .     .        . 0 : pas de probleme                        .
  64 c .        .     .        . 1 : probleme                               .
  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       character*6 nompro
  77       parameter ( nompro = 'PCSEPZ' )
  78 c
  79 #include "nblang.h"
  80 c
  81 c 0.2. ==> communs
  82 c
  83 #include "envca1.h"
  84 #include "nombno.h"
  85 #include "nombar.h"
  86 #include "nombtr.h"
  87 #include "nombqu.h"
  88 #include "nombte.h"
  89 #include "nombpe.h"
  90 #include "nombpy.h"
  91 c
  92 c 0.3. ==> arguments
  93 c
  94       integer lepent, etat
  95 c
  96       integer somare(2,nbarto)
  97       integer aretri(nbtrto,3)
  98       integer arequa(nbquto,4)
  99       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 100       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 101       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 102 c
 103       integer filpen(nbpeto), fppyte(2,nbpeco)
 104 c
 105       double precision propor(11)
 106       double precision coonoe(nbnoto,sdim)
 107 c
 108       integer ulsort, langue, codret
 109 c
 110 c 0.4. ==> variables locales
 111 c
 112       integer iaux
 113       integer fipent, fipyra, fitetr
 114       integer nfpent, nfpyra, nftetr, nbfils
 115 c
 116       double precision daux
 117       double precision daux0
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 10 )
 121       character*80 texte(nblang,nbmess)
 122 c
 123 c 0.5. ==> initialisations
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. initialisations
 128 c====
 129 c
 130 #include "impr01.h"
 131 #include "impr03.h"
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134       write (ulsort,texte(langue,1)) 'Entree', nompro
 135       call dmflsh (iaux)
 136 #endif
 137 c
 138 #include "pcimp2.h"
 139 c
 140       codret = 0
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143       write (ulsort,texte(langue,4)) lepent, etat
 144 #endif
 145 c
 146 c====
 147 c 2. denombrement des fils pour les differents cas de figure
 148 c====
 149 c 2.0. ==> a priori, aucun
 150 c
 151       nfpent = 0
 152       nfpyra = 0
 153       nftetr = 0
 154 c
 155 c 2.1. ==> etat = 1, ..., 6 :
 156 c          decoupage en 1 tetraedre et 2 pyramides
 157 c
 158       if ( etat.ge.1 .and. etat.le.6 ) then
 159 c
 160         nfpyra = 2
 161         nftetr = 1
 162 c
 163 c 2.2. ==> etat = 17, ..., 19 :
 164 c          decoupage en 2 tetraedres et 1 pyramide.
 165 c
 166       elseif ( etat.ge.17 .and. etat.le.19 ) then
 167 c
 168         nfpyra = 1
 169         nftetr = 2
 170 c
 171 c 2.3. ==> etat = 21, ..., 26 :
 172 c          decoupage en 6 tetraedres
 173 c
 174       elseif ( etat.ge.21 .and. etat.le.26 ) then
 175 c
 176         nftetr = 6
 177 c
 178 c 2.4. ==> etat = 31, ..., 36 :
 179 c          decoupage en 10 tetraedres et 1 pyramide.
 180 c
 181       elseif ( etat.ge.31 .and. etat.le.36 ) then
 182 c
 183         nfpyra = 1
 184         nftetr = 10
 185 c
 186 c 2.5. ==> etat = 43, ..., 45 :
 187 c          decoupage en 2 tetraedres et 4 pyramides
 188 c
 189       elseif ( etat.ge.43 .and. etat.le.45 ) then
 190 c
 191         nfpyra = 4
 192         nftetr = 2
 193 c
 194 c 2.6. ==> etat = 51, 52 :
 195 c          decoupage en 11 tetraedres
 196 c
 197       elseif ( etat.ge.51 .and. etat.le.52 ) then
 198 c
 199         nftetr = 11
 200 c
 201 c 2.7. ==> etat = 80 :
 202 c          decoupage en 8 pentaedres.
 203 c
 204       elseif ( etat.eq.80 .or. etat.eq.99 ) then
 205 c
 206         nfpent = 8
 207 c
 208       endif
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,90002) 'nfpent', nfpent
 212       write (ulsort,90002) 'nfpyra', nfpyra
 213       write (ulsort,90002) 'nftetr', nftetr
 214 #endif
 215 c
 216 c====
 217 c 3. Calcul
 218 c====
 219 c 3.1. ==> Calcul des volumes
 220 c          Remarque : certains des volumes des fils sont identiques
 221 c          par paires, par construction. On les calcule quand meme
 222 c          pour la lisibilite du programme.
 223 c
 224       nbfils = nfpent + nfpyra + nftetr
 225 c
 226 c 3.1.1. ==> Pentaedres
 227 c
 228       if ( nfpent.gt.0 ) then
 229 c
 230         fipent = filpen(lepent) - 1
 231         do 321 , iaux = 1, nfpent
 232           call utvpen ( fipent+iaux, propor(iaux),
 233      >                  coonoe, somare, arequa,
 234      >                  facpen, cofape, arepen )
 235   321   continue
 236 c
 237       endif
 238 c
 239 c 3.1.2. ==> Pyramides
 240 c
 241       if ( nfpyra.gt.0 ) then
 242 c
 243         fipyra = fppyte(1,-filpen(lepent)) - 1
 244         do 322 , iaux = 1 , nfpyra
 245           call utvpyr ( fipyra+iaux, propor(iaux),
 246      >                  coonoe, somare, aretri,
 247      >                  facpyr, cofapy, arepyr )
 248   322  continue
 249 c
 250       endif
 251 c
 252 c 3.1.3. ==> Tetraedres
 253 c
 254       if ( nftetr.gt.0 ) then
 255 c
 256         fitetr = fppyte(2,-filpen(lepent)) - 1
 257         do 323 , iaux = 1 , nftetr
 258           call utvtet ( fitetr+iaux, propor(iaux+nfpyra),
 259      >                  coonoe, somare, aretri,
 260      >                  tritet, cotrte, aretet )
 261   323  continue
 262 c
 263       endif
 264 c
 265 c 3.2. ==> Le volume total ; c'est donc le volume du pere
 266 c
 267       daux0 = 0.d0
 268       do 32 , iaux = 1, nbfils
 269         daux0 = daux0 + propor(iaux)
 270    32 continue
 271 c
 272 c 3.3. ==> Rapport
 273 c
 274       do 33 , iaux = 1, nbfils
 275         propor(iaux) = propor(iaux) / daux0
 276    33 continue
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279       if ( nfpent.gt.0 ) then
 280         write (ulsort,90015) 'propor pour les', nfpent, ' pentaedres'
 281         do 3391 , iaux = 1, nfpent
 282           write (ulsort,90014) iaux, propor(iaux)
 283  3391   continue
 284       endif
 285       if ( nfpyra.eq.1 ) then
 286         write (ulsort,90015) 'propor pour la pyramide'
 287         write (ulsort,90014) 1, propor(1)
 288       elseif ( nfpyra.gt.0 ) then
 289         write (ulsort,90015) 'propor pour les', nfpyra, ' pyramides'
 290         do 3392 , iaux = 1, nfpyra
 291           write (ulsort,90014) iaux, propor(iaux)
 292  3392   continue
 293       endif
 294       if ( nftetr.eq.1 ) then
 295         write (ulsort,90015) 'propor pour le tetradre'
 296         write (ulsort,90014) 1, propor(1+nfpyra)
 297       elseif ( nftetr.gt.0 ) then
 298         write (ulsort,90015) 'propor pour les', nftetr, ' tetradres'
 299         do 3393 , iaux = 1, nftetr
 300           write (ulsort,90014) iaux, propor(iaux+nfpyra)
 301  3393   continue
 302       endif
 303 #endif
 304 c
 305 c====
 306 c 4. la fin
 307 c====
 308 c
 309       if ( codret.ne.0 ) then
 310 c
 311       write (ulsort,texte(langue,1)) 'Sortie', nompro
 312       write (ulsort,texte(langue,2)) codret
 313 c
 314       endif
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,texte(langue,1)) 'Sortie', nompro
 318       call dmflsh (iaux)
 319 #endif
 320 c
 321       end