src/tool/Creation_Maillage/cmchf0.F

   1       subroutine cmchf0 ( lehexa, etahex, etatfa,
   2      >                    indare, indtri, indtet, indpyr,
   3      >                    indptp,
   4      >                    hetare, somare,
   5      >                    filare, merare, famare,
   6      >                    hettri, aretri,
   7      >                    filtri, pertri, famtri,
   8      >                    nivtri,
   9      >                    arequa, filqua,
  10      >                    hettet, tritet, cotrte,
  11      >                    filtet, pertet, famtet,
  12      >                    hetpyr, facpyr, cofapy,
  13      >                    filpyr, perpyr, fampyr,
  14      >                    quahex, coquhe,
  15      >                    famhex, cfahex,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  24 c aupres des huissiers de justice Simart et Lavoir a Clamart
  25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  26 c aupres des huissiers de justice
  27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  38 c    -           -          -                          -
  39 c                         - par 1 Face - pilotage
  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 . etahex .  s  .    1   . etat final de l'hexaedre                   .
  47 c . etatfa . e   .   6    . etat des faces de l'hexaedre               .
  48 c . indare . es  .   1    . indice de la derniere arete creee          .
  49 c . indtri . es  .   1    . indice du dernier triangle cree            .
  50 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  51 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  52 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  53 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  54 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  55 c . filare . es  . nouvar . premiere fille des aretes                  .
  56 c . merare . es  . nouvar . mere des aretes                            .
  57 c . famare .     . nouvar . famille des aretes                         .
  58 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  59 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  60 c . filtri . es  . nouvtr . premier fils des triangles                 .
  61 c . pertri . es  . nouvtr . pere des triangles                         .
  62 c . famtri . es  . nouvtr . famille des triangles                      .
  63 c . nivtri . es  . nouvtr . niveau des triangles                       .
  64 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  65 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  66 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  67 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  68 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  69 c . filtet . es  . nouvte . premier fils des tetraedres                .
  70 c . pertet . es  . nouvte . pere des tetraedres                        .
  71 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  72 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  73 c . famtet . es  . nouvte . famille des tetraedres                     .
  74 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  75 c . facpyr . e   .nouvyf*5. numeros des 5 faces des pyramides          .
  76 c . cofapy . e   .nouvyf*5. codes des faces des pyramides              .
  77 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . e   . 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 . e   . nouvpy . famille des pyramides                      .
  82 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  83 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  84 c . famhex . e   . nouvhe . famille des hexaedres                      .
  85 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  86 c .        .     . nbfhex .   1 : famille MED                          .
  87 c .        .     .        .   2 : type d'hexaedres                     .
  88 c .        .     .        .   3 : famille des tetraedres de conformite .
  89 c .        .     .        .   4 : famille des pyramides de conformite  .
  90 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  91 c . langue . e   .    1   . langue des messages                        .
  92 c .        .     .        . 1 : francais, 2 : anglais                  .
  93 c . codret . es  .    1   . code de retour des modules                 .
  94 c .        .     .        . 0 : pas de probleme                        .
  95 c .        .     .        . 1 : aucune face ne correspond              .
  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 = 'CMCHF0' )
 109 c
 110 #include "nblang.h"
 111 c
 112 c 0.2. ==> communs
 113 c
 114 #include "envex1.h"
 115 c
 116 #include "dicfen.h"
 117 #include "nbfami.h"
 118 #include "nouvnb.h"
 119 #include "impr02.h"
 120 c
 121 c 0.3. ==> arguments
 122 c
 123       integer lehexa, etahex, etatfa(6)
 124       integer indare, indtri, indtet, indpyr
 125       integer indptp
 126       integer hetare(nouvar), somare(2,nouvar)
 127       integer filare(nouvar), merare(nouvar), famare(nouvar)
 128       integer hettri(nouvtr), aretri(nouvtr,3)
 129       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 130       integer nivtri(nouvtr)
 131       integer arequa(nouvqu,4), filqua(nouvqu)
 132       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 133       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 134       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 135       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 136       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 137       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 138 c
 139       integer ulsort, langue, codret
 140 c
 141 c 0.4. ==> variables locales
 142 c
 143       integer iaux
 144       integer listar(12), listso(8)
 145 c
 146       integer nbmess
 147       parameter ( nbmess = 10 )
 148       character*80 texte(nblang,nbmess)
 149 c
 150 c 0.5. ==> initialisations
 151 c ______________________________________________________________________
 152 c
 153 c====
 154 c 1. messages
 155 c====
 156 c
 157 #include "impr01.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,texte(langue,1)) 'Entree', nompro
 161       call dmflsh (iaux)
 162       write (ulsort,1000) 'indtri', indtri
 163       write (ulsort,1000) 'indtet', indtet
 164       write (ulsort,1000) 'indpyr', indpyr
 165  1000 format (a6,' =',i10)
 166 #endif
 167 c
 168       texte(1,4) = '(''Aucune face ne correspond.'')'
 169       texte(1,5) = '(''Liste des '',a,'' :'',6i10)'
 170       texte(1,6) = '(''avec les etats           :'',6i10)'
 171 c
 172       texte(2,4) = '(''No face is good'')'
 173       texte(2,5) = '(''List of '',a,'' :'',6i10)'
 174       texte(2,6) = '(''with status              :'',6i10)'
 175 c
 176       codret = 0
 177 c
 178 c====
 179 c 2. Recherche des faces, des aretes et des sommets
 180 c====
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,3)) 'UTARHE', nompro
 184 #endif
 185       call utarhe ( lehexa,
 186      >              nouvqu, nouvhe,
 187      >              arequa, quahex, coquhe,
 188      >              listar )
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,3)) 'UTSOHE', nompro
 192 #endif
 193       call utsohe ( somare, listar, listso )
 194 #ifdef _DEBUG_HOMARD_
 195       write(ulsort,*) 'listar = ', listar
 196       write(ulsort,*) 'listso = ', listso
 197 #endif
 198 c
 199 c====
 200 c 3. decoupage
 201 c====
 202 #ifdef _DEBUG_HOMARD_
 203        iaux = 212
 204       write(ulsort,*) 'arequa(iaux,1) = ', arequa(iaux,1),
 205      >                   ' de ',somare(1,arequa(iaux,1)),
 206      >                   ' a ',somare(2,arequa(iaux,1))
 207       write(ulsort,*) 'arequa(iaux,2) = ', arequa(iaux,2),
 208      >                   ' de ',somare(1,arequa(iaux,2)),
 209      >                   ' a ',somare(2,arequa(iaux,2))
 210       write(ulsort,*) 'arequa(iaux,3) = ', arequa(iaux,3),
 211      >                   ' de ',somare(1,arequa(iaux,3)),
 212      >                   ' a ',somare(2,arequa(iaux,3))
 213       write(ulsort,*) 'arequa(iaux,4) = ', arequa(iaux,4),
 214      >                   ' de ',somare(1,arequa(iaux,4)),
 215      >                   ' a ',somare(2,arequa(iaux,4))
 216 #endif
 217 c
 218 c 3.1. ==> C'est la face 1 qui est coupee
 219 c
 220       if ( etatfa(1).eq.4 ) then
 221         etahex = 285
 222 #ifdef _DEBUG_HOMARD_
 223       write (ulsort,texte(langue,3)) 'CMCH41', nompro
 224 #endif
 225         call cmch41 ( lehexa, listar, listso,
 226      >                indare, indtri, indtet, indpyr,
 227      >                indptp,
 228      >                hetare, somare,
 229      >                filare, merare, famare,
 230      >                hettri, aretri,
 231      >                filtri, pertri, famtri,
 232      >                nivtri,
 233      >                arequa, filqua,
 234      >                hettet, tritet, cotrte,
 235      >                filtet, pertet, famtet,
 236      >                hetpyr, facpyr, cofapy,
 237      >                filpyr, perpyr, fampyr,
 238      >                quahex, coquhe,
 239      >                famhex, cfahex,
 240      >                ulsort, langue, codret )
 241 c
 242 c 3.2. ==> C'est la face 2 qui est coupee
 243 c
 244       elseif ( etatfa(2).eq.4 ) then
 245         etahex = 286
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,texte(langue,3)) 'CMCH42', nompro
 248 #endif
 249         call cmch42 ( lehexa, listar, listso,
 250      >                indare, indtri, indtet, indpyr,
 251      >                indptp,
 252      >                hetare, somare,
 253      >                filare, merare, famare,
 254      >                hettri, aretri,
 255      >                filtri, pertri, famtri,
 256      >                nivtri,
 257      >                arequa, filqua,
 258      >                hettet, tritet, cotrte,
 259      >                filtet, pertet, famtet,
 260      >                hetpyr, facpyr, cofapy,
 261      >                filpyr, perpyr, fampyr,
 262      >                quahex, coquhe,
 263      >                famhex, cfahex,
 264      >                ulsort, langue, codret )
 265 c
 266 c 3.3. ==> C'est la face 3 qui est coupee
 267 c
 268       elseif ( etatfa(3).eq.4 ) then
 269         etahex = 287
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'CMCH43', nompro
 272       write (ulsort,*) 'indtri = ', indtri
 273 #endif
 274         call cmch43 ( lehexa, listar, listso,
 275      >                indare, indtri, indtet, indpyr,
 276      >                indptp,
 277      >                hetare, somare,
 278      >                filare, merare, famare,
 279      >                hettri, aretri,
 280      >                filtri, pertri, famtri,
 281      >                nivtri,
 282      >                arequa, filqua,
 283      >                hettet, tritet, cotrte,
 284      >                filtet, pertet, famtet,
 285      >                hetpyr, facpyr, cofapy,
 286      >                filpyr, perpyr, fampyr,
 287      >                quahex, coquhe,
 288      >                famhex, cfahex,
 289      >                ulsort, langue, codret )
 290 c
 291 c 3.4. ==> C'est la face 4 qui est coupee
 292 c
 293       elseif ( etatfa(4).eq.4 ) then
 294         etahex = 288
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,3)) 'CMCH44', nompro
 297 #endif
 298         call cmch44 ( lehexa, listar, listso,
 299      >                indare, indtri, indtet, indpyr,
 300      >                indptp,
 301      >                hetare, somare,
 302      >                filare, merare, famare,
 303      >                hettri, aretri,
 304      >                filtri, pertri, famtri,
 305      >                nivtri,
 306      >                arequa, filqua,
 307      >                hettet, tritet, cotrte,
 308      >                filtet, pertet, famtet,
 309      >                hetpyr, facpyr, cofapy,
 310      >                filpyr, perpyr, fampyr,
 311      >                quahex, coquhe,
 312      >                famhex, cfahex,
 313      >                ulsort, langue, codret )
 314 c
 315 c 3.5. ==> C'est la face 5 qui est coupee
 316 c
 317       elseif ( etatfa(5).eq.4 ) then
 318         etahex = 289
 319 #ifdef _DEBUG_HOMARD_
 320       write (ulsort,texte(langue,3)) 'CMCH45', nompro
 321 #endif
 322         call cmch45 ( lehexa, listar, listso,
 323      >                indare, indtri, indtet, indpyr,
 324      >                indptp,
 325      >                hetare, somare,
 326      >                filare, merare, famare,
 327      >                hettri, aretri,
 328      >                filtri, pertri, famtri,
 329      >                nivtri,
 330      >                arequa, filqua,
 331      >                hettet, tritet, cotrte,
 332      >                filtet, pertet, famtet,
 333      >                hetpyr, facpyr, cofapy,
 334      >                filpyr, perpyr, fampyr,
 335      >                quahex, coquhe,
 336      >                famhex, cfahex,
 337      >                ulsort, langue, codret )
 338 c
 339 c 3.6. ==> C'est la face 6 qui est coupee
 340 c
 341       elseif ( etatfa(6).eq.4 ) then
 342         etahex = 290
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,texte(langue,3)) 'CMCH46', nompro
 345 #endif
 346         call cmch46 ( lehexa, listar, listso,
 347      >                indare, indtri, indtet, indpyr,
 348      >                indptp,
 349      >                hetare, somare,
 350      >                filare, merare, famare,
 351      >                hettri, aretri,
 352      >                filtri, pertri, famtri,
 353      >                nivtri,
 354      >                arequa, filqua,
 355      >                hettet, tritet, cotrte,
 356      >                filtet, pertet, famtet,
 357      >                hetpyr, facpyr, cofapy,
 358      >                filpyr, perpyr, fampyr,
 359      >                quahex, coquhe,
 360      >                famhex, cfahex,
 361      >                ulsort, langue, codret )
 362 c
 363 c 3.7. ==> Laquelle ?
 364 c
 365       else
 366         codret = 1
 367       endif
 368 c
 369 c====
 370 c 4. la fin
 371 c====
 372 c
 373       if ( codret.ne.0 ) then
 374 c
 375 #include "envex2.h"
 376 c
 377       write (ulsort,texte(langue,1)) 'Sortie', nompro
 378       write (ulsort,texte(langue,2)) codret
 379       write (ulsort,texte(langue,4))
 380       write (ulsort,texte(langue,5)) mess14(langue,3,4),
 381      >                      ( quahex(lehexa,iaux), iaux=1,6 )
 382       write (ulsort,texte(langue,6)) (etatfa(iaux),iaux=1,6 )
 383 c
 384       endif
 385 c
 386 #ifdef _DEBUG_HOMARD_
 387       write (ulsort,texte(langue,1)) 'Sortie', nompro
 388       call dmflsh (iaux)
 389 #endif
 390 c
 391       end