src/tool/AP_Conversion/pcsepy.F

   1       subroutine pcsepy ( nfpent, nfpyra, nftetr, ficalc,
   2      >                    lepent, etat,
   3      >                    filpen, fppyte,
   4      >                    npecca, ntecca, npycca,
   5      >                    ulsort, langue, codret )
   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 Elements de volume -
  27 c     -                 -             -        -
  28 c                       Pentaedres - reperages des fils
  29 c                       -
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . nfpent .   s .    1   . nombre de fils pentaedres                  .
  35 c . nfpyra .   s .    1   . nombre de fils pyramides                   .
  36 c . nftetr .   s .    1   . nombre de fils tetraedres                  .
  37 c . ficalc .   s .  3,11  . numeros des fils en numerotation du calcul .
  38 c .        .     .        . 1 : pentaedres                             .
  39 c .        .     .        . 2 : pyramides                              .
  40 c .        .     .        . 3 : tetraedres                             .
  41 c . lepent . e   .    1   . hexaedre courant                           .
  42 c . etat   . e   .    1   . etat du pentaedre                          .
  43 c . filpen . e   .   *    . premier fils des pentaedres                .
  44 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  45 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  46 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  47 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  48 c . npecca . e   .   *    . numero des pentaedres dans le calcul e/s   .
  49 c . ntecca . e   .   *    . numero des tetraedres dans le calcul e/s   .
  50 c . npycca . e   .   *    . pyramides en sortie dans le calcul e/s     .
  51 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  52 c . langue . e   .    1   . langue des messages                        .
  53 c .        .     .        . 1 : francais, 2 : anglais                  .
  54 c . codret . es  .    1   . code de retour des modules                 .
  55 c .        .     .        . 0 : pas de probleme                        .
  56 c .        .     .        . 1 : probleme                               .
  57 c ______________________________________________________________________
  58 c
  59 c====
  60 c 0. declarations et dimensionnement
  61 c====
  62 c
  63 c 0.1. ==> generalites
  64 c
  65       implicit none
  66       save
  67 c
  68       character*6 nompro
  69       parameter ( nompro = 'PCSEPY' )
  70 c
  71 #include "nblang.h"
  72 c
  73 c 0.2. ==> communs
  74 c
  75 c 0.3. ==> arguments
  76 c
  77       integer nfpent, nfpyra, nftetr
  78       integer ficalc(3,11)
  79       integer lepent, etat
  80 c
  81       integer filpen(*), fppyte(2,*)
  82       integer npecca(*)
  83       integer ntecca(*)
  84       integer npycca(*)
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer iaux, jaux
  91 c
  92       integer nbmess
  93       parameter ( nbmess = 10 )
  94       character*80 texte(nblang,nbmess)
  95 c
  96 c 0.5. ==> initialisations
  97 c ______________________________________________________________________
  98 c
  99 c====
 100 c 1. initialisations
 101 c====
 102 c
 103 #include "impr01.h"
 104 #include "impr03.h"
 105 c
 106 #ifdef _DEBUG_HOMARD_
 107       write (ulsort,texte(langue,1)) 'Entree', nompro
 108       call dmflsh (iaux)
 109 #endif
 110 c
 111 #include "pcimp2.h"
 112 c
 113       codret = 0
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,4)) lepent, etat
 117 #endif
 118 c
 119 c====
 120 c 2. denombrement des fils pour les differents cas de figure
 121 c====
 122 c 2.0. ==> a priori, aucun
 123 c
 124       nfpent = 0
 125       nfpyra = 0
 126       nftetr = 0
 127 c
 128 c 2.1. ==> etat = 1, ..., 6 :
 129 c          decoupage en 1 tetraedre et 2 pyramides
 130 c
 131       if ( etat.ge.1 .and. etat.le.6 ) then
 132 c
 133         nfpyra = 2
 134         nftetr = 1
 135 c
 136 c 2.2. ==> etat = 17, ..., 19 :
 137 c          decoupage en 2 tetraedres et 1 pyramide.
 138 c
 139       elseif ( etat.ge.17 .and. etat.le.19 ) then
 140 c
 141         nfpyra = 1
 142         nftetr = 2
 143 c
 144 c 2.3. ==> etat = 21, ..., 26 :
 145 c          decoupage en 6 tetraedres
 146 c
 147       elseif ( etat.ge.21 .and. etat.le.26 ) then
 148 c
 149         nftetr = 6
 150 c
 151 c 2.4. ==> etat = 31, ..., 36 :
 152 c          decoupage en 10 tetraedres et 1 pyramide.
 153 c
 154       elseif ( etat.ge.31 .and. etat.le.36 ) then
 155 c
 156         nfpyra = 1
 157         nftetr = 10
 158 c
 159 c 2.5. ==> etat = 43, ..., 45 :
 160 c          decoupage en 2 tetraedres et 4 pyramides
 161 c
 162       elseif ( etat.ge.43 .and. etat.le.45 ) then
 163 c
 164         nfpyra = 4
 165         nftetr = 2
 166 c
 167 c 2.6. ==> etat = 51, 52 :
 168 c          decoupage en 11 tetraedres
 169 c
 170       elseif ( etat.ge.51 .and. etat.le.52 ) then
 171 c
 172         nftetr = 11
 173 c
 174 c 2.7. ==> etat = 80 :
 175 c          decoupage en 8 pentaedres.
 176 c
 177       elseif ( etat.eq.80 .or. etat.eq.99 ) then
 178 c
 179         nfpent = 8
 180 c
 181       endif
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,90002) 'nfpent', nfpent
 185       write (ulsort,90002) 'nfpyra', nfpyra
 186       write (ulsort,90002) 'nftetr', nftetr
 187 #endif
 188 c
 189 c====
 190 c 3. Calcul
 191 c====
 192 c 3.1. ==> Reperage des pentaedres fils du pentaedre
 193 c
 194       if ( nfpent.gt.0 ) then
 195 c
 196         jaux = filpen(lepent) - 1
 197         do 31 , iaux = 1 , nfpent
 198           ficalc(1,iaux) = npecca(jaux+iaux)
 199    31   continue
 200 cgn        write(ulsort,90002) 'nfpent', nfpent
 201 cgn        write(ulsort,91020) (ficalc(1,iaux) , iaux = 1 , nfpent)
 202 c
 203       endif
 204 c
 205 c 3.2. ==> Reperage des pyramides filles du pentaedre
 206 c
 207       if ( nfpyra.gt.0 ) then
 208 c
 209         jaux = fppyte(1,-filpen(lepent)) - 1
 210         do 32 , iaux = 1 , nfpyra
 211           ficalc(2,iaux) = npycca(jaux+iaux)
 212    32   continue
 213 cgn        write(ulsort,90002) 'nfpyra', nfpyra
 214 cgn        write(ulsort,91020) (ficalc(2,iaux) , iaux = 1 , nfpyra)
 215 c
 216       endif
 217 c
 218 c 3.3. ==> Reperage des tetraedres fils du pentaedre
 219 c
 220       if ( nftetr.gt.0 ) then
 221 c
 222         jaux = fppyte(2,-filpen(lepent)) - 1
 223         do 33 , iaux = 1 , nftetr
 224           ficalc(3,iaux) = ntecca(jaux+iaux)
 225    33   continue
 226 cgn        write(ulsort,90002) 'nftetr', nftetr
 227 cgn        write(ulsort,91020) (ficalc(3,iaux) , iaux = 1 , nftetr)
 228 c
 229       endif
 230 c
 231 c====
 232 c 4. la fin
 233 c====
 234 c
 235       if ( codret.ne.0 ) then
 236 c
 237       write (ulsort,texte(langue,1)) 'Sortie', nompro
 238       write (ulsort,texte(langue,2)) codret
 239 c
 240       endif
 241 c
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,texte(langue,1)) 'Sortie', nompro
 244       call dmflsh (iaux)
 245 #endif
 246 c
 247       end