src/tool/Creation_Maillage/cmcp19.F

   1       subroutine cmcp19 ( lepent, listar,
   2      >                    indtri, indtet, indpyr,
   3      >                    indptp,
   4      >                    hettri, aretri,
   5      >                    filtri, pertri, famtri,
   6      >                    nivtri,
   7      >                    filqua,
   8      >                    hettet, tritet, cotrte,
   9      >                    filtet, pertet, famtet,
  10      >                    hetpyr, facpyr, cofapy,
  11      >                    filpyr, perpyr, fampyr,
  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 19 - par l'arete de quadrangle 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 . indtri . es  .   1    . indice du dernier triangle cree            .
  46 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  47 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  48 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  49 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  50 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  51 c . filtri . es  . nouvtr . premier fils des triangles                 .
  52 c . pertri . es  . nouvtr . pere des triangles                         .
  53 c . famtri . es  . nouvtr . famille des triangles                      .
  54 c . nivtri . es  . nouvtr . niveau des triangles                       .
  55 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  56 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  57 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  58 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  59 c . filtet . es  . nouvte . premier fils des tetraedres                .
  60 c . pertet . es  . nouvte . pere des tetraedres                        .
  61 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  62 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  63 c . famtet . es  . nouvte . famille des tetraedres                     .
  64 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  65 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  66 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  67 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  68 c . perpyr . es  . nouvpy . pere des pyramides                         .
  69 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  70 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  71 c . fampyr . es  . nouvpy . famille des pyramides                      .
  72 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  73 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  74 c . fampen . e   . nouvpe . famille des penaedres                      .
  75 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  76 c .        .     . nbfpen .   1 : famille MED                          .
  77 c .        .     .        .   2 : type de pentaedres                   .
  78 c .        .     .        .   3 : famille des tetraedres de conformite .
  79 c .        .     .        .   4 : famille des pyramides de conformite  .
  80 c .        .     .        .   3 : famille des tetraedres de conformite .
  81 c .        .     .        .   4 : famille des pyramides de conformite  .
  82 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  83 c . langue . e   .    1   . langue des messages                        .
  84 c .        .     .        . 1 : francais, 2 : anglais                  .
  85 c . codret . es  .    1   . code de retour des modules                 .
  86 c .        .     .        . 0 : pas de probleme                        .
  87 c .        .     .        . 1 : aucune face ne correspond              .
  88 c ______________________________________________________________________
  89 c
  90 c====
  91 c 0. declarations et dimensionnement
  92 c====
  93 c
  94 c 0.1. ==> generalites
  95 c
  96       implicit none
  97       save
  98 c
  99       character*6 nompro
 100       parameter ( nompro = 'CMCP19' )
 101 c
 102 #include "nblang.h"
 103 c
 104 c 0.2. ==> communs
 105 c
 106 #include "envex1.h"
 107 c
 108 #include "dicfen.h"
 109 #include "nbfami.h"
 110 #include "nouvnb.h"
 111 #include "ope001.h"
 112 #include "cofpfp.h"
 113 c
 114 c 0.3. ==> arguments
 115 c
 116       integer lepent
 117       integer listar(9)
 118       integer indtri, indtet, indpyr
 119       integer indptp
 120       integer hettri(nouvtr), aretri(nouvtr,3)
 121       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 122       integer nivtri(nouvtr)
 123       integer filqua(nouvqu)
 124       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 125       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 126       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 127       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 128       integer facpen(nouvpf,5), cofape(nouvpf,5)
 129       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 130 c
 131       integer ulsort, langue, codret
 132 c
 133 c 0.4. ==> variables locales
 134 c
 135       integer iaux, jaux
 136       integer f1, cf1
 137       integer f2, cf2
 138       integer f4, cf4
 139 #ifdef _DEBUG_HOMARD_
 140       integer f3, cf3
 141       integer f5, cf5
 142 #endif
 143       integer lesare(2)
 144       integer tab1(4), tab2(4)
 145       integer triint(2)
 146       integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2)
 147       integer nulofa(2)
 148       integer niveau
 149 c
 150       integer nbmess
 151       parameter ( nbmess = 10 )
 152       character*80 texte(nblang,nbmess)
 153 c
 154 c 0.5. ==> initialisations
 155 c ______________________________________________________________________
 156 c
 157 c====
 158 c 1. messages
 159 c====
 160 c
 161 #include "impr01.h"
 162 c
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,texte(langue,1)) 'Entree', nompro
 165       call dmflsh (iaux)
 166 #endif
 167 c
 168 #include "impr03.h"
 169 #include "impr04.h"
 170 c
 171       codret = 0
 172 c
 173 c====
 174 c 2. initialisations
 175 c====
 176 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 177 c          les faces du pentaedre et leurs codes
 178 c
 179       f1 = facpen(lepent,1)
 180       cf1 = cofape(lepent,1)
 181       f2 = facpen(lepent,2)
 182       cf2 = cofape(lepent,2)
 183       cf4 = cofape(lepent,4)
 184       f4 = facpen(lepent,4)
 185 #ifdef _DEBUG_HOMARD_
 186       f3 = facpen(lepent,3)
 187       cf3 = cofape(lepent,3)
 188       cf5 = cofape(lepent,5)
 189       f5 = facpen(lepent,5)
 190       write(ulsort,90002) 'f1', f1, cf1
 191       write(ulsort,90002) 'f2', f2, cf2
 192       write(ulsort,90002) 'f3', f3, cf3
 193       write(ulsort,90002) 'f4', f4, cf4
 194       write(ulsort,90002) 'f5', f5, cf5
 195 #endif
 196 c
 197 c 2.2. ==> Triangles et aretes tracees sur les quadrangles coupes
 198 c
 199 c     trifad(1,0) = triangle central de la face 1 : FF3
 200 c     trifad(1,1) = triangle de la face 1 du cote de F1 : FF4 + 1/2
 201 c     trifad(1,2) = triangle de la face 1 du cote de F2 : FF4 + 2/1
 202 c     areqtr(1,1) : AS1N9
 203 c     areqtr(1,2) : AS4N9
 204 c
 205 c     trifad(2,0) = triangle central de la face 1 : FF5
 206 c     trifad(2,1) = triangle de la face 1 du cote de F1 : FF3 + 1/2
 207 c     trifad(2,2) = triangle de la face 1 du cote de F2 : FF3 + 2/1
 208 c     areqtr(2,1) : AS2N9
 209 c     areqtr(2,2) : AS5N9
 210 c
 211       if ( codret.eq.0 ) then
 212 c
 213       nulofa(1) = 3
 214       nulofa(2) = 5
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,3)) 'CMCP1B', nompro
 218 #endif
 219       call cmcp1b ( nulofa, lepent,
 220      >              aretri, nivtri,
 221      >              filqua,
 222      >              facpen, cofape,
 223      >              niveau,
 224      >              trifad, cotrvo, areqtr,
 225      >              ulsort, langue, codret )
 226 c
 227       endif
 228 c
 229 c====
 230 c 3. Creation du noeud interne
 231 c====
 232 c====
 233 c 4. Creation de l'arete interne
 234 c====
 235 c====
 236 c 5. Creation des deux triangles internes
 237 c    triint(1) : le triangle interne du cote de F1
 238 c    triint(2) : le triangle interne du cote de F2
 239 c    triint(1) : FA2N9
 240 c    triint(2) : FA5N9
 241 c====
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,92000) indtri+1, indtri+2
 245 #endif
 246 c
 247       if ( codret.eq.0 ) then
 248 c
 249       lesare(1) = listar(2)
 250       lesare(2) = listar(5)
 251 c
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,texte(langue,3)) 'CMCP1C', nompro
 254 #endif
 255       call cmcp1c ( indtri, triint,
 256      >              lesare,
 257      >              areqtr, niveau,
 258      >              aretri, famtri, hettri,
 259      >              filtri, pertri, nivtri,
 260      >              ulsort, langue, codret )
 261 c
 262       endif
 263 c
 264 c====
 265 c 6. Creation de la pyramide
 266 c====
 267 c
 268 #ifdef _DEBUG_HOMARD_
 269       write (ulsort,95000) indpyr+1, indpyr+1
 270 #endif
 271 c
 272       iaux = -indptp
 273       jaux = cfapen(cofpfp,fampen(lepent))
 274 c
 275       indpyr = indpyr + 1
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'CMCPYR', nompro
 278 #endif
 279       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 280      >                triint(1),           1,
 281      >              trifad(1,0), cotrvo(1,0),
 282      >                triint(2),           1,
 283      >              trifad(2,0), cotrvo(2,0),
 284      >                       f4,         cf4,
 285      >              iaux,  jaux,   indpyr )
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       do 600 , iaux = indpyr , indpyr
 289         write (ulsort,90015) 'Pyra', iaux,
 290      >                ', faces', (facpyr(iaux,jaux),jaux=1,5)
 291         write (ulsort,90015) 'Pyra', iaux,
 292      >                ', codes', (cofapy(iaux,jaux),jaux=1,5)
 293   600 continue
 294 #endif
 295 c
 296 c====
 297 c 7. Creation des 2 tetraedres
 298 c====
 299 c
 300 #ifdef _DEBUG_HOMARD_
 301       write (ulsort,93000) indtet+1, indtet+2
 302 #endif
 303 c
 304       if ( codret.eq.0 ) then
 305 c
 306       tab1(1) = f1
 307       tab2(1) = per001(4,cf1)
 308 c
 309       tab1(2) = f2
 310       tab2(2) = per001(6,cf2)
 311 c
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,3)) 'CMCP1E', nompro
 314 #endif
 315       call cmcp1e ( indtet, indptp,
 316      >              lepent,
 317      >              trifad, cotrvo, triint,
 318      >              tab1, tab2,
 319      >              hettet, tritet, cotrte,
 320      >              filtet, pertet, famtet,
 321      >              fampen, cfapen,
 322      >              ulsort, langue, codret )
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       do 700 , iaux = indtet-1 , indtet
 326         write (ulsort,90015) 'Tetra', iaux,
 327      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 328         write (ulsort,90015) 'Tetra', iaux,
 329      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 330   700 continue
 331 #endif
 332 c
 333       endif
 334 c
 335 c====
 336 c 8. la fin
 337 c====
 338 c
 339       if ( codret.ne.0 ) then
 340 c
 341 #include "envex2.h"
 342 c
 343       write (ulsort,texte(langue,1)) 'Sortie', nompro
 344       write (ulsort,texte(langue,2)) codret
 345 c
 346       endif
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,1)) 'Sortie', nompro
 350       call dmflsh (iaux)
 351 #endif
 352 c
 353       end