src/tool/Creation_Maillage/cmcp25.F

   1       subroutine cmcp25 ( lepent, listar,
   2      >                    indare, indtri, indtet,
   3      >                    indptp,
   4      >                    hetare, somare,
   5      >                    filare, merare, famare,
   6      >                    hettri, aretri,
   7      >                    filtri, pertri, famtri,
   8      >                    nivtri,
   9      >                    filqua,
  10      >                    hettet, tritet, cotrte,
  11      >                    filtet, pertet, famtet,
  12      >                    facpen, cofape,
  13      >                    fampen, cfapen,
  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 Pentaedres
  36 c    -           -          -                          -
  37 c                         - etat 25 - par les aretes 5 et 9
  38 c                                --
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . lepent . e   .   1    . pentaedre a decouper                       .
  44 c . listar . e   .   9   . liste des aretes du pentaedre a decouper    .
  45 c . indare . es  .   1    . indice de la derniere arete creee          .
  46 c . indtri . es  .   1    . indice du dernier triangle cree            .
  47 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  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 . filqua . e   . nouvqu . premier fils des quadrangles               .
  61 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  62 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  63 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  64 c . filtet . es  . nouvte . premier fils des tetraedres                .
  65 c . pertet . es  . nouvte . pere des tetraedres                        .
  66 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  67 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  68 c . famtet . es  . nouvte . famille des tetraedres                     .
  69 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  70 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  71 c . fampen . e   . nouvpe . famille des penaedres                      .
  72 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  73 c .        .     . nbfpen .   1 : famille MED                          .
  74 c .        .     .        .   2 : type de pentaedres                   .
  75 c .        .     .        .   3 : famille des tetraedres de conformite .
  76 c .        .     .        .   4 : famille des pyramides de conformite  .
  77 c .        .     .        .   3 : famille des tetraedres de conformite .
  78 c .        .     .        .   4 : famille des pyramides de conformite  .
  79 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  80 c . langue . e   .    1   . langue des messages                        .
  81 c .        .     .        . 1 : francais, 2 : anglais                  .
  82 c . codret . es  .    1   . code de retour des modules                 .
  83 c .        .     .        . 0 : pas de probleme                        .
  84 c .        .     .        . 1 : aucune face ne correspond              .
  85 c ______________________________________________________________________
  86 c
  87 c====
  88 c 0. declarations et dimensionnement
  89 c====
  90 c
  91 c 0.1. ==> generalites
  92 c
  93       implicit none
  94       save
  95 c
  96       character*6 nompro
  97       parameter ( nompro = 'CMCP25' )
  98 c
  99 #include "nblang.h"
 100 c
 101 c 0.2. ==> communs
 102 c
 103 #include "envex1.h"
 104 c
 105 #include "dicfen.h"
 106 #include "nbfami.h"
 107 #include "nouvnb.h"
 108 #include "ope001.h"
 109 #include "i1i2i3.h"
 110 c
 111 c 0.3. ==> arguments
 112 c
 113       integer lepent
 114       integer listar(9)
 115       integer indare, indtri, indtet
 116       integer indptp
 117       integer hetare(nouvar), somare(2,nouvar)
 118       integer filare(nouvar), merare(nouvar), famare(nouvar)
 119       integer hettri(nouvtr), aretri(nouvtr,3)
 120       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 121       integer nivtri(nouvtr)
 122       integer filqua(nouvqu)
 123       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 124       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 125       integer facpen(nouvpf,5), cofape(nouvpf,5)
 126       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 127 c
 128       integer ulsort, langue, codret
 129 c
 130 c 0.4. ==> variables locales
 131 c
 132       integer iaux, jaux
 133       integer f1, cf1
 134 #ifdef _DEBUG_HOMARD_
 135       integer f2, cf2
 136       integer f3, cf3
 137       integer f4, cf4
 138       integer f5, cf5
 139 #endif
 140       integer noemil(2), lesare(1)
 141       integer areint(1)
 142       integer triint(6)
 143       integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
 144       integer nulofa(4)
 145       integer niveau
 146       integer coface
 147 c
 148       integer nbmess
 149       parameter ( nbmess = 10 )
 150       character*80 texte(nblang,nbmess)
 151 c
 152 c 0.5. ==> initialisations
 153 c ______________________________________________________________________
 154 c
 155 c====
 156 c 1. messages
 157 c====
 158 c
 159 #include "impr01.h"
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162       write (ulsort,texte(langue,1)) 'Entree', nompro
 163       call dmflsh (iaux)
 164 #endif
 165 c
 166 #include "impr03.h"
 167 #include "impr04.h"
 168 c
 169       codret = 0
 170 c
 171 c====
 172 c 2. initialisations
 173 c====
 174 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 175 c          les faces du pentaedre et leurs codes
 176 c
 177       f1 = facpen(lepent,1)
 178       cf1 = cofape(lepent,1)
 179 #ifdef _DEBUG_HOMARD_
 180       f2 = facpen(lepent,2)
 181       cf2 = cofape(lepent,2)
 182       f3 = facpen(lepent,3)
 183       cf3 = cofape(lepent,3)
 184       f4 = facpen(lepent,4)
 185       cf4 = cofape(lepent,4)
 186       f5 = facpen(lepent,5)
 187       cf5 = cofape(lepent,5)
 188       write(ulsort,90002) 'f1', f1, cf1
 189       write(ulsort,90002) 'f2', f2, cf2
 190       write(ulsort,90002) 'f3', f3, cf3
 191       write(ulsort,90002) 'f4', f4, cf4
 192       write(ulsort,90002) 'f5', f5, cf5
 193 #endif
 194 c
 195 c 2.2. ==> grandeurs dependant du cas traite
 196 c     iaux = numero local de l'arete coupee
 197 c     jaux = numero global de l'arete coupee
 198 c     noemil = noeud milieu de l'arete coupee
 199 c
 200       iaux = 5
 201       jaux = listar(iaux)
 202       noemil(1) = somare(2,filare(jaux))
 203 c
 204       iaux = 9
 205       jaux = listar(iaux)
 206       noemil(2) = somare(2,filare(jaux))
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write(ulsort,90002) 'noemil', noemil
 210 #endif
 211 c
 212 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 213 c
 214 c     trifad(1,0) = triangle central de la face 1 : FF4
 215 c     trifad(1,1) = triangle de la face 1 du cote de S6 : FF4 + 1/2
 216 c     trifad(1,2) = triangle de la face 1 du cote de S4 : FF4 + 2/1
 217 c     areqtr(1,1) : AS1N5
 218 c     areqtr(1,2) : AS2N5
 219 c
 220 c     trifad(2,0) = triangle central de la face 2 : FF3
 221 c     trifad(2,1) = triangle de la face 2 du cote de F2 : FF3 + 1/2
 222 c     trifad(2,2) = triangle de la face 2 du cote de F1 : FF3 + 2/1
 223 c     areqtr(2,1) : AS4N9
 224 c     areqtr(2,2) : AS1N9
 225 c
 226 c     trifad(3,0) = triangle central de la face 3 : FF5
 227 c     trifad(3,1) = triangle de la face 3 du cote de F2 : FF5 + 1/2
 228 c     trifad(3,2) = triangle de la face 3 du cote de F1 : FF5 + 2/1
 229 c     areqtr(3,1) : AS5N9
 230 c     areqtr(3,2) : AS2N9
 231 c
 232 c     trifad(4,0) = triangle 1 de la face 4 : FF2 + 0/1 (FF2D4)
 233 c     trifad(4,1) = triangle 2 de la face 4 : FF2 + 1/0 (FF2D6)
 234 c     areqtr(4,1) : AS6N5
 235 c
 236 c     areqtr(1,0) : AS4N5
 237 c     areqtr(2,0) : AS5N5
 238 c     areqtr(3,0) : AS6N9
 239 c
 240       if ( codret.eq.0 ) then
 241 c
 242       nulofa(1) = 4
 243       nulofa(2) = 3
 244       nulofa(3) = 5
 245       nulofa(4) = 2
 246 c
 247       iaux = 6
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,3)) 'CMCP2B', nompro
 251 #endif
 252       call cmcp2b ( nulofa, lepent,
 253      >              i3, i1, i2, iaux,
 254      >              aretri, nivtri, filtri,
 255      >              filqua,
 256      >              facpen, cofape,
 257      >              niveau,
 258      >              trifad, cotrvo, areqtr,
 259      >              ulsort, langue, codret )
 260 c
 261       endif
 262 c
 263 c====
 264 c 3. Creation du noeud interne
 265 c====
 266 c====
 267 c 4. Creation de l'arete interne
 268 c    noemil(1) : N5
 269 c    noemil(2) : N9
 270 c    areint(1) : AN5N9
 271 c====
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,91000) indare+1, indare+1
 274 #endif
 275 c
 276       if ( codret.eq.0 ) then
 277 c
 278       indare = indare + 1
 279       areint(1) = indare
 280 c
 281       somare(1,areint(1)) = min ( noemil(1) , noemil(2) )
 282       somare(2,areint(1)) = max ( noemil(1) , noemil(2) )
 283 c
 284       famare(areint(1)) = 1
 285       hetare(areint(1)) = 50
 286       merare(areint(1)) = 0
 287       filare(areint(1)) = 0
 288 #ifdef _DEBUG_HOMARD_
 289       write(ulsort,90006) 'areint(1) = ', areint(1),
 290      >                   ' de ',somare(1,areint(1)),
 291      >                   ' a ',somare(2,areint(1))
 292 #endif
 293 c
 294       endif
 295 c====
 296 c 5. Creation des six triangles internes
 297 c    triint(1) : FA2
 298 c    triint(2) : FS1
 299 c    triint(3) : FS2
 300 c    triint(4) : FS4
 301 c    triint(5) : FS5
 302 c    triint(6) : FS6
 303 c====
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,92000) indtri+1, indtri+6
 307 #endif
 308 c
 309       if ( codret.eq.0 ) then
 310 c
 311       lesare(1) = listar(2)
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,3)) 'CMCP2C', nompro
 315 #endif
 316       call cmcp2c ( indtri, triint,
 317      >              lesare,
 318      >              areint, areqtr, niveau,
 319      >              aretri, famtri, hettri,
 320      >              filtri, pertri, nivtri,
 321      >              ulsort, langue, codret )
 322 c
 323       endif
 324 c
 325 c====
 326 c 6. Creation de la pyramide
 327 c====
 328 c
 329 c====
 330 c 7. Creation des 6 tetraedres
 331 c====
 332 c
 333 #ifdef _DEBUG_HOMARD_
 334       write (ulsort,93000) indtet+1, indtet+6
 335 #endif
 336 c
 337       if ( codret.eq.0 ) then
 338 c
 339       coface = per001(4,cf1)
 340 c
 341 #ifdef _DEBUG_HOMARD_
 342       write (ulsort,texte(langue,3)) 'CMCP2E', nompro
 343 #endif
 344       call cmcp2e ( indtet, indptp,
 345      >              lepent,
 346      >              trifad, cotrvo, triint,
 347      >              f1, coface,
 348      >              hettet, tritet, cotrte,
 349      >              filtet, pertet, famtet,
 350      >              fampen, cfapen,
 351      >              ulsort, langue, codret )
 352 c
 353 #ifdef _DEBUG_HOMARD_
 354       do 700 , iaux = indtet-5 , indtet
 355         write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4)
 356         write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4)
 357   700 continue
 358 #endif
 359 c
 360       endif
 361 c
 362 c====
 363 c 8. la fin
 364 c====
 365 c
 366       if ( codret.ne.0 ) then
 367 c
 368 #include "envex2.h"
 369 c
 370       write (ulsort,texte(langue,1)) 'Sortie', nompro
 371       write (ulsort,texte(langue,2)) codret
 372 c
 373       endif
 374 c
 375 #ifdef _DEBUG_HOMARD_
 376       write (ulsort,texte(langue,1)) 'Sortie', nompro
 377       call dmflsh (iaux)
 378 #endif
 379 c
 380       end