src/tool/Creation_Maillage/cmcp4a.F

   1       subroutine cmcp4a ( lepent, etapen,
   2      >                    indare, indtri, indtet, indpyr,
   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      >                    hetpyr, facpyr, cofapy,
  13      >                    filpyr, perpyr, fampyr,
  14      >                    facpen, cofape,
  15      >                    fampen, cfapen,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  24 c aupres des huissiers de justice Simart et Lavoir a Clamart
  25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  26 c aupres des huissiers de justice
  27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c    Creation du Maillage - Conformite - decoupage des Pentaedres
  38 c    -           -          -                          -
  39 c                         - cas 4, phase A, pilotage
  40 c                               -        -
  41 c                         - par 1 face quadrangulaire
  42 c ______________________________________________________________________
  43 c .        .     .        .                                            .
  44 c .  nom   . e/s . taille .           description                      .
  45 c .____________________________________________________________________.
  46 c . lepent . e   .   1    . pentaedre a decouper                       .
  47 c . etapen .  s  .    1   . etat final du pentaedre                    .
  48 c . indare . es  .   1    . indice de la derniere arete creee          .
  49 c . indtri . es  .   1    . indice du dernier triangle cree            .
  50 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  51 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  52 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  53 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  54 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  55 c . filare . es  . nouvar . premiere fille des aretes                  .
  56 c . merare . es  . nouvar . mere des aretes                            .
  57 c . famare .     . nouvar . famille des aretes                         .
  58 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  59 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  60 c . filtri . es  . nouvtr . premier fils des triangles                 .
  61 c . pertri . es  . nouvtr . pere des triangles                         .
  62 c . famtri . es  . nouvtr . famille des triangles                      .
  63 c . nivtri . es  . nouvtr . niveau des triangles                       .
  64 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  65 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  66 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  67 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  68 c . cotrte . es  .nouvtf*4. code des 4 triangles des tetraedres        .
  69 c . filtet . es  . nouvte . premier fils des tetraedres                .
  70 c . pertet . es  . nouvte . pere des tetraedres                        .
  71 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  72 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  73 c . famtet . es  . nouvte . famille des tetraedres                     .
  74 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  75 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  76 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  77 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . es  . nouvpy . pere des pyramides                         .
  79 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  80 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  81 c . fampyr . es  . nouvpy . famille des pyramides                      .
  82 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  83 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  84 c . fampen . e   . nouvpe . famille des penaedres                      .
  85 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  86 c .        .     . nbfpen .   1 : famille MED                          .
  87 c .        .     .        .   2 : type de pentaedres                   .
  88 c .        .     .        .   3 : famille des tetraedres de conformite .
  89 c .        .     .        .   4 : famille des pyramides de conformite  .
  90 c .        .     .        .   3 : famille des tetraedres de conformite .
  91 c .        .     .        .   4 : famille des pyramides de conformite  .
  92 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  93 c . langue . e   .    1   . langue des messages                        .
  94 c .        .     .        . 1 : francais, 2 : anglais                  .
  95 c . codret . es  .    1   . code de retour des modules                 .
  96 c .        .     .        . 0 : pas de probleme                        .
  97 c ______________________________________________________________________
  98 c
  99 c====
 100 c 0. declarations et dimensionnement
 101 c====
 102 c
 103 c 0.1. ==> generalites
 104 c
 105       implicit none
 106       save
 107 c
 108       character*6 nompro
 109       parameter ( nompro = 'CMCP4A' )
 110 c
 111 #include "nblang.h"
 112 c
 113 c 0.2. ==> communs
 114 c
 115 #include "envex1.h"
 116 c
 117 #include "dicfen.h"
 118 #include "nbfami.h"
 119 #include "nouvnb.h"
 120 c
 121 c 0.3. ==> arguments
 122 c
 123       integer lepent, etapen
 124       integer indare, indtri, indtet, indpyr
 125       integer indptp
 126       integer hetare(nouvar), somare(2,nouvar)
 127       integer filare(nouvar), merare(nouvar), famare(nouvar)
 128       integer hettri(nouvtr), aretri(nouvtr,3)
 129       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 130       integer nivtri(nouvtr)
 131       integer arequa(nouvqu,4)
 132       integer filqua(nouvqu)
 133       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 134       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 135       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 136       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 137       integer facpen(nouvpf,5), cofape(nouvpf,5)
 138       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 139 c
 140       integer ulsort, langue, codret
 141 c
 142 c 0.4. ==> variables locales
 143 c
 144       integer iaux
 145       integer listar(9), listso(6)
 146 c
 147       integer nbmess
 148       parameter ( nbmess = 10 )
 149       character*80 texte(nblang,nbmess)
 150 c
 151 c 0.5. ==> initialisations
 152 c ______________________________________________________________________
 153 c
 154 c====
 155 c 1. messages
 156 c====
 157 c
 158 #include "impr01.h"
 159 c
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,texte(langue,1)) 'Entree', nompro
 162       call dmflsh (iaux)
 163 #endif
 164 c
 165       texte(1,4) = '(''Aucune arete ne correspond.'')'
 166 c
 167       texte(2,4) = '(''No edge is correct.'')'
 168 c
 169 #include "impr03.h"
 170 #include "impr04.h"
 171 c
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,90002) 'indare', indare
 174       write (ulsort,90002) 'indtri', indtri
 175       write (ulsort,90002) 'indtet', indtet
 176       write (ulsort,90002) 'indpyr', indpyr
 177 #endif
 178 c
 179       codret = 0
 180 c
 181 c====
 182 c 2. Recherche des aretes
 183 c====
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186       write (ulsort,texte(langue,3)) 'UTARPE', nompro
 187 #endif
 188       call utarpe ( lepent,
 189      >              nouvqu, nouvpe,
 190      >              arequa, facpen, cofape,
 191      >              listar )
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,texte(langue,3)) 'UTSOPE', nompro
 195 #endif
 196       call utsope ( somare, listar, listso )
 197 c
 198 c====
 199 c 3. Recherche de l'arete decoupee
 200 c====
 201 #ifdef _DEBUG_HOMARD_
 202       do 3999 , iaux = 1 , 9
 203         write(ulsort,91002) iaux, listar(iaux),
 204      >                  somare(1,listar(iaux)), somare(2,listar(iaux)),
 205      >                    hetare(listar(iaux))
 206  3999 continue
 207 #endif
 208 c
 209       if ( codret.eq.0 ) then
 210 c
 211 c 3.1. ==> La face F3 est coupee : aretes 1, 7, 4 ,9
 212 c
 213       if ( mod(hetare(listar(1)),10).eq.2 .and.
 214      >     mod(hetare(listar(4)),10).eq.2 .and.
 215      >     mod(hetare(listar(7)),10).eq.2 .and.
 216      >     mod(hetare(listar(9)),10).eq.2 ) then
 217         etapen = 43
 218 #ifdef _DEBUG_HOMARD_
 219       write (ulsort,texte(langue,3)) 'CMCP43', nompro
 220 #endif
 221         call cmcp43 ( lepent, listar, listso,
 222      >                indare, indtri, indtet, indpyr,
 223      >                indptp,
 224      >                hetare, somare,
 225      >                filare, merare, famare,
 226      >                hettri, aretri,
 227      >                filtri, pertri, famtri,
 228      >                nivtri,
 229      >                arequa, filqua,
 230      >                hettet, tritet, cotrte,
 231      >                filtet, pertet, famtet,
 232      >                hetpyr, facpyr, cofapy,
 233      >                filpyr, perpyr, fampyr,
 234      >                facpen, cofape,
 235      >                fampen, cfapen,
 236      >                ulsort, langue, codret )
 237 c
 238 c 3.2. ==> La face F4 est coupee : aretes 2, 8, 5 ,7
 239 c
 240       elseif ( mod(hetare(listar(2)),10).eq.2 .and.
 241      >         mod(hetare(listar(5)),10).eq.2 .and.
 242      >         mod(hetare(listar(7)),10).eq.2 .and.
 243      >         mod(hetare(listar(8)),10).eq.2 ) then
 244         etapen = 44
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'CMCP44', nompro
 247 #endif
 248         call cmcp44 ( lepent, listar, listso,
 249      >                indare, indtri, indtet, indpyr,
 250      >                indptp,
 251      >                hetare, somare,
 252      >                filare, merare, famare,
 253      >                hettri, aretri,
 254      >                filtri, pertri, famtri,
 255      >                nivtri,
 256      >                arequa, filqua,
 257      >                hettet, tritet, cotrte,
 258      >                filtet, pertet, famtet,
 259      >                hetpyr, facpyr, cofapy,
 260      >                filpyr, perpyr, fampyr,
 261      >                facpen, cofape,
 262      >                fampen, cfapen,
 263      >                ulsort, langue, codret )
 264 c
 265 c 3.3. ==> La face F5 est coupee : aretes 3, 9, 6, 8
 266 c
 267       elseif ( mod(hetare(listar(3)),10).eq.2 .and.
 268      >         mod(hetare(listar(6)),10).eq.2 .and.
 269      >         mod(hetare(listar(8)),10).eq.2 .and.
 270      >         mod(hetare(listar(9)),10).eq.2 ) then
 271         etapen = 45
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'CMCP45', nompro
 274 #endif
 275         call cmcp45 ( lepent, listar, listso,
 276      >                indare, indtri, indtet, indpyr,
 277      >                indptp,
 278      >                hetare, somare,
 279      >                filare, merare, famare,
 280      >                hettri, aretri,
 281      >                filtri, pertri, famtri,
 282      >                nivtri,
 283      >                arequa, filqua,
 284      >                hettet, tritet, cotrte,
 285      >                filtet, pertet, famtet,
 286      >                hetpyr, facpyr, cofapy,
 287      >                filpyr, perpyr, fampyr,
 288      >                facpen, cofape,
 289      >                fampen, cfapen,
 290      >                ulsort, langue, codret )
 291 c
 292 c 3.9. ==> Laquelle ?
 293 c
 294       else
 295         codret = 1
 296       endif
 297 c
 298       endif
 299 c
 300 c====
 301 c 4. la fin
 302 c====
 303 c
 304       if ( codret.ne.0 ) then
 305 c
 306 #include "envex2.h"
 307 c
 308       write (ulsort,texte(langue,1)) 'Sortie', nompro
 309       write (ulsort,texte(langue,2)) codret
 310       write (ulsort,texte(langue,4))
 311 c
 312       endif
 313 c
 314 #ifdef _DEBUG_HOMARD_
 315       write (ulsort,texte(langue,1)) 'Sortie', nompro
 316       call dmflsh (iaux)
 317 #endif
 318 c
 319       end