src/tool/Creation_Maillage/cmcp1a.F

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