src/tool/ES_HOMARD/esece2.F

   1       subroutine esece2 ( typenh, nbencf, nbenca, nbrfma,
   2      >                    somare, codeen, infosu, codear,
   3      >                    tbiaux,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c  Entree-Sortie : ECriture d'une Entite - 2
  26 c  -      -        --             -        -
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . typenh . e   .   1    . code des entites                           .
  31 c .        .     .        .  -1 : noeuds                               .
  32 c .        .     .        .   0 : mailles-points                       .
  33 c .        .     .        .   1 : aretes                               .
  34 c .        .     .        .   2 : triangles                            .
  35 c .        .     .        .   3 : tetraedres                           .
  36 c .        .     .        .   4 : quadrangles                          .
  37 c .        .     .        .   5 : pyramides                            .
  38 c .        .     .        .   6 : hexaedres                            .
  39 c .        .     .        .   7 : pentaedres                           .
  40 c . nbencf . e   .   1    . nombre d'entites decrites par faces        .
  41 c . nbenca . e   .   1    . nombre d'entites decrites par aretes       .
  42 c . nbrfma . e   .   1    . nbre faces par maille                      .
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . codeen . e   .nbencf**. connectivite descendante des mailles       .
  45 c . infosu . e   .nbencf**. code des faces dans les mailles 3D         .
  46 c . codear . e   .nbenca**. connectivite des mailles par aretes        .
  47 c . tbiaux .  s  .    *   . tableau tampon entier                      .
  48 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  49 c . langue . e   .    1   . langue des messages                        .
  50 c .        .     .        . 1 : francais, 2 : anglais                  .
  51 c . codret . es  .    1   . code de retour des modules                 .
  52 c .        .     .        . 0 : pas de probleme                        .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'ESECE2' )
  66 c
  67 #include "nblang.h"
  68 #include "consts.h"
  69 c
  70 c 0.2. ==> communs
  71 c
  72 #include "envex1.h"
  73 #include "fahmed.h"
  74 #include "oriett.h"
  75 #include "orieqh.h"
  76 #include "oriefp.h"
  77 #include "oriefy.h"
  78 c
  79 #include "impr02.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer typenh
  84       integer nbencf, nbenca, nbrfma
  85       integer somare(2,*)
  86       integer codeen(nbencf,*), infosu(nbencf,*), codear(nbenca,*)
  87       integer tbiaux(*)
  88 c
  89       integer ulsort, langue, codret
  90 c
  91 c 0.4. ==> variables locales
  92 c
  93 #include "meddc0.h"
  94 c
  95       integer iaux, jaux, kaux, laux
  96       integer orient(8)
  97       integer aret(4)
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 100 )
 101       character*80 texte(nblang,nbmess)
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 1. messages
 106 c====
 107 c
 108 #include "impr01.h"
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       write (ulsort,texte(langue,1)) 'Entree', nompro
 112       call dmflsh (iaux)
 113 #endif
 114 c
 115       texte(1,4) = '(''... Conversion des '',i10,1x,a)'
 116 c
 117       texte(2,4) = '(''... Conversion of '',i10,1x,a)'
 118 c
 119 #include "impr03.h"
 120 c
 121 #ifdef _DEBUG_HOMARD_
 122       write (ulsort,texte(langue,4)) nbencf, mess14(langue,3,typenh)
 123       write (ulsort,90002) 'nbencf', nbencf
 124       write (ulsort,90002) 'nbenca', nbenca
 125 #endif
 126 c
 127 c====
 128 c 2. Mise en place de la connectivite descendante
 129 c====
 130 c
 131       if ( codret.eq.0 ) then
 132 c
 133       kaux = 0
 134 c
 135 c 2.1. ==> Triangles
 136 c
 137       if ( typenh.eq.2 ) then
 138 c
 139         do 221 , iaux = 1, nbencf
 140           do 2211, jaux = 1, nbrfma
 141             aret(jaux) = codeen(iaux,jaux)
 142  2211     continue
 143 cgn          write(ulsort,*)aret
 144           call utorat ( somare, aret(1), aret(2), aret(3),
 145      >                  orient(1), orient(2), orient(3) )
 146 cgn          write(ulsort,*)(orient(jaux),jaux = 1, nbrfma)
 147           do 2212, jaux = 1, nbrfma
 148             kaux = kaux + 1
 149             tbiaux(kaux) = orient(jaux)*aret(jaux)
 150  2212     continue
 151   221   continue
 152 c
 153 c 2.3. ==> Tetraedres
 154 c
 155       elseif ( typenh.eq.3 ) then
 156 c
 157 cgn            write(ulsort,*) typenh
 158         do 231 , iaux = 1, nbencf
 159           do 2311, jaux = 1, nbrfma
 160             laux = nofmed(typenh,jaux,1)
 161 cgn          write(ulsort,*) jaux,laux
 162             orient(jaux) = orcott(laux,infosu(iaux,laux))
 163 cgn          write(ulsort,*) laux, codeen(iaux,laux), orient(jaux)
 164             kaux = kaux + 1
 165             tbiaux(kaux) = orient(jaux)*codeen(iaux,laux)
 166  2311     continue
 167   231   continue
 168 c
 169 c 2.4. ==> Quadrangles
 170 c
 171       elseif ( typenh.eq.4 ) then
 172 c
 173         do 241 , iaux = 1, nbencf
 174           do 2411, jaux = 1, nbrfma
 175             aret(jaux) = codeen(iaux,jaux)
 176  2411     continue
 177 cgn          write(ulsort,*)aret
 178           call utoraq ( somare, aret(1), aret(2), aret(3), aret(4),
 179      >                  orient(1), orient(2), orient(3), orient(4) )
 180 cgn          write(ulsort,*)(orient(jaux),jaux = 1, nbrfma)
 181           do 2412, jaux = 1, nbrfma
 182             kaux = kaux + 1
 183             tbiaux(kaux) = orient(jaux)*aret(jaux)
 184  2412     continue
 185   241   continue
 186 c
 187 c 2.5. ==> Pyramides
 188 c
 189       elseif ( typenh.eq.5 ) then
 190 c
 191         do 251 , iaux = 1, nbencf
 192           do 2511, jaux = 1, nbrfma
 193             laux = nofmed(typenh,jaux,1)
 194             orient(jaux) = orcofy(laux,infosu(iaux,laux))
 195 cgn          write(ulsort,*) laux, codeen(iaux,laux), orient(jaux)
 196             kaux = kaux + 1
 197             tbiaux(kaux) = orient(jaux)*codeen(iaux,laux)
 198  2511     continue
 199   251   continue
 200 c
 201 c 2.6. ==> Hexaedres
 202 c
 203       elseif ( typenh.eq.6 ) then
 204 c
 205         do 261 , iaux = 1, nbencf
 206           do 2611, jaux = 1, nbrfma
 207             laux = nofmed(typenh,jaux,1)
 208             orient(jaux) = orcoqh(laux,infosu(iaux,laux))
 209 cgn          write(ulsort,*) laux, codeen(iaux,laux), orient(jaux)
 210             kaux = kaux + 1
 211             tbiaux(kaux) = orient(jaux)*codeen(iaux,laux)
 212  2611     continue
 213   261   continue
 214 c
 215 c 2.7. ==> Pentaedres
 216 c
 217       elseif ( typenh.eq.7 ) then
 218 c
 219         do 271 , iaux = 1, nbencf
 220           do 2711, jaux = 1, nbrfma
 221             laux = nofmed(typenh,jaux,1)
 222             orient(jaux) = orcofp(laux,infosu(iaux,laux))
 223 cgn          write(ulsort,*) laux, codeen(iaux,laux), orient(jaux)
 224             kaux = kaux + 1
 225             tbiaux(kaux) = orient(jaux)*codeen(iaux,laux)
 226  2711     continue
 227   271   continue
 228 c
 229 c
 230       else
 231 c
 232 c 2.8. ==> Probleme
 233 c
 234         codret = 28
 235 c
 236       endif
 237 c
 238       endif
 239 c
 240 c====
 241 c 3. Quand il peut y avoir une description par arete, on complete
 242 c    le tableau avec les premieres valeurs de la connectivite
 243 c    pour optimiser le remplissage et utiliser le dimensionnement
 244 c    habituel des entites, nbento
 245 c    Une entite a nbrfac faces et nbrare aretes.
 246 c    La connectivite descendante ecrite dans le fichier med
 247 c    est dimensionnee a nbento*nbrfac.
 248 c    Dans esece2, on remplit donc le tableau avec deux parties :
 249 c    . La connectivite descendante proprement dite, soit
 250 c      nbencf*nbrfac variables.
 251 c    . La connectivite par aretes des nbenca entites decrites, en
 252 c      se limitant aux nbrfac premieres, soit nbenca*nbrfac
 253 c      variables.
 254 c    Cela fait bien en tout nbento*nbrfac = (nbencf+nbenca)*nbrfac
 255 c    On ecrit dans esecs5 la fin des descriptions par aretes,
 256 c    donc au dela de la nbrfac-ieme.
 257 c    Exemple : les pyramides sont decrites par 5 faces ou 8 aretes.
 258 c    Pour toutes celles decrites par aretes, on met ici les numeros
 259 c    de leurs 5 premieres aretes. Les autres seront geres avec les
 260 c    profils dans esecs5
 261 c    La lecture est faite dans eslee1.
 262 c====
 263 c
 264       if ( nbenca.gt.0 ) then
 265 c
 266         if ( codret.eq.0 ) then
 267 c
 268         do 31 , iaux = 1, nbenca
 269 c
 270           do 311, jaux = 1, nbrfma
 271             kaux = kaux + 1
 272             tbiaux(kaux) = codear(iaux,jaux)
 273   311     continue
 274 c
 275    31   continue
 276 c
 277         endif
 278 c
 279       endif
 280 c
 281 c====
 282 c 4. la fin
 283 c====
 284 c
 285       if ( codret.ne.0 ) then
 286 c
 287 #include "envex2.h"
 288 c
 289       write (ulsort,texte(langue,1)) 'Sortie', nompro
 290       write (ulsort,texte(langue,2)) codret
 291 c
 292       endif
 293 c
 294 #ifdef _DEBUG_HOMARD_
 295       write (ulsort,texte(langue,1)) 'Sortie', nompro
 296       call dmflsh (iaux)
 297 #endif
 298 c
 299       end