src/tool/Creation_Maillage/cmchad.F

   1       subroutine cmchad ( nulofa, lehexa,
   2      >                    indpyr, indptp,
   3      >                    triint,   tab1,
   4      >                    hetpyr, facpyr, cofapy,
   5      >                    filpyr, perpyr, fampyr,
   6      >                    quahex, coquhe,
   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 - Conformite - decoupage des Hexaedres
  30 c    -           -          -                          -
  31 c                         - par 2 Aretes - phase D
  32 c                                 -              -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . nulofa . e   .   2    . numero local des faces quadrangles         .
  38 c . lehexa . e   .   1    . hexaedre a decouper                        .
  39 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  40 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  41 c . triint . e   .  22    . triangles internes a l'hexaedre            .
  42 c .        .     .        .  1-4 = bordant la pyramide 1               .
  43 c .        .     .        .  5-8 = bordant la pyramide 2               .
  44 c .        .     .        .  9-10 = s'appuyant sur les 2 autres aretes .
  45 c .        .     .        .         non decoupees                      .
  46 c .        .     .        .  11-14 = appuyes sur une arete interne a   .
  47 c .        .     .        .   une face coupee, du cote de la pyramide 1.
  48 c .        .     .        .  15-18 = appuyes sur une arete interne a   .
  49 c .        .     .        .   une face coupee, du cote de la pyramide 2.
  50 c .        .     .        .  19-22 = appuyes sur les filles des aretes .
  51 c .        .     .        .   coupees                                  .
  52 c . tab1   . e   .    2   . code de la permutation circulaire des 4    .
  53 c .        .     .        . faces definissant la pyramide              .
  54 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  55 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  56 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  57 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  58 c . perpyr . es  . nouvpy . pere des pyramides                         .
  59 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  60 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  61 c . fampyr . es  . nouvpy . famille des pyramides                      .
  62 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  63 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  64 c . famhex . e   . nouvhe . famille des hexaedres                      .
  65 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  66 c .        .     . nbfhex .   1 : famille MED                          .
  67 c .        .     .        .   2 : type d'hexaedres                     .
  68 c .        .     .        .   3 : famille des tetraedres de conformite .
  69 c .        .     .        .   4 : famille des pyramides de conformite  .
  70 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  71 c . langue . e   .    1   . langue des messages                        .
  72 c .        .     .        . 1 : francais, 2 : anglais                  .
  73 c . codret . es  .    1   . code de retour des modules                 .
  74 c .        .     .        . 0 : pas de probleme                        .
  75 c .        .     .        . 1 : aucune arete ne correspond             .
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 0. declarations et dimensionnement
  80 c====
  81 c
  82 c 0.1. ==> generalites
  83 c
  84       implicit none
  85       save
  86 c
  87       character*6 nompro
  88       parameter ( nompro = 'CMCHAD' )
  89 c
  90 #include "nblang.h"
  91 c
  92 c 0.2. ==> communs
  93 c
  94 #include "envex1.h"
  95 c
  96 #include "dicfen.h"
  97 #include "nbfami.h"
  98 #include "nouvnb.h"
  99 #include "cofpfh.h"
 100 #include "ope1a4.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       integer lehexa, nulofa(2)
 105       integer indpyr, indptp
 106       integer triint(22), tab1(2)
 107       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 108       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 109       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 110       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 111 c
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer iaux, jaux
 117       integer laface
 118       integer codfac
 119 c
 120       integer nbmess
 121       parameter ( nbmess = 10 )
 122       character*80 texte(nblang,nbmess)
 123 c
 124 c 0.5. ==> initialisations
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 1. initialisations
 129 c====
 130 c
 131 c 1.1. ==> messages
 132 c
 133 #include "impr01.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140       codret = 0
 141 c
 142 c====
 143 c 2. Creation des deux pyramides
 144 c====
 145 c
 146 c 2.1. ==> Le pere des pyramides et leur famille
 147 c
 148       iaux = -indptp
 149       jaux = cfahex(cofpfh,famhex(lehexa))
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,texte(langue,3)) 'CMCPYR', nompro
 153       write (ulsort,2100) indpyr+1, indpyr+2
 154  2100 format( '.. pyramides de',i10,' a',i10)
 155 #endif
 156 c
 157       laface = quahex(lehexa,nulofa(1))
 158       codfac = coquhe(lehexa,nulofa(1))
 159       indpyr = indpyr + 1
 160       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 161      >              triint(per1a4(tab1(1),1)), 3,
 162      >              triint(per1a4(tab1(1),2)), 3,
 163      >              triint(per1a4(tab1(1),3)), 3,
 164      >              triint(per1a4(tab1(1),4)), 2,
 165      >                 laface, codfac,
 166      >              iaux,  jaux,   indpyr )
 167 c
 168       laface = quahex(lehexa,nulofa(2))
 169       codfac = coquhe(lehexa,nulofa(2))
 170       indpyr = indpyr + 1
 171       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 172      >              triint(4+per1a4(tab1(2),1)), 3,
 173      >              triint(4+per1a4(tab1(2),2)), 3,
 174      >              triint(4+per1a4(tab1(2),3)), 3,
 175      >              triint(4+per1a4(tab1(2),4)), 2,
 176      >                 laface, codfac,
 177      >              iaux,  jaux,   indpyr )
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       do 4333 , iaux = indpyr-1, indpyr
 181       write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5)
 182  4333 continue
 183  1789 format('pyramide ',i6,' : ',5i6)
 184 #endif
 185 c
 186 c====
 187 c 3. la fin
 188 c====
 189 c
 190       if ( codret.ne.0 ) then
 191 c
 192 #include "envex2.h"
 193 c
 194       write (ulsort,texte(langue,1)) 'Sortie', nompro
 195       write (ulsort,texte(langue,2)) codret
 196 c
 197       endif
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,texte(langue,1)) 'Sortie', nompro
 201       call dmflsh (iaux)
 202 #endif
 203 c
 204       end