src/tool/Creation_Maillage/cmcp2a.F

   1       subroutine cmcp2a( lepent, etapen,
   2      >                    indare, indtri, indtet,
   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      >                    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                         - cas 2, phase A, pilotage
  38 c                               -        -
  39 c                         - par 2 aretes de tri/quadrangle
  40 c ______________________________________________________________________
  41 c .        .     .        .                                            .
  42 c .  nom   . e/s . taille .           description                      .
  43 c .____________________________________________________________________.
  44 c . lepent . e   .   1    . pentaedre a decouper                       .
  45 c . etapen .  s  .    1   . etat final du pentaedre                    .
  46 c . indare . es  .   1    . indice de la derniere arete creee          .
  47 c . indtri . es  .   1    . indice du dernier triangle cree            .
  48 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  49 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  50 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  51 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  52 c . filare . es  . nouvar . premiere fille des aretes                  .
  53 c . merare . es  . nouvar . mere des aretes                            .
  54 c . famare .     . nouvar . famille des aretes                         .
  55 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  56 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  57 c . filtri . es  . nouvtr . premier fils des triangles                 .
  58 c . pertri . es  . nouvtr . pere des triangles                         .
  59 c . famtri . es  . nouvtr . famille des triangles                      .
  60 c . nivtri . es  . nouvtr . niveau des triangles                       .
  61 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  62 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  63 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  64 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  65 c . cotrte . es  .nouvtf*4. code des 4 triangles des tetraedres        .
  66 c . filtet . es  . nouvte . premier fils des tetraedres                .
  67 c . pertet . es  . nouvte . pere des tetraedres                        .
  68 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  69 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  70 c . famtet . es  . nouvte . famille des tetraedres                     .
  71 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  72 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  73 c . fampen . e   . nouvpe . famille des penaedres                      .
  74 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  75 c .        .     . nbfpen .   1 : famille MED                          .
  76 c .        .     .        .   2 : type de pentaedres                   .
  77 c .        .     .        .   3 : famille des tetraedres de conformite .
  78 c .        .     .        .   4 : famille des pyramides de conformite  .
  79 c .        .     .        .   3 : famille des tetraedres de conformite .
  80 c .        .     .        .   4 : famille des pyramides de conformite  .
  81 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  82 c . langue . e   .    1   . langue des messages                        .
  83 c .        .     .        . 1 : francais, 2 : anglais                  .
  84 c . codret . es  .    1   . code de retour des modules                 .
  85 c .        .     .        . 0 : pas de probleme                        .
  86 c ______________________________________________________________________
  87 c
  88 c====
  89 c 0. declarations et dimensionnement
  90 c====
  91 c
  92 c 0.1. ==> generalites
  93 c
  94       implicit none
  95       save
  96 c
  97       character*6 nompro
  98       parameter ( nompro = 'CMCP2A' )
  99 c
 100 #include "nblang.h"
 101 c
 102 c 0.2. ==> communs
 103 c
 104 #include "envex1.h"
 105 c
 106 #include "dicfen.h"
 107 #include "nbfami.h"
 108 #include "nouvnb.h"
 109 c
 110 c 0.3. ==> arguments
 111 c
 112       integer lepent, etapen
 113       integer indare, indtri, indtet
 114       integer indptp
 115       integer hetare(nouvar), somare(2,nouvar)
 116       integer filare(nouvar), merare(nouvar), famare(nouvar)
 117       integer hettri(nouvtr), aretri(nouvtr,3)
 118       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 119       integer nivtri(nouvtr)
 120       integer arequa(nouvqu,4)
 121       integer filqua(nouvqu)
 122       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 123       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 124       integer facpen(nouvpf,5), cofape(nouvpf,5)
 125       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 126 c
 127       integer ulsort, langue, codret
 128 c
 129 c 0.4. ==> variables locales
 130 c
 131       integer iaux
 132       integer listar(9)
 133 c
 134       integer nbmess
 135       parameter ( nbmess = 10 )
 136       character*80 texte(nblang,nbmess)
 137 c
 138 c 0.5. ==> initialisations
 139 c ______________________________________________________________________
 140 c
 141 c====
 142 c 1. messages
 143 c====
 144 c
 145 #include "impr01.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,1)) 'Entree', nompro
 149       call dmflsh (iaux)
 150 #endif
 151 c
 152       texte(1,4) = '(''Aucune arete ne correspond.'')'
 153 c
 154       texte(2,4) = '(''No edge is correct.'')'
 155 c
 156 #include "impr03.h"
 157 #include "impr04.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,90002) 'indare', indare
 161       write (ulsort,90002) 'indtri', indtri
 162       write (ulsort,90002) 'indtet', indtet
 163 #endif
 164 c
 165       codret = 0
 166 c
 167 c====
 168 c 2. Recherche des aretes
 169 c====
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,texte(langue,3)) 'UTARPE', nompro
 173 #endif
 174       call utarpe ( lepent,
 175      >              nouvqu, nouvpe,
 176      >              arequa, facpen, cofape,
 177      >              listar )
 178 c
 179 c====
 180 c 3. Recherche de l'arete decoupee
 181 c====
 182 #ifdef _DEBUG_HOMARD_
 183       do 3999 , iaux = 1 , 9
 184         write(ulsort,91002) iaux, listar(iaux),
 185      >                  somare(1,listar(iaux)), somare(2,listar(iaux)),
 186      >                    hetare(listar(iaux))
 187  3999 continue
 188 #endif
 189 c
 190       if ( codret.eq.0 ) then
 191 c
 192 c 3.1. ==> Les aretes 1 et 8 sont coupees
 193 c
 194       if ( mod(hetare(listar(1)),10).eq.2 .and.
 195      >     mod(hetare(listar(8)),10).eq.2 ) then
 196         etapen = 21
 197 #ifdef _DEBUG_HOMARD_
 198       write (ulsort,texte(langue,3)) 'CMCP21', nompro
 199 #endif
 200         call cmcp21 ( lepent, listar,
 201      >                indare, indtri, indtet,
 202      >                indptp,
 203      >                hetare, somare,
 204      >                filare, merare, famare,
 205      >                hettri, aretri,
 206      >                filtri, pertri, famtri,
 207      >                nivtri,
 208      >                filqua,
 209      >                hettet, tritet, cotrte,
 210      >                filtet, pertet, famtet,
 211      >                facpen, cofape,
 212      >                fampen, cfapen,
 213      >                ulsort, langue, codret )
 214 c
 215 c 3.2. ==> Les aretes 2 et 9 sont coupees
 216 c
 217       elseif ( mod(hetare(listar(2)),10).eq.2 .and.
 218      >         mod(hetare(listar(9)),10).eq.2 ) then
 219         etapen = 22
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,texte(langue,3)) 'CMCP22', nompro
 222 #endif
 223         call cmcp22 ( lepent, listar,
 224      >                indare, indtri, indtet,
 225      >                indptp,
 226      >                hetare, somare,
 227      >                filare, merare, famare,
 228      >                hettri, aretri,
 229      >                filtri, pertri, famtri,
 230      >                nivtri,
 231      >                filqua,
 232      >                hettet, tritet, cotrte,
 233      >                filtet, pertet, famtet,
 234      >                facpen, cofape,
 235      >                fampen, cfapen,
 236      >                ulsort, langue, codret )
 237 c
 238 c 3.3. ==> Les aretes 3 et 7 sont coupees
 239 c
 240       elseif ( mod(hetare(listar(3)),10).eq.2 .and.
 241      >         mod(hetare(listar(7)),10).eq.2 ) then
 242         etapen = 23
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,texte(langue,3)) 'CMCP23', nompro
 245 #endif
 246         call cmcp23 ( lepent, listar,
 247      >                indare, indtri, indtet,
 248      >                indptp,
 249      >                hetare, somare,
 250      >                filare, merare, famare,
 251      >                hettri, aretri,
 252      >                filtri, pertri, famtri,
 253      >                nivtri,
 254      >                filqua,
 255      >                hettet, tritet, cotrte,
 256      >                filtet, pertet, famtet,
 257      >                facpen, cofape,
 258      >                fampen, cfapen,
 259      >                ulsort, langue, codret )
 260 c
 261 c 3.4. ==> Les aretes 4 et 8 sont coupees
 262 c
 263       elseif ( mod(hetare(listar(4)),10).eq.2 .and.
 264      >         mod(hetare(listar(8)),10).eq.2 ) then
 265         etapen = 24
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,texte(langue,3)) 'CMCP24', nompro
 268 #endif
 269         call cmcp24 ( lepent, listar,
 270      >                indare, indtri, indtet,
 271      >                indptp,
 272      >                hetare, somare,
 273      >                filare, merare, famare,
 274      >                hettri, aretri,
 275      >                filtri, pertri, famtri,
 276      >                nivtri,
 277      >                filqua,
 278      >                hettet, tritet, cotrte,
 279      >                filtet, pertet, famtet,
 280      >                facpen, cofape,
 281      >                fampen, cfapen,
 282      >                ulsort, langue, codret )
 283 c
 284 c 3.5. ==> Les aretes 5 et 9 sont coupees
 285 c
 286       elseif ( mod(hetare(listar(5)),10).eq.2 .and.
 287      >         mod(hetare(listar(9)),10).eq.2 ) then
 288         etapen = 25
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,texte(langue,3)) 'CMCP25', nompro
 291 #endif
 292         call cmcp25 ( lepent, listar,
 293      >                indare, indtri, indtet,
 294      >                indptp,
 295      >                hetare, somare,
 296      >                filare, merare, famare,
 297      >                hettri, aretri,
 298      >                filtri, pertri, famtri,
 299      >                nivtri,
 300      >                filqua,
 301      >                hettet, tritet, cotrte,
 302      >                filtet, pertet, famtet,
 303      >                facpen, cofape,
 304      >                fampen, cfapen,
 305      >                ulsort, langue, codret )
 306 c
 307 c 3.6. ==> Les aretes 6 et 7 sont coupees
 308 c
 309       elseif ( mod(hetare(listar(6)),10).eq.2 .and.
 310      >         mod(hetare(listar(7)),10).eq.2 ) then
 311         etapen = 26
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,3)) 'CMCP26', nompro
 314 #endif
 315         call cmcp26 ( lepent, listar,
 316      >                indare, indtri, indtet,
 317      >                indptp,
 318      >                hetare, somare,
 319      >                filare, merare, famare,
 320      >                hettri, aretri,
 321      >                filtri, pertri, famtri,
 322      >                nivtri,
 323      >                filqua,
 324      >                hettet, tritet, cotrte,
 325      >                filtet, pertet, famtet,
 326      >                facpen, cofape,
 327      >                fampen, cfapen,
 328      >                ulsort, langue, codret )
 329 c
 330 c 3.7. ==> Laquelle ?
 331 c
 332       else
 333         codret = 1
 334       endif
 335 c
 336       endif
 337 c
 338 c====
 339 c 4. la fin
 340 c====
 341 c
 342       if ( codret.ne.0 ) then
 343 c
 344 #include "envex2.h"
 345 c
 346       write (ulsort,texte(langue,1)) 'Sortie', nompro
 347       write (ulsort,texte(langue,2)) codret
 348       write (ulsort,texte(langue,4))
 349 c
 350       endif
 351 c
 352 #ifdef _DEBUG_HOMARD_
 353       write (ulsort,texte(langue,1)) 'Sortie', nompro
 354       call dmflsh (iaux)
 355 #endif
 356 c
 357       end