src/tool/Creation_Maillage/cmcha1.F

   1       subroutine cmcha1 ( lehexa, etahex,
   2      >                    indare, indtri, indpyr,
   3      >                    indptp,
   4      >                    hetare, somare,
   5      >                    filare, merare, famare,
   6      >                    hettri, aretri,
   7      >                    filtri, pertri, famtri,
   8      >                    nivtri,
   9      >                    arequa, filqua,
  10      >                    hetpyr, facpyr, cofapy,
  11      >                    filpyr, perpyr, fampyr,
  12      >                    quahex, coquhe,
  13      >                    famhex, cfahex,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  36 c    -           -          -                          -
  37 c                         - par 1 Arete - pilotage
  38 c                               - -
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . lehexa . e   .   1    . hexaedre a decouper                        .
  44 c . etahex .  s  .    1   . etat final de l'hexaedre                   .
  45 c . indare . es  .   1    . indice de la derniere arete creee          .
  46 c . indtri . es  .   1    . indice du dernier triangle cree            .
  47 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  48 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  49 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  50 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  51 c . filare . es  . nouvar . premiere fille des aretes                  .
  52 c . merare . es  . nouvar . mere des aretes                            .
  53 c . famare .     . nouvar . famille des aretes                         .
  54 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  55 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  56 c . filtri . es  . nouvtr . premier fils des triangles                 .
  57 c . pertri . es  . nouvtr . pere des triangles                         .
  58 c . famtri . es  . nouvtr . famille des triangles                      .
  59 c . nivtri . es  . nouvtr . niveau des triangles                       .
  60 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  61 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  62 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  63 c . facpyr . e   .nouvyf*5. numeros des 5 faces des pyramides          .
  64 c . cofapy . e   .nouvyf*5. codes des faces des pyramides              .
  65 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  66 c . perpyr . e   . nouvpy . pere des pyramides                         .
  67 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  68 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  69 c . fampyr . e   . nouvpy . famille des pyramides                      .
  70 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  71 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  72 c . famhex . e   . nouvhe . famille des hexaedres                      .
  73 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  74 c .        .     . nbfhex .   1 : famille MED                          .
  75 c .        .     .        .   2 : type d'hexaedres                     .
  76 c .        .     .        .   3 : famille des tetraedres de conformite .
  77 c .        .     .        .   4 : famille des pyramides de conformite  .
  78 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  79 c . langue . e   .    1   . langue des messages                        .
  80 c .        .     .        . 1 : francais, 2 : anglais                  .
  81 c . codret . es  .    1   . code de retour des modules                 .
  82 c .        .     .        . 0 : pas de probleme                        .
  83 c .        .     .        . 1 : aucune arete ne correspond             .
  84 c ______________________________________________________________________
  85 c
  86 c====
  87 c 0. declarations et dimensionnement
  88 c====
  89 c
  90 c 0.1. ==> generalites
  91 c
  92       implicit none
  93       save
  94 c
  95       character*6 nompro
  96       parameter ( nompro = 'CMCHA1' )
  97 c
  98 #include "nblang.h"
  99 c
 100 c 0.2. ==> communs
 101 c
 102 #include "envex1.h"
 103 c
 104 #include "dicfen.h"
 105 #include "nbfami.h"
 106 #include "nouvnb.h"
 107 c
 108 c 0.3. ==> arguments
 109 c
 110       integer lehexa, etahex
 111       integer indare, indtri, indpyr
 112       integer indptp
 113       integer hetare(nouvar), somare(2,nouvar)
 114       integer filare(nouvar), merare(nouvar), famare(nouvar)
 115       integer hettri(nouvtr), aretri(nouvtr,3)
 116       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 117       integer nivtri(nouvtr)
 118       integer arequa(nouvqu,4)
 119       integer filqua(nouvqu)
 120       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 121       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 122       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 123       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 124 c
 125       integer ulsort, langue, codret
 126 c
 127 c 0.4. ==> variables locales
 128 c
 129       integer iaux
 130       integer listar(12), listso(8)
 131 c
 132       integer nbmess
 133       parameter ( nbmess = 10 )
 134       character*80 texte(nblang,nbmess)
 135 c
 136 c 0.5. ==> initialisations
 137 c ______________________________________________________________________
 138 c
 139 c====
 140 c 1. messages
 141 c====
 142 c
 143 #include "impr01.h"
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,1)) 'Entree', nompro
 147       call dmflsh (iaux)
 148       write (ulsort,1000) 'indare', indare
 149       write (ulsort,1000) 'indtri', indtri
 150       write (ulsort,1000) 'indpyr', indpyr
 151  1000 format (a6,' =',i10)
 152 #endif
 153 c
 154       texte(1,4) ='(''Aucune arete ne correspond.'')'
 155 c
 156       texte(2,4) ='(''No Edge is good.'')'
 157 c
 158       codret = 0
 159 c
 160 c====
 161 c 2. Recherche des aretes et des sommets
 162 c====
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,texte(langue,3)) 'UTARHE', nompro
 166 #endif
 167       call utarhe ( lehexa,
 168      >              nouvqu, nouvhe,
 169      >              arequa, quahex, coquhe,
 170      >              listar )
 171 c
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,texte(langue,3)) 'UTSOHE', nompro
 174 #endif
 175       call utsohe ( somare, listar, listso )
 176 c
 177 c====
 178 c 3. Recherche de l'arete decoupee
 179 c====
 180 #ifdef _DEBUG_HOMARD_
 181       write(ulsort,*) 'listar(1) = ', listar(1),
 182      >                   ' de ',somare(1,listar(1)),
 183      >                   ' a ',somare(2,listar(1))
 184       write(ulsort,*) 'listar(2) = ', listar(2),
 185      >                   ' de ',somare(1,listar(2)),
 186      >                   ' a ',somare(2,listar(2))
 187       write(ulsort,*) 'listar(3) = ', listar(3),
 188      >                   ' de ',somare(1,listar(3)),
 189      >                   ' a ',somare(2,listar(3))
 190       write(ulsort,*) 'listar(4) = ', listar(4),
 191      >                   ' de ',somare(1,listar(4)),
 192      >                   ' a ',somare(2,listar(4))
 193       write(ulsort,*) 'listar(9) = ', listar(9),
 194      >                   ' de ',somare(1,listar(9)),
 195      >                   ' a ',somare(2,listar(9))
 196       write(ulsort,*) 'listar(11) = ', listar(11),
 197      >                   ' de ',somare(1,listar(11)),
 198      >                   ' a ',somare(2,listar(11))
 199 #endif
 200 c
 201       if ( codret.eq.0 ) then
 202 c
 203 c 3.1. ==> C'est l'arete 1 qui est coupee
 204 c
 205       if ( mod(hetare(listar(1)),10).eq.2 ) then
 206         etahex = 11
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,texte(langue,3)) 'CMCH61', nompro
 209 #endif
 210         call cmch61 ( lehexa, listar, listso,
 211      >                indare, indtri, indpyr,
 212      >                indptp,
 213      >                hetare, somare,
 214      >                filare, merare, famare,
 215      >                hettri, aretri,
 216      >                filtri, pertri, famtri,
 217      >                nivtri,
 218      >                filqua,
 219      >                hetpyr, facpyr, cofapy,
 220      >                filpyr, perpyr, fampyr,
 221      >                quahex, coquhe,
 222      >                famhex, cfahex,
 223      >                ulsort, langue, codret )
 224 c
 225 c 3.2. ==> C'est l'arete 2 qui est coupee
 226 c
 227       elseif ( mod(hetare(listar(2)),10).eq.2 ) then
 228         etahex = 12
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,3)) 'CMCH62', nompro
 231 #endif
 232         call cmch62 ( lehexa, listar, listso,
 233      >                indare, indtri, indpyr,
 234      >                indptp,
 235      >                hetare, somare,
 236      >                filare, merare, famare,
 237      >                hettri, aretri,
 238      >                filtri, pertri, famtri,
 239      >                nivtri,
 240      >                filqua,
 241      >                hetpyr, facpyr, cofapy,
 242      >                filpyr, perpyr, fampyr,
 243      >                quahex, coquhe,
 244      >                famhex, cfahex,
 245      >                ulsort, langue, codret )
 246 c
 247 c 3.3. ==> C'est l'arete 3 qui est coupee
 248 c
 249       elseif ( mod(hetare(listar(3)),10).eq.2 ) then
 250         etahex = 13
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,3)) 'CMCH63', nompro
 253 #endif
 254         call cmch63 ( lehexa, listar, listso,
 255      >                indare, indtri, indpyr,
 256      >                indptp,
 257      >                hetare, somare,
 258      >                filare, merare, famare,
 259      >                hettri, aretri,
 260      >                filtri, pertri, famtri,
 261      >                nivtri,
 262      >                filqua,
 263      >                hetpyr, facpyr, cofapy,
 264      >                filpyr, perpyr, fampyr,
 265      >                quahex, coquhe,
 266      >                famhex, cfahex,
 267      >                ulsort, langue, codret )
 268 c
 269 c 3.4. ==> C'est l'arete 4 qui est coupee
 270 c
 271       elseif ( mod(hetare(listar(4)),10).eq.2 ) then
 272         etahex = 14
 273 #ifdef _DEBUG_HOMARD_
 274       write (ulsort,texte(langue,3)) 'CMCH64', nompro
 275 #endif
 276         call cmch64 ( lehexa, listar, listso,
 277      >                indare, indtri, indpyr,
 278      >                indptp,
 279      >                hetare, somare,
 280      >                filare, merare, famare,
 281      >                hettri, aretri,
 282      >                filtri, pertri, famtri,
 283      >                nivtri,
 284      >                filqua,
 285      >                hetpyr, facpyr, cofapy,
 286      >                filpyr, perpyr, fampyr,
 287      >                quahex, coquhe,
 288      >                famhex, cfahex,
 289      >                ulsort, langue, codret )
 290 c
 291 c 3.5. ==> C'est l'arete 5 qui est coupee
 292 c
 293       elseif ( mod(hetare(listar(5)),10).eq.2 ) then
 294         etahex = 15
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,3)) 'CMCH65', nompro
 297 #endif
 298         call cmch65 ( lehexa, listar, listso,
 299      >                indare, indtri, indpyr,
 300      >                indptp,
 301      >                hetare, somare,
 302      >                filare, merare, famare,
 303      >                hettri, aretri,
 304      >                filtri, pertri, famtri,
 305      >                nivtri,
 306      >                filqua,
 307      >                hetpyr, facpyr, cofapy,
 308      >                filpyr, perpyr, fampyr,
 309      >                quahex, coquhe,
 310      >                famhex, cfahex,
 311      >                ulsort, langue, codret )
 312 c
 313 c 3.6. ==> C'est l'arete 6 qui est coupee
 314 c
 315       elseif ( mod(hetare(listar(6)),10).eq.2 ) then
 316         etahex = 16
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,texte(langue,3)) 'CMCH66', nompro
 319 #endif
 320         call cmch66 ( lehexa, listar, listso,
 321      >                indare, indtri, indpyr,
 322      >                indptp,
 323      >                hetare, somare,
 324      >                filare, merare, famare,
 325      >                hettri, aretri,
 326      >                filtri, pertri, famtri,
 327      >                nivtri,
 328      >                filqua,
 329      >                hetpyr, facpyr, cofapy,
 330      >                filpyr, perpyr, fampyr,
 331      >                quahex, coquhe,
 332      >                famhex, cfahex,
 333      >                ulsort, langue, codret )
 334 c
 335 c 3.7. ==> C'est l'arete 7 qui est coupee
 336 c
 337       elseif ( mod(hetare(listar(7)),10).eq.2 ) then
 338         etahex = 17
 339 #ifdef _DEBUG_HOMARD_
 340       write (ulsort,texte(langue,3)) 'CMCH67', nompro
 341 #endif
 342         call cmch67 ( lehexa, listar, listso,
 343      >                indare, indtri, indpyr,
 344      >                indptp,
 345      >                hetare, somare,
 346      >                filare, merare, famare,
 347      >                hettri, aretri,
 348      >                filtri, pertri, famtri,
 349      >                nivtri,
 350      >                filqua,
 351      >                hetpyr, facpyr, cofapy,
 352      >                filpyr, perpyr, fampyr,
 353      >                quahex, coquhe,
 354      >                famhex, cfahex,
 355      >                ulsort, langue, codret )
 356 c
 357 c 3.8. ==> C'est l'arete 8 qui est coupee
 358 c
 359       elseif ( mod(hetare(listar(8)),10).eq.2 ) then
 360         etahex = 18
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,texte(langue,3)) 'CMCH68', nompro
 363 #endif
 364         call cmch68 ( lehexa, listar, listso,
 365      >                indare, indtri, indpyr,
 366      >                indptp,
 367      >                hetare, somare,
 368      >                filare, merare, famare,
 369      >                hettri, aretri,
 370      >                filtri, pertri, famtri,
 371      >                nivtri,
 372      >                filqua,
 373      >                hetpyr, facpyr, cofapy,
 374      >                filpyr, perpyr, fampyr,
 375      >                quahex, coquhe,
 376      >                famhex, cfahex,
 377      >                ulsort, langue, codret )
 378 c
 379 c 3.9. ==> C'est l'arete 9 qui est coupee
 380 c
 381       elseif ( mod(hetare(listar(9)),10).eq.2 ) then
 382         etahex = 19
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,3)) 'CMCH69', nompro
 385 #endif
 386         call cmch69 ( lehexa, listar, listso,
 387      >                indare, indtri, indpyr,
 388      >                indptp,
 389      >                hetare, somare,
 390      >                filare, merare, famare,
 391      >                hettri, aretri,
 392      >                filtri, pertri, famtri,
 393      >                nivtri,
 394      >                filqua,
 395      >                hetpyr, facpyr, cofapy,
 396      >                filpyr, perpyr, fampyr,
 397      >                quahex, coquhe,
 398      >                famhex, cfahex,
 399      >                ulsort, langue, codret )
 400 c
 401 c 3.10. ==> C'est l'arete 10 qui est coupee
 402 c
 403       elseif ( mod(hetare(listar(10)),10).eq.2 ) then
 404         etahex = 20
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,texte(langue,3)) 'CMCH70', nompro
 407 #endif
 408         call cmch70 ( lehexa, listar, listso,
 409      >                indare, indtri, indpyr,
 410      >                indptp,
 411      >                hetare, somare,
 412      >                filare, merare, famare,
 413      >                hettri, aretri,
 414      >                filtri, pertri, famtri,
 415      >                nivtri,
 416      >                filqua,
 417      >                hetpyr, facpyr, cofapy,
 418      >                filpyr, perpyr, fampyr,
 419      >                quahex, coquhe,
 420      >                famhex, cfahex,
 421      >                ulsort, langue, codret )
 422 c
 423 c 3.11. ==> C'est l'arete 11 qui est coupee
 424 c
 425       elseif ( mod(hetare(listar(11)),10).eq.2 ) then
 426         etahex = 21
 427 #ifdef _DEBUG_HOMARD_
 428       write (ulsort,texte(langue,3)) 'CMCH71', nompro
 429 #endif
 430         call cmch71 ( lehexa, listar, listso,
 431      >                indare, indtri, indpyr,
 432      >                indptp,
 433      >                hetare, somare,
 434      >                filare, merare, famare,
 435      >                hettri, aretri,
 436      >                filtri, pertri, famtri,
 437      >                nivtri,
 438      >                filqua,
 439      >                hetpyr, facpyr, cofapy,
 440      >                filpyr, perpyr, fampyr,
 441      >                quahex, coquhe,
 442      >                famhex, cfahex,
 443      >                ulsort, langue, codret )
 444 c
 445 c 3.12. ==> C'est l'arete 12 qui est coupee
 446 c
 447       elseif ( mod(hetare(listar(12)),10).eq.2 ) then
 448         etahex = 22
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,texte(langue,3)) 'CMCH72', nompro
 451 #endif
 452         call cmch72 ( lehexa, listar, listso,
 453      >                indare, indtri, indpyr,
 454      >                indptp,
 455      >                hetare, somare,
 456      >                filare, merare, famare,
 457      >                hettri, aretri,
 458      >                filtri, pertri, famtri,
 459      >                nivtri,
 460      >                filqua,
 461      >                hetpyr, facpyr, cofapy,
 462      >                filpyr, perpyr, fampyr,
 463      >                quahex, coquhe,
 464      >                famhex, cfahex,
 465      >                ulsort, langue, codret )
 466 c
 467 c 3.13. ==> Laquelle ?
 468 c
 469       else
 470         codret = 1
 471       endif
 472 c
 473       endif
 474 c
 475 c====
 476 c 4. la fin
 477 c====
 478 c
 479       if ( codret.ne.0 ) then
 480 c
 481 #include "envex2.h"
 482 c
 483       write (ulsort,texte(langue,1)) 'Sortie', nompro
 484       write (ulsort,texte(langue,2)) codret
 485       write (ulsort,texte(langue,4))
 486 c
 487       endif
 488 c
 489 #ifdef _DEBUG_HOMARD_
 490       write (ulsort,texte(langue,1)) 'Sortie', nompro
 491       call dmflsh (iaux)
 492 #endif
 493 c
 494       end