src/tool/Creation_Maillage/cmch40.F

   1       subroutine cmch40 ( lehexa, nulofa, tabaux,
   2      >                    somm, arext1, arext2, arext3, arext4,
   3      >                    indare, indtri, indtet, indpyr, 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      >                    trigpy, facnde, cofnde,
  17      >                    ulsort, langue, codret )
  18 c ______________________________________________________________________
  19 c
  20 c                             H O M A R D
  21 c
  22 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  23 c
  24 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  25 c aupres des huissiers de justice Simart et Lavoir a Clamart
  26 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  27 c aupres des huissiers de justice
  28 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  29 c
  30 c    HOMARD est une marque deposee d'Electricite de France
  31 c
  32 c Copyright EDF 1996
  33 c Copyright EDF 1998
  34 c Copyright EDF 2002
  35 c Copyright EDF 2020
  36 c ______________________________________________________________________
  37 c
  38 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  39 c    -           -          -                          -
  40 c                         - par 1 Face - etat 4x
  41 c                                 -           -
  42 c ______________________________________________________________________
  43 c .        .     .        .                                            .
  44 c .  nom   . e/s . taille .           description                      .
  45 c .____________________________________________________________________.
  46 c . lehexa . e   .   1    . hexaedre a decouper                        .
  47 c . nulofa . e   .   1    . numero local de la face couppe en 4        .
  48 c . tabaux . e   .    4   . numeros locaux des faces coupees en 3,     .
  49 c .        .     .        . dans l'ordre des pyramides p/p1+1          .
  50 c . somm   . e   .   1    . sommets de la face non decoupee            .
  51 c . arexti . e   .   1    . aretes de la face non decoupee             .
  52 c . indare . es  .   1    . indice de la derniere arete creee          .
  53 c . indtri . es  .   1    . indice du dernier triangle cree            .
  54 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  55 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  56 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  57 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  58 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  59 c . filare . es  . nouvar . premiere fille des aretes                  .
  60 c . merare . es  . nouvar . mere des aretes                            .
  61 c . famare .     . nouvar . famille des aretes                         .
  62 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  63 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  64 c . filtri . es  . nouvtr . premier fils des triangles                 .
  65 c . pertri . es  . nouvtr . pere des triangles                         .
  66 c . famtri . es  . nouvtr . famille des triangles                      .
  67 c . nivtri . es  . nouvtr . niveau des triangles                       .
  68 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  69 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  70 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  71 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  72 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  73 c . filtet . es  . nouvte . premier fils des tetraedres                .
  74 c . pertet . es  . nouvte . pere des tetraedres                        .
  75 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  76 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  77 c . famtet . es  . nouvte . famille des tetraedres                     .
  78 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  79 c . facpyr . e   .nouvyf*5. numeros des 5 faces des pyramides          .
  80 c . cofapy . e   .nouvyf*5. codes des faces des pyramides              .
  81 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  82 c . perpyr . e   . nouvpy . pere des pyramides                         .
  83 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  84 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  85 c . fampyr . e   . nouvpy . famille des pyramides                      .
  86 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  87 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  88 c . famhex . e   . nouvhe . famille des hexaedres                      .
  89 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  90 c .        .     . nbfhex .   1 : famille MED                          .
  91 c .        .     .        .   2 : type d'hexaedres                     .
  92 c .        .     .        .   3 : famille des tetraedres de conformite .
  93 c .        .     .        .   4 : famille des pyramides de conformite  .
  94 c . trigpy .  s  .   4    . triangle de la grande pyramide             .
  95 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  96 c . langue . e   .    1   . langue des messages                        .
  97 c .        .     .        . 1 : francais, 2 : anglais                  .
  98 c . codret . es  .    1   . code de retour des modules                 .
  99 c .        .     .        . 0 : pas de probleme                        .
 100 c .        .     .        . 1 : aucune face ne correspond              .
 101 c ______________________________________________________________________
 102 c
 103 c====
 104 c 0. declarations et dimensionnement
 105 c====
 106 c
 107 c 0.1. ==> generalites
 108 c
 109       implicit none
 110       save
 111 c
 112       character*6 nompro
 113       parameter ( nompro = 'CMCH40' )
 114 c
 115 #include "nblang.h"
 116 c
 117 c 0.2. ==> communs
 118 c
 119 #include "envex1.h"
 120 c
 121 #include "dicfen.h"
 122 #include "nbfami.h"
 123 #include "nouvnb.h"
 124 #include "cofpfh.h"
 125 #include "coftfh.h"
 126 c
 127 c 0.3. ==> arguments
 128 c
 129       integer lehexa, nulofa, tabaux(4)
 130       integer somm(4)
 131       integer arext1, arext2, arext3, arext4
 132       integer indare, indtri, indtet, indpyr, indptp
 133       integer hetare(nouvar), somare(2,nouvar)
 134       integer filare(nouvar), merare(nouvar), famare(nouvar)
 135       integer hettri(nouvtr), aretri(nouvtr,3)
 136       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 137       integer nivtri(nouvtr)
 138       integer arequa(nouvqu,4), filqua(nouvqu)
 139       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 140       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 141       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 142       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 143       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 144       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 145       integer trigpy(4)
 146       integer facnde, cofnde
 147 c
 148       integer ulsort, langue, codret
 149 c
 150 c 0.4. ==> variables locales
 151 c
 152       integer iaux
 153 #ifdef _DEBUG_HOMARD_
 154       integer jaux
 155 #endif
 156       integer noefac
 157       integer areint(4)
 158       integer facdec, cofdec
 159       integer quabas(4)
 160       integer arefad(4), areqtr(4,2)
 161       integer trifad(4,0:2), cotrvo(4,0:2)
 162       integer triint(4,2)
 163       integer niveau
 164 c
 165       integer nbmess
 166       parameter ( nbmess = 10 )
 167       character*80 texte(nblang,nbmess)
 168 c
 169 c 0.5. ==> initialisations
 170 c ______________________________________________________________________
 171 c
 172 c====
 173 c 1. messages
 174 c====
 175 c
 176 #include "impr01.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,1)) 'Entree', nompro
 180       call dmflsh (iaux)
 181 #endif
 182 #ifdef _DEBUG_HOMARD_
 183  1789 format(5(a,i5,', '))
 184 #endif
 185 c
 186       codret = 0
 187 c
 188 c====
 189 c 2. initialisations
 190 c====
 191 c
 192 #ifdef _DEBUG_HOMARD_
 193       write (ulsort,texte(langue,3)) 'CMCHFA', nompro
 194 #endif
 195       call cmchfa ( facdec, cofdec, facnde, cofnde,
 196      >              niveau, noefac,
 197      >              quabas, arefad,
 198      >              trifad, cotrvo, areqtr,
 199      >              lehexa, nulofa,
 200      >              somare, aretri, nivtri,
 201      >              arequa, filqua,
 202      >              quahex, coquhe,
 203      >              tabaux,
 204      >              ulsort, langue, codret )
 205 c
 206 c====
 207 c 3. Creation des quatres aretes internes
 208 c    areint(p) relie le sommet somm(p) (de la pyramide fille p)
 209 c    au centre de la face coupee
 210 c====
 211 c
 212       if ( codret.eq.0 ) then
 213 c
 214       do 31 , iaux = 1 , 4
 215 c
 216         indare = indare + 1
 217         areint(iaux) = indare
 218 c
 219         somare(1,areint(iaux)) = min ( noefac , somm(iaux) )
 220         somare(2,areint(iaux)) = max ( noefac , somm(iaux) )
 221 c
 222         famare(areint(iaux)) = 1
 223         hetare(areint(iaux)) = 50
 224         merare(areint(iaux)) = 0
 225         filare(areint(iaux)) = 0
 226 #ifdef _DEBUG_HOMARD_
 227  3100   format('. Arete interne',i10,' de',i10,' a',i10)
 228         write(ulsort,3100) indare,
 229      >  somare(1,areint(iaux)), somare(2,areint(iaux))
 230 #endif
 231 c
 232    31 continue
 233 c
 234       endif
 235 c
 236 c====
 237 c 4. Creation des dix triangles internes
 238 c     par convention, le niveau est le meme que les quadrangles fils
 239 c     sur l'exterieur
 240 c====
 241 c
 242 c 4.1. ==> triangles s'appuyant sur la face decoupee
 243 c
 244       if ( codret.eq.0 ) then
 245 c
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,texte(langue,3)) 'CMCHFB', nompro
 248 cgn      write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+8
 249 #endif
 250       call cmchfb ( indtri, triint,
 251      >              hettri, aretri, nivtri,
 252      >              filtri, pertri, famtri,
 253      >              areint, arefad, areqtr, niveau,
 254      >              ulsort, langue, codret )
 255 c
 256       endif
 257 #ifdef _DEBUG_HOMARD_
 258       iaux = indtri-7
 259       write(ulsort,1789) 'TRIANGLE = ', iaux
 260       write(ulsort,1789) 'arete = ', aretri(iaux,1),
 261      >                   ' de ',somare(1,aretri(iaux,1)),
 262      >                   ' a ',somare(2,aretri(iaux,1))
 263       write(ulsort,1789) 'arete = ', aretri(iaux,2),
 264      >                   ' de ',somare(1,aretri(iaux,2)),
 265      >                   ' a ',somare(2,aretri(iaux,2))
 266       write(ulsort,1789) 'arete = ', aretri(iaux,3),
 267      >                   ' de ',somare(1,aretri(iaux,3)),
 268      >                   ' a ',somare(2,aretri(iaux,3))
 269 #endif
 270 c
 271 c 4.2. ==> triangles s'appuyant sur les aretes de la face non decoupee
 272 c          Ce sont ceux qui bordent la grande pyramide
 273 c
 274       if ( codret.eq.0 ) then
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'CMCHFC', nompro
 278 cgn      write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+4
 279 #endif
 280       call cmchfc ( indtri, trigpy,
 281      >              hettri, aretri, nivtri,
 282      >              filtri, pertri, famtri,
 283      >              areint, arext1, arext2, arext3, arext4,
 284      >              niveau,
 285      >              ulsort, langue, codret )
 286 c
 287       endif
 288 c
 289 c====
 290 c 5. Creation des 4 pyramides dans les coins
 291 c====
 292 c
 293       iaux = cfahex(cofpfh,famhex(lehexa))
 294 c
 295       if ( codret.eq.0 ) then
 296 c
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,3)) 'CMCHFD', nompro
 299 #endif
 300       call cmchfd ( indpyr,
 301      >              facpyr, cofapy, fampyr,
 302      >              hetpyr, filpyr, perpyr,
 303      >              trifad, cotrvo, triint, quabas, cofdec,
 304      >              indptp, iaux )
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       do 5333 , iaux = indpyr-3, indpyr
 308       write(ulsort,1792) iaux, (facpyr(iaux,jaux),jaux=1,5)
 309  5333 continue
 310  1792 format('pyramide ',i6,' : ',5i6)
 311 #endif
 312 c
 313       endif
 314 c
 315 c====
 316 c 6. Creation des tetraedres
 317 c====
 318 c
 319       iaux = cfahex(coftfh,famhex(lehexa))
 320 c
 321       if ( codret.eq.0 ) then
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324       write (ulsort,texte(langue,3)) 'CMCHFE', nompro
 325 #endif
 326       call cmchfe ( indtet, indptp,
 327      >              tritet, cotrte, famtet,
 328      >              hettet, filtet, pertet,
 329      >              trifad, cotrvo, triint, trigpy,
 330      >              iaux )
 331 c
 332 #ifdef _DEBUG_HOMARD_
 333       do 6333 , iaux = indtet-3, indtet
 334       write(ulsort,1793) iaux, (tritet(iaux,jaux),jaux=1,4)
 335  6333 continue
 336  1793 format('tetraedre ',i6,' : ',4i6)
 337 #endif
 338 c
 339       endif
 340 c
 341 c====
 342 c 7. la fin
 343 c====
 344 c
 345       if ( codret.ne.0 ) then
 346 c
 347 #include "envex2.h"
 348 c
 349       write (ulsort,texte(langue,1)) 'Sortie', nompro
 350       write (ulsort,texte(langue,2)) codret
 351 c
 352       endif
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355       write (ulsort,texte(langue,1)) 'Sortie', nompro
 356       call dmflsh (iaux)
 357 #endif
 358 c
 359       end