src/tool/Creation_Maillage/cmcpy4.F

   1       subroutine cmcpy4 ( lehexa, indpyr, indptp,
   2      >                    laface,
   3      >                    somhex, areint, as1s2, as1s4, as3s4, as2s3,
   4      >                    somare, filare, arequa, filqua,
   5      >                    arepyr, fampyr,
   6      >                    hetpyr, filpyr, perpyr,
   7      >                    famhex, cfahex,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    Creation du Maillage - Creation de PYramidee par leurs aretes
  30 c    -           -          -            --
  31 c                         - par paquets de 4 appuyes sur une face
  32 c                                          -
  33 c ______________________________________________________________________
  34 c    La description est faite comme pour le decoupage de la face 1
  35 c
  36 c           S2               N1              S1
  37 c            |---------------|---------------|
  38 c            |               |               |
  39 c            |               |               |
  40 c            |               |               |
  41 c            |               |N0             |
  42 c         N3 |---------------|---------------| N2
  43 c            |               |               |
  44 c            |               |               |
  45 c            |               |               |
  46 c            |               |               |
  47 c            |---------------|---------------|
  48 c           S3               N4              S4
  49 c ______________________________________________________________________
  50 c .        .     .        .                                            .
  51 c .  nom   . e/s . taille .           description                      .
  52 c .____________________________________________________________________.
  53 c . lehexa . e   .   1    . hexaedre a decouper                        .
  54 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  55 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  56 c . laface . e   .   1    . face coupee en 2 quadrangles               .
  57 c . somhex . e   .   8    . Les sommets de la face dans                .
  58 c .        .     .        . l'ordre S2, S1, S4, S3                     .
  59 c .        .     .        . puis les noeuds milieux N1, N2, N4, N3     .
  60 c . areint . e   .   9    . Les aretes internes utiles                 .
  61 c .        .     .        . . Les 4 1ers sur S2, S1, S4, S3            .
  62 c .        .     .        . . Les 4 suivants sur N1, N2, N4, N3        .
  63 c .        .     .        . . 9 sur le milieu de la face               .
  64 c . as1s2  . e   .   1    . arete S1-S2                                .
  65 c . as1s4  . e   .   1    . arete S1-S4                                .
  66 c . as3s4  . e   .   1    . arete S3-S4                                .
  67 c . as2s3  . e   .   1    . arete S2-S3                                .
  68 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  69 c . filare . e   . nouvar . fille ainee de chaque arete                .
  70 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  71 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  72 c . arepyr . e   .nouvya*8. numeros des 8 aretes des pyramides         .
  73 c . fampyr . e   . nouvpy . famille des pyramides                      .
  74 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  75 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  76 c . perpyr . e   . nouvpy . pere des pyramides                         .
  77 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  78 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  79 c . famhex . e   . nouvhe . famille des hexaedres                      .
  80 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  81 c .        .     . nbfhex .   1 : famille MED                          .
  82 c .        .     .        .   2 : type d'hexaedres                     .
  83 c .        .     .        .   3 : famille des tetraedres de conformite .
  84 c .        .     .        .   4 : famille des pyramides de conformite  .
  85 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  86 c . langue . e   .    1   . langue des messages                        .
  87 c .        .     .        . 1 : francais, 2 : anglais                  .
  88 c . codret . es  .    1   . code de retour des modules                 .
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 0. declarations et dimensionnement
  93 c====
  94 c
  95 c 0.1. ==> generalites
  96 c
  97       implicit none
  98       save
  99 c
 100       character*6 nompro
 101       parameter ( nompro = 'CMCPY4' )
 102 c
 103 #include "nblang.h"
 104 c
 105 c 0.2. ==> communs
 106 c
 107 #include "envex1.h"
 108 c
 109 #include "dicfen.h"
 110 #include "nbfami.h"
 111 #include "nouvnb.h"
 112 #include "cofpfh.h"
 113 c
 114 c 0.3. ==> arguments
 115 c
 116       integer lehexa, indpyr, indptp
 117       integer laface
 118       integer somhex(8), areint(9)
 119       integer as1s2, as1s4, as3s4, as2s3
 120       integer somare(2,nouvar), filare(nouvar)
 121       integer arequa(nouvqu,4), filqua(nouvqu)
 122       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 123       integer arepyr(nouvya,8), fampyr(nouvpy)
 124       integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy)
 125 c
 126       integer ulsort, langue, codret
 127 c
 128 c 0.4. ==> variables locales
 129 c
 130       integer iaux, jaux
 131       integer listar(4)
 132       integer nupere, nufami
 133       integer as1n1, as2n1, as1n2, as4n2
 134       integer as3n4, as4n4, as2n3, as3n3
 135       integer an1nf1, an2nf1, an4nf1, an3nf1
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 10 )
 139       character*80 texte(nblang,nbmess)
 140 c ______________________________________________________________________
 141 c
 142 c====
 143 c 1. initialisations
 144 c====
 145 c
 146 #include "impr01.h"
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,texte(langue,1)) 'Entree', nompro
 150       call dmflsh (iaux)
 151 #endif
 152 c
 153 #include "impr03.h"
 154 c
 155       codret = 0
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,90002) 'laface', laface
 159       write (ulsort,90002) 'somhex', somhex
 160       write (ulsort,90002) 'areint', areint
 161       write (ulsort,90002) 'as1s2, as1s4, as3s4, as2s3',
 162      >                      as1s2, as1s4, as3s4, as2s3
 163 #endif
 164 c
 165 c====
 166 c 2. Recuperation des demi-aretes
 167 c====
 168 c 2.1. == filles de as1s2
 169 c
 170       if ( somhex(1).le.somhex(2) ) then
 171         as1n1 = filare(as1s2) + 1
 172         as2n1 = filare(as1s2)
 173       else
 174         as1n1 = filare(as1s2)
 175         as2n1 = filare(as1s2) + 1
 176       endif
 177 c
 178 c 2.2. == filles de as1s4
 179 c
 180       if ( somhex(2).le.somhex(3) ) then
 181         as1n2 = filare(as1s4)
 182         as4n2 = filare(as1s4) + 1
 183       else
 184         as1n2 = filare(as1s4) + 1
 185         as4n2 = filare(as1s4)
 186       endif
 187 c
 188 c 2.4. == filles de as3s4
 189 c
 190       if ( somhex(3).le.somhex(4) ) then
 191         as3n4 = filare(as3s4) + 1
 192         as4n4 = filare(as3s4)
 193       else
 194         as3n4 = filare(as3s4)
 195         as4n4 = filare(as3s4) + 1
 196       endif
 197 c
 198 c 2.4. == filles de as2s3
 199 c
 200       if ( somhex(4).le.somhex(1) ) then
 201         as2n3 = filare(as2s3) + 1
 202         as3n3 = filare(as2s3)
 203       else
 204         as2n3 = filare(as2s3)
 205         as3n3 = filare(as2s3) + 1
 206       endif
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,90002) 'as1n1, as2n1, as1n2, as4n2',
 210      >                      as1n1, as2n1, as1n2, as4n2
 211       write (ulsort,90002) 'as3n4, as4n4, as2n3, as3n3',
 212      >                      as3n4, as4n4, as2n3, as3n3
 213 #endif
 214 c
 215 c====
 216 c 3. Recuperation des aretes entre les milieux des aretes coupees
 217 c====
 218 c 3.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans
 219 c          la description des fils (cf. cmcdq2)
 220 c
 221       listar(1) = arequa(filqua(laface)  ,2)
 222       listar(2) = arequa(filqua(laface)  ,3)
 223       listar(3) = arequa(filqua(laface)+2,2)
 224       listar(4) = arequa(filqua(laface)+2,3)
 225 #ifdef _DEBUG_HOMARD_
 226       write (ulsort,90002) 'listar', listar
 227 #endif
 228 c
 229 c 3.2. ==> Positionnement
 230 c
 231       do 32 , iaux = 1 , 4
 232 c
 233         jaux = somare(1,listar(iaux))
 234         if ( jaux.eq.somhex(5) ) then
 235           an1nf1 = listar(iaux)
 236         elseif ( jaux.eq.somhex(6) ) then
 237           an2nf1 = listar(iaux)
 238         elseif ( jaux.eq.somhex(7) ) then
 239           an4nf1 = listar(iaux)
 240         elseif ( jaux.eq.somhex(8) ) then
 241           an3nf1 = listar(iaux)
 242         endif
 243 c
 244    32 continue
 245 c
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,90002) 'an1nf1, an2nf1, an4nf1, an3nf1',
 248      >                      an1nf1, an2nf1, an4nf1, an3nf1
 249 #endif
 250 c
 251 c====
 252 c 4. Creation des pyramides
 253 c====
 254 c
 255       nupere = -indptp
 256       nufami = cfahex(cofpfh,famhex(lehexa))
 257 c
 258 c 4.1. ==> Pyramide numero 1
 259 c
 260       indpyr = indpyr + 1
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro
 263 #endif
 264       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 265      >              areint(2), areint(6), areint(9), areint(5),
 266      >              as1n2, an2nf1, an1nf1, as1n1,
 267      >              nupere,  nufami,   indpyr )
 268 c
 269 c 4.2. ==> Pyramide numero 2
 270 c
 271       indpyr = indpyr + 1
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'CMCPYA pyra 2', nompro
 274 #endif
 275       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 276      >              areint(3), areint(7), areint(9), areint(6),
 277      >              as4n4, an4nf1, an2nf1, as4n2,
 278      >              nupere,  nufami,   indpyr )
 279 c
 280 c 4.3. ==> Pyramide numero 3
 281 c
 282       indpyr = indpyr + 1
 283 #ifdef _DEBUG_HOMARD_
 284       write (ulsort,texte(langue,3)) 'CMCPYA pyra 3', nompro
 285 #endif
 286       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 287      >              areint(4), areint(8), areint(9), areint(7),
 288      >              as3n3, an3nf1, an4nf1, as3n4,
 289      >              nupere,  nufami,   indpyr )
 290 c
 291 c 4.4. ==> Pyramide numero 4
 292 c
 293       indpyr = indpyr + 1
 294 #ifdef _DEBUG_HOMARD_
 295       write (ulsort,texte(langue,3)) 'CMCPYA pyra 4', nompro
 296 #endif
 297       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 298      >              areint(1), areint(5), areint(9), areint(8),
 299      >              as2n1, an1nf1, an3nf1, as2n3,
 300      >              nupere,  nufami,   indpyr )
 301 c
 302 c====
 303 c 5. la fin
 304 c====
 305 c
 306       if ( codret.ne.0 ) then
 307 c
 308 #include "envex2.h"
 309 c
 310       write (ulsort,texte(langue,1)) 'Sortie', nompro
 311       write (ulsort,texte(langue,2)) codret
 312 c
 313       endif
 314 c
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,texte(langue,1)) 'Sortie', nompro
 317       call dmflsh (iaux)
 318 #endif
 319 c
 320       end