src/tool/Creation_Maillage/cmh100.F

   1       subroutine cmh100 ( lehexa,
   2      >                    indnoe, indare, indtet, indpyr, indhex,
   3      >                    indptp,
   4      >                    listso, listar, listfa, listcf,
   5      >                    coonoe, hetnoe, arenoe,
   6      >                    famnoe,
   7      >                    hetare, somare,
   8      >                    filare, merare, famare,
   9      >                    aretri,
  10      >                    arequa, filqua,
  11      >                    hettet, aretet,
  12      >                    filtet, pertet, famtet,
  13      >                    hetpyr, arepyr,
  14      >                    filpyr, perpyr, fampyr,
  15      >                    hethex, arehex,
  16      >                    filhex, perhex, famhex,
  17      >                    cfahex,
  18      >                    ulsort, langue, codret )
  19 c ______________________________________________________________________
  20 c
  21 c                             H O M A R D
  22 c
  23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  24 c
  25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  26 c aupres des huissiers de justice Simart et Lavoir a Clamart
  27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  28 c aupres des huissiers de justice
  29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  30 c
  31 c    HOMARD est une marque deposee d'Electricite de France
  32 c
  33 c Copyright EDF 1996
  34 c Copyright EDF 1998
  35 c Copyright EDF 2002
  36 c Copyright EDF 2020
  37 c ______________________________________________________________________
  38 c
  39 c    Creation du Maillage - decoupage de conformite des Hexaedres
  40 c    -           -                                      -
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . lehexa . e   .   1    . hexaedre a decouper                        .
  46 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  47 c . indare . es  .   1    . indice de la derniere arete creee          .
  48 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  49 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  50 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  51 c . indptp . es  .   1    . indice du dernier pere enregistre          .
  52 c . listso . e   .   8    . numeros globaux des sommets                .
  53 c . listar . e   .  12    . numeros globaux des aretes                 .
  54 c . listfa . e   .   6    . numeros globaux des faces                  .
  55 c . listcf . e   .   6    . codes des faces                            .
  56 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  57 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  58 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  59 c . famnoe . es  . nouvno . famille des noeuds                         .
  60 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  61 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  62 c . filare . es  . nouvar . premiere fille des aretes                  .
  63 c . merare . es  . nouvar . mere des aretes                            .
  64 c . famare . es  . nouvar . famille des aretes                         .
  65 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  66 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  67 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  68 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  69 c . aretet . es  .nouvta*6. numeros des 6 aretes des tetraedres        .
  70 c . filtet . es  . nouvte . premier fils des tetraedres                .
  71 c . pertet . es  . nouvte . pere des tetraedres                        .
  72 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  73 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  74 c . famtet . es  . nouvte . famille des tetraedres                     .
  75 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  76 c . arepyr . es  .nouvya*8. numeros des 8 aretes des pyramides         .
  77 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . es  . nouvpy . pere des pyramides                         .
  79 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  80 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  81 c . fampyr . es  . nouvpy . famille des pyramides                      .
  82 c . hethex . es  . nouvhe . historique de l'etat des hexaedres         .
  83 c . arehex . es  .nouvha12. numeros des 12 aretes des hexaedres        .
  84 c . filhex . es  . nouvhe . premier fils des hexaedres                 .
  85 c . perhex . es  . nouvhe . pere des hexaedres                         .
  86 c . famhex . es  . nouvhe . famille des hexaedres                      .
  87 c . cfahex . e   . nctfhe. codes des familles des hexaedres            .
  88 c .        .     . nbfhex .   1 : famille MED                          .
  89 c .        .     .        .   2 : type d'hexaedres                     .
  90 c .        .     .        .   3 : famille des tetraedres de conformite .
  91 c .        .     .        .   4 : famille des pyramides de conformite  .
  92 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  93 c . langue . e   .    1   . langue des messages                        .
  94 c .        .     .        . 1 : francais, 2 : anglais                  .
  95 c . codret . es  .    1   . code de retour des modules                 .
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 0. declarations et dimensionnement
 100 c====
 101 c
 102 c 0.1. ==> generalites
 103 c
 104       implicit none
 105       save
 106 c
 107       character*6 nompro
 108       parameter ( nompro ='CMH100' )
 109 c
 110       integer nbsomm
 111       parameter ( nbsomm = 8 )
 112 c
 113 #include "nblang.h"
 114 #include "cofpfh.h"
 115 c
 116 c 0.2. ==> communs
 117 c
 118 #include "envex1.h"
 119 c
 120 #include "envca1.h"
 121 #include "dicfen.h"
 122 #include "nbfami.h"
 123 #include "nouvnb.h"
 124 c
 125 c 0.3. ==> arguments
 126 c
 127       integer lehexa
 128       integer indnoe, indare, indtet, indpyr, indhex
 129       integer indptp
 130       integer listso(8), listar(12), listfa(6), listcf(6)
 131       integer hetnoe(nouvno), arenoe(nouvno)
 132       integer famnoe(nouvno)
 133       integer hetare(nouvar), somare(2,nouvar)
 134       integer filare(nouvar), merare(nouvar), famare(nouvar)
 135       integer aretri(nouvtr,3)
 136       integer arequa(nouvqu,4)
 137       integer filqua(nouvqu)
 138       integer hettet(nouvte), aretet(nouvta,6)
 139       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 140       integer hetpyr(nouvpy), arepyr(nouvya,8)
 141       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 142       integer arehex(nouvha,12)
 143       integer hethex(nouvhe)
 144       integer filhex(nouvhe), perhex(nouvhe)
 145       integer cfahex(nctfhe,nbfhex), famhex(nouvhe)
 146 c
 147       double precision coonoe(nouvno,sdim)
 148 c
 149       integer ulsort, langue, codret
 150 c
 151 c 0.4. ==> variables locales
 152 c
 153       integer iaux, jaux
 154 c
 155       integer lesnoe(9), areint(9)
 156       integer fdnume, fdcode
 157       integer are1, are2, are3, are4
 158       integer are5, are6, are7, are8
 159
 160       integer as1n1, as2n1
 161       integer as3n1, as4n1
 162       integer as5n1, as6n1
 163 c
 164       integer nbmess
 165       parameter ( nbmess = 10 )
 166       character*80 texte(nblang,nbmess)
 167 c
 168 c 0.5. ==> initialisations
 169 c ______________________________________________________________________
 170 c
 171 c====
 172 c 1. messages
 173 c====
 174 c
 175 #include "impr01.h"
 176 #include "impr03.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,1)) 'Entree', nompro
 180       call dmflsh (iaux)
 181 #endif
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,90002) 'indnoe', indnoe
 185       write (ulsort,90002) 'indtet', indtet
 186       write (ulsort,90002) 'indpyr', indpyr
 187       write (ulsort,90002) 'indhex', indhex
 188 #endif
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,90002) 'listar  1-8', (listar(iaux),iaux=1,8)
 191       write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
 192       write (ulsort,90002) 'listso', listso
 193       write (ulsort,90002) 'listfa', listfa
 194       write (ulsort,90002) 'listcf', listcf
 195 #endif
 196 c
 197       codret = 0
 198 c
 199 c====
 200 c 2. Recuperation
 201 c    . des sommets de l'hexaedre
 202 c    . du noeud milieu de l'arete coupee
 203 c====
 204 c
 205       do 21 , iaux = 1 , 8
 206         lesnoe(iaux) = listso(iaux)
 207    21 continue
 208 c
 209       lesnoe(9) = somare(2,filare(listar(1)))
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       do 2000 , iaux = 1 , 9
 213         write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
 214  2000 continue
 215 #endif
 216 c
 217 c====
 218 c 3. Recuperation des aretes tracees sur les faces coupees en 3
 219 c====
 220 c
 221       fdnume = listfa(1)
 222       jaux = -filqua(fdnume)
 223       if ( listcf(1).lt.5 ) then
 224         as4n1 = aretri(jaux,1)
 225         as3n1 = aretri(jaux,3)
 226         as1n1 = aretri(jaux+1,1)
 227         as2n1 = aretri(jaux+2,1)
 228       else
 229         as4n1 = aretri(jaux,3)
 230         as3n1 = aretri(jaux,1)
 231         as1n1 = aretri(jaux+2,1)
 232         as2n1 = aretri(jaux+1,1)
 233       endif
 234 c
 235       fdnume = listfa(2)
 236       jaux = -filqua(fdnume)
 237       if ( listcf(2).lt.5 ) then
 238         as6n1 = aretri(jaux,3)
 239         as5n1 = aretri(jaux,1)
 240       else
 241         as6n1 = aretri(jaux,1)
 242         as5n1 = aretri(jaux,3)
 243       endif
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write(ulsort,90002) 'as1n1, as2n1', as1n1, as2n1
 247       write(ulsort,90002) 'as3n1, as4n1', as3n1, as4n1
 248       write(ulsort,90002) 'as5n1, as6n1', as5n1, as6n1
 249 #endif
 250 c
 251 c====
 252 c 4. Creation des deux aretes internes
 253 c    areint(1) : AS7N1
 254 c    areint(2) : AS8N1
 255 c====
 256 c
 257       do 41 , iaux = 1 , 2
 258 c
 259         indare = indare + 1
 260         areint(iaux) = indare
 261 c
 262         somare(1,areint(iaux)) = min ( lesnoe(9) , lesnoe(6+iaux) )
 263         somare(2,areint(iaux)) = max ( lesnoe(9) , lesnoe(6+iaux) )
 264 c
 265         famare(areint(iaux)) = 1
 266         hetare(areint(iaux)) = 50
 267         merare(areint(iaux)) = 0
 268         filare(areint(iaux)) = 0
 269 #ifdef _DEBUG_HOMARD_
 270       write(ulsort,90006) 'areint(iaux) = ', areint(iaux),
 271      >                    ' de ',somare(1,areint(iaux)),
 272      >                    ' a ',somare(2,areint(iaux))
 273 #endif
 274 c
 275    41 continue
 276 c
 277 c====
 278 c 5. Creation des 4 pyramides
 279 c====
 280 c
 281       iaux = -indptp
 282       jaux = cfahex(cofpfh,famhex(lehexa))
 283 c
 284 c 5.1. ==> Sur la face 3
 285 c
 286       indpyr = indpyr + 1
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro
 289 #endif
 290       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 291      >              as4n1, as1n1, as6n1, areint(1),
 292      >              listar(2), listar(5), listar(10), listar(7),
 293      >              iaux,  jaux,   indpyr )
 294 c
 295 c 5.2. ==> Sur la face 4
 296 c
 297       indpyr = indpyr + 1
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro
 300 #endif
 301       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 302      >              as2n1, as3n1, areint(2), as5n1,
 303      >              listar(3), listar(8), listar(11), listar(6),
 304      >              iaux,  jaux,   indpyr )
 305 c
 306 c 5.3. ==> Sur la face 5
 307 c
 308       indpyr = indpyr + 1
 309 #ifdef _DEBUG_HOMARD_
 310       write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro
 311 #endif
 312       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 313      >              as3n1, as4n1, areint(1), areint(2),
 314      >              listar(4), listar(7), listar(12), listar(8),
 315      >              iaux,  jaux,   indpyr )
 316 c
 317 c 5.4. ==> Sur la face 6
 318 c
 319       indpyr = indpyr + 1
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro
 322 #endif
 323       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 324      >              as6n1, as5n1, areint(2), areint(1),
 325      >              listar(9), listar(11), listar(12), listar(10),
 326      >              iaux,  jaux,   indpyr )
 327 c
 328 c====
 329 c 5. la fin
 330 c====
 331 c
 332       if ( codret.ne.0 ) then
 333 c
 334 #include "envex2.h"
 335 c
 336       write (ulsort,texte(langue,1)) 'Sortie', nompro
 337       write (ulsort,texte(langue,2)) codret
 338 c
 339       endif
 340 c
 341 #ifdef _DEBUG_HOMARD_
 342       write (ulsort,texte(langue,1)) 'Sortie', nompro
 343       call dmflsh (iaux)
 344 #endif
 345 c
 346       end