src/tool/Creation_Maillage/cmhoma.F

   1       subroutine cmhoma ( noehom, arehom,
   2      >                    somare, filare, hetare,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    Creation du Maillage - HOMologues - les Aretes
  25 c    -           -          ---              -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . noehom . es  . nbnoto . ensemble des noeuds homologues             .
  31 c . arehom . es  . nbarto . ensemble des aretes homologues             .
  32 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  33 c . filare . e   . nbarto . premiere fille des aretes                  .
  34 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  35 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51       character*6 nompro
  52       parameter ( nompro = 'CMHOMA' )
  53 c
  54 #include "nblang.h"
  55 c
  56 c 0.2. ==> communs
  57 c
  58 #include "envex1.h"
  59 c
  60 #include "nombno.h"
  61 #include "nombar.h"
  62 #include "impr02.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66       integer noehom(nbnoto), arehom(nbarto)
  67       integer somare(2,nbarto), filare(nbarto), hetare(nbarto)
  68 c
  69       integer ulsort, langue, codret
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       integer iaux
  74       integer a21, a22, a11, a12, s11, s12, s21, s22, s2m, s1m
  75       integer larete
  76       integer areh
  77 c
  78       integer nbmess
  79       parameter ( nbmess = 10 )
  80       character*80 texte(nblang,nbmess)
  81 c
  82 c 0.5. ==> initialisations
  83 c ______________________________________________________________________
  84 c
  85 c====
  86 c 1. initialisations
  87 c====
  88 c
  89 #include "impr01.h"
  90 c
  91 #ifdef _DEBUG_HOMARD_
  92       write (ulsort,texte(langue,1)) 'Entree', nompro
  93       call dmflsh (iaux)
  94 #endif
  95 c
  96       texte(1,4) = '(''Le noeud'',i10,'' est homologue du noeud'',i10)'
  97       texte(1,5) =
  98      > '(''Le '',a,i10,'' devrait etre homologue du '',a,i10)'
  99       texte(1,6) = '(''alors que les tables indiquent que :'')'
 100       texte(1,7) = '(''Arete'',i10,'' de sommets'',2i10)'
 101 c
 102       texte(2,4) = '(''Node #'',i10,'' is homologous of node #'',i10)'
 103       texte(2,5) =
 104      >'(''The '',a,''#'',i10,'' should be homologous of '',a,''#'',i10)'
 105       texte(2,6) = '(''but tables indicate that :'')'
 106       texte(2,7) = '(''Edge #'',i10,'' with vertices #'',2i10)'
 107 c
 108 c====
 109 c 2. on boucle uniquement sur les aretes de la face periodique 2
 110 c    qui viennent d'etre decoupees en 2
 111 c====
 112 c
 113       do 21, larete = 1 , nbarpe
 114 cgn                   print *,' '
 115 cgn                   print *,'larete = ',larete
 116 c
 117         if ( arehom(larete).gt.0 ) then
 118 c
 119 c         larete est sur la face periodique 2
 120 c
 121           if ( hetare(larete).eq.2 ) then
 122 cgn                   print *,'.. larete est coupee en 2'
 123 c
 124 c 2.1. ==> les entites liees a l'arete courante, larete :
 125 c          . sommets de l'arete mere
 126 c          . les aretes filles
 127 c          . le nouveau noeud
 128 c          . l'arete homologue de la mere
 129 c
 130 c               s21       larete        s22
 131 c                x-----------.-----------x
 132 c                    a21   s2m    a22
 133 c
 134             s21 = somare(1,larete)
 135             s22 = somare(2,larete)
 136 c
 137             a21 = filare(larete)
 138             a22 = a21 + 1
 139 c
 140             s2m = somare(2,a21)
 141 c
 142             areh = arehom(larete)
 143 cgn                   if ( larete.eq.50)then
 144 cgn                   print *,'.. sommets de larete : ',s21,s22
 145 cgn                   print *,'.. filles de larete  : ',a21,a22
 146 cgn                   print *,'.. homologue de larete : ',arehom(larete)
 147 cgn                   endif
 148 c
 149             if ( larete.eq.areh ) then
 150 c
 151 c 2.2. ==> si on est sur l'axe : les deux aretes filles et le nouveau
 152 c          noeud sont homologues d'eux memes
 153 c          par convention, ils sont notes positifs.
 154 c
 155               if ( noehom(s2m).ne.0 ) then
 156                 if ( abs(noehom(s2m)).ne.s2m ) then
 157 c                 il y a un probleme : la table est deja remplie
 158                   write (ulsort,texte(langue,5)) mess14(langue,1,-1),
 159      >            s2m, mess14(langue,1,-1), s2m
 160                   write (ulsort,texte(langue,6))
 161                   write (ulsort,texte(langue,4)) s2m, noehom(s2m)
 162                   codret = 2
 163                 endif
 164               endif
 165 c
 166               noehom(s2m) = s2m
 167 c
 168               arehom(a21) = a21
 169               arehom(a22) = a22
 170 c
 171             else
 172 c
 173 c 2.3. ==> on n'est pas sur l'axe : il faut les entites liees a l'arete
 174 c          homologue, areh :
 175 c          . sommets de l'arete mere
 176 c          . les aretes filles
 177 c          . le nouveau noeud
 178 c
 179 c               s11        areh         s12
 180 c                x-----------.-----------x
 181 c                    a11    s1m    a12
 182 c
 183               s11 = somare(1,areh)
 184               s12 = somare(2,areh)
 185 c
 186               a11 = filare(areh)
 187               a12 = a11 + 1
 188 c
 189               s1m = somare(2,a11)
 190 c
 191 c           les 2 nouveaux noeuds sommets doivent etre homologues
 192 c           s2m est sur la meme face que "larete" c'est-a-dire la face 2
 193 c           donc noehom(s2m) est positif.
 194 c           s1m est sur l'autre face, donc noehom(s1m) est negatif
 195 c
 196               if ( noehom(s2m).ne.0 ) then
 197                 if ( abs(noehom(s2m)).ne.s1m ) then
 198 c                 il y a un probleme : la table est deja remplie
 199                   write (ulsort,texte(langue,5)) mess14(langue,1,-1),
 200      >            s1m, mess14(langue,1,-1), s2m
 201                   write (ulsort,texte(langue,6))
 202                   write (ulsort,texte(langue,4)) s1m, noehom(s1m)
 203                   write (ulsort,texte(langue,4)) s2m, noehom(s2m)
 204                   codret = 2
 205                 endif
 206               endif
 207 c
 208               noehom(s2m) = s1m
 209               noehom(s1m) = -s2m
 210 c
 211 c             on repere les homologues des aretes
 212 c             on utilise le fait que noehom(s21) > 0 car s21 est
 213 c             sur la face 2
 214 c
 215               if ( noehom(s21).eq.s11 ) then
 216 c
 217 c             la premiere fille de larete est homologue a
 218 c             la premiere fille de areh
 219 c
 220                 arehom(a21) = a11
 221                 arehom(a11) = -a21
 222                 arehom(a22) = a12
 223                 arehom(a12) = -a22
 224 c
 225               elseif ( noehom(s21).eq.s12 ) then
 226 c
 227 c             la premiere fille de larete est homologue a
 228 c             la deuxieme fille de areh
 229 c
 230                 arehom(a21) = a12
 231                 arehom(a11) = -a22
 232                 arehom(a22) = a11
 233                 arehom(a12) = -a21
 234 c
 235               else
 236 c             il y a un probleme : la correspondance sur les noeuds
 237 c             n'est pas coherente avec la correspondance sur les aretes
 238                 write (ulsort,texte(langue,5)) mess14(langue,1,1),
 239      >          larete, mess14(langue,1,1), areh
 240                 write (ulsort,texte(langue,7)) larete, s21, s22
 241                 write (ulsort,texte(langue,7)) areh, s11, s12
 242                 write (ulsort,texte(langue,4)) s21, noehom(s21)
 243                 write (ulsort,texte(langue,4)) s22, noehom(s22)
 244                 write (ulsort,texte(langue,4)) s11, noehom(s11)
 245                 write (ulsort,texte(langue,4)) s12, noehom(s12)
 246                 codret = 2
 247               endif
 248 c
 249             endif
 250 c
 251           endif
 252 c
 253         endif
 254 c
 255    21 continue
 256 c
 257 c====
 258 c 3. la fin
 259 c====
 260 c
 261       if ( codret.ne.0 ) then
 262 c
 263 #include "envex2.h"
 264 c
 265       write (ulsort,texte(langue,1)) 'Sortie', nompro
 266       write (ulsort,texte(langue,2)) codret
 267 c
 268       endif
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,1)) 'Sortie', nompro
 272       call dmflsh (iaux)
 273 #endif
 274 c
 275       end