src/tool/AV_Conversion/vcme24.F

   1       subroutine vcme24 ( numfam,
   2      >                    nbfpe0,
   3      >                    cfaqua,
   4      >                    cfahex,
   5      >                    cfapen,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    aVant adaptation - Conversion de Maillage Extrude - phase 24
  28 c     -                 -             -        -               --
  29 c Determine les familles pour la relation hexaedres/pentaedres
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . numfam . es  .    1   . numero de la derniere famille traitee      .
  35 c . nbfpe0 . e   .  1     . nombre de familles pour le dimensionnement .
  36 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  37 c .        .     . nbfqua .   1 : famille MED                          .
  38 c .        .     .        .   2 : type de quadrangle                   .
  39 c .        .     .        .   3 : numero de surface de frontiere       .
  40 c .        .     .        .   4 : famille des aretes internes apres raf.
  41 c .        .     .        .   5 : famille des triangles de conformite  .
  42 c .        .     .        .   6 : famille de sf active/inactive        .
  43 c .        .     .        .   7 : famille du quadrangle extrude        .
  44 c .        .     .        .   8 : famille du volume perpendiculaire    .
  45 c .        .     .        .   9 : code du quadrangle dans hexa ou penta.
  46 c .        .     .        .  10 : position du quadrangle               .
  47 c .        .     .        . si equivalence :                           .
  48 c .        .     .        . + l : appartenance a l'equivalence l       .
  49 c . cfahex . es  . nctfhe*. codes des familles des hexaedres           .
  50 c .        .     . nbfhex .   1 : famille MED                          .
  51 c .        .     .        .   2 : type d'hexaedres                     .
  52 c .        .     .        .   3 : famille des tetraedres de conformite .
  53 c .        .     .        .   4 : famille des pyramides de conformite  .
  54 c .        .     .        . si extrusion :                             .
  55 c .        .     .        .   3 : famille des pentaedres de conformite .
  56 c . cfapen . es  . nctfpe*. codes des familles des pentaedres          .
  57 c .        .     . nbfpen .   1 : famille MED                          .
  58 c .        .     .        .   2 : type de pentaedres                   .
  59 c .        .     .        .   3 : famille des tetraedres de conformite .
  60 c .        .     .        .   4 : famille des pyramides de conformite  .
  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 . e   .    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 = 'VCME24' )
  80 c
  81 #include "nblang.h"
  82 #include "consts.h"
  83 #include "cofaar.h"
  84 #include "coftex.h"
  85 #include "cofexq.h"
  86 #include "cofexh.h"
  87 c
  88 c 0.2. ==> communs
  89 c
  90 #include "envex1.h"
  91 c
  92 #include "impr02.h"
  93 #include "meddc0.h"
  94 #include "dicfen.h"
  95 #include "nbfami.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer numfam
 100       integer nbfpe0
 101       integer cfaqua(nctfqu,nbfqua)
 102       integer cfahex(nctfhe,nbfhex)
 103       integer cfapen(nctfpe,nbfpen)
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer iaux, jaux
 110       integer lafami, famdeb
 111       integer fahohe, fammed
 112       integer nufaex
 113 c
 114       integer nbmess
 115       parameter ( nbmess = 10 )
 116       character*80 texte(nblang,nbmess)
 117 c
 118 c 0.5. ==> initialisations
 119 c ______________________________________________________________________
 120 c
 121 c====
 122 c 1. messages
 123 c====
 124 c
 125 #include "impr01.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,1)) 'Entree', nompro
 129       call dmflsh (iaux)
 130 #endif
 131 c
 132 #include "impr03.h"
 133 c
 134 #ifdef _DEBUG_HOMARD_
 135       write (ulsort,90002) 'numfam', numfam
 136       write (ulsort,90002) 'nbfpe0', nbfpe0
 137       write (ulsort,90002) 'nbfqua', nbfqua
 138       write (ulsort,90002) 'nctfqu', nctfqu
 139 #endif
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142       write (ulsort,*) 'Codes des familles des quadrangles'
 143       do 5991 , iaux = 1 , nbfqua
 144         write(ulsort,90012) 'Famille', iaux,
 145      >                      (cfaqua(jaux,iaux),jaux=1,nctfqu)
 146  5991 continue
 147       write (ulsort,*) 'Codes des familles des hexaedres'
 148       do 5992 , iaux = 1 , nbfhex
 149         write(ulsort,90012) 'Famille', iaux,
 150      >                      (cfahex(jaux,iaux),jaux=1,nctfhe)
 151  5992 continue
 152       write (ulsort,*) 'Codes des familles des pentaedres'
 153       do 5993 , iaux = 1 , nbfpen
 154         write(ulsort,90012) 'Famille', iaux,
 155      >                      (cfapen(jaux,iaux),jaux=1,nctfpe)
 156 #endif
 157  5993 continue
 158 c
 159       codret = 0
 160 c
 161 c====
 162 c 2. Parcours des familles de la face avant des quadrangles
 163 c====
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,90002) '2. parcours ; codret', codret
 166 #endif
 167 c
 168       famdeb = numfam + 1
 169       do 20 , lafami = famdeb, nbfqua
 170 c
 171         if ( cfaqua(cofxqp,lafami).eq.0 ) then
 172 cgn        write (ulsort,90002) '. Famille de quadrangle', lafami
 173 c
 174 c 2.1. ==> La famille du volume d'extrusion
 175 c
 176           fahohe = cfaqua(cofxqx,lafami)
 177           fammed = cfahex(cofamd,fahohe)
 178 cgn      write (ulsort,90002) '.. Familles HOMARD/MED hexa',fahohe,fammed
 179 c
 180 c 2.1.2. ==> On veut une famille de pentaedre avec la meme famille MED
 181 c
 182           do 212 , iaux = 1 , nbfpen
 183 c
 184             do 2121 , jaux = 1 , nctfpe
 185               if ( cfapen(cofamd,iaux).ne.fammed ) then
 186                 goto 212
 187               endif
 188  2121       continue
 189 c
 190               nufaex = iaux
 191 cgn            write (ulsort,90002) '.. Correspond a la famille', nufaex
 192               goto 23
 193 c
 194   212       continue
 195 c
 196 c 2.2. ==> Creation d'une nouvelle famille
 197 c 2.2.1. ==> S'il n'y a plus de places, on sort et on recommencera
 198 c            pour cette famille
 199 c
 200           if ( nbfpen.ge.nbfpe0 ) then
 201 c
 202             numfam = lafami - 1
 203             nbfpen = -nbfpen
 204             goto 2999
 205 c
 206 c 2.2.2. ==> Creation
 207 c
 208           else
 209 c
 210 c 2.2.2.1. ==> La famille avec les memes caracteristiques
 211 c
 212             nbfpen = nbfpen + 1
 213             do 222 , iaux = 1 , nctfpe
 214               cfapen(iaux,nbfpen) = 0
 215   222       continue
 216 cgn         write (ulsort,90002) '.. Creation de la famille', nbfpen
 217             cfapen(cofamd,nbfpen) = fammed
 218             if ( cfahex(cotyel,fahohe).eq.edhex8 ) then
 219               cfapen(cotyel,nbfpen) = edpen6
 220             else
 221               cfapen(cotyel,nbfpen) = edpe15
 222             endif
 223             nufaex = nbfpen
 224 c
 225           endif
 226 c
 227 c 2.3. ==> Enregistrement de la famille de pentaedres associee a
 228 c          la famille des hexaedres
 229 c
 230    23     continue
 231 c
 232           cfahex(cofexh,fahohe) = nufaex
 233 c
 234         endif
 235 c
 236    20 continue
 237 c
 238  2999 continue
 239 c
 240 #ifdef _DEBUG_HOMARD_
 241       write (ulsort,90002) 'A la sortie de '//nompro//', nbfhex', nbfhex
 242       write (ulsort,*) 'Codes des familles des hexaedres'
 243       do 6991 , iaux = 1 , abs(nbfhex)
 244         write(ulsort,90012) 'Famille', iaux,
 245      >                      (cfahex(jaux,iaux),jaux=1,nctfhe)
 246  6991 continue
 247       write (ulsort,90002) 'A la sortie de '//nompro//', nbfpen', nbfpen
 248       write (ulsort,*) 'Codes des familles des pentaedres'
 249       do 6992 , iaux = 1 , abs(nbfpen)
 250         write(ulsort,90012) 'Famille', iaux,
 251      >                      (cfapen(jaux,iaux),jaux=1,nctfpe)
 252  6992 continue
 253 #endif
 254 c
 255 c====
 256 c 3. la fin
 257 c====
 258 c
 259       if ( codret.ne.0 ) then
 260 c
 261 #include "envex2.h"
 262 c
 263       write (ulsort,texte(langue,1)) 'Sortie', nompro
 264       write (ulsort,texte(langue,2)) codret
 265 c
 266       endif
 267 c
 268 #ifdef _DEBUG_HOMARD_
 269       write (ulsort,texte(langue,1)) 'Sortie', nompro
 270       call dmflsh (iaux)
 271 #endif
 272 c
 273       end