src/tool/AV_Conversion/vcequ5.F

   1       subroutine vcequ5 ( entlo1, entlo2,
   2      >                    noehom, arehom,
   3      >                    somare, np2are,
   4      >                    povoso, voisom,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    aVant adaptation Conversion - EQUivalence - phase 5
  27 c     -               -            ---                 -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . entlo1 . e   .   1    . numero de l'arete sur la face 1            .
  33 c . entlo2 . e   .   1    . numero de l'arete sur la face 2            .
  34 c . noehom . es  . nbnoto . liste etendue des homologues par noeuds    .
  35 c . arehom . es  . nbarto . liste etendue des homologues par aretes    .
  36 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  37 c . np2are . e   . nbarto . numero du noeud milieu de l'arete          .
  38 c . povoso . e   .0:nbnoto. pointeur des voisins par sommet            .
  39 c . voisom . e   . nvosom . elements 1d, 2d ou 3d voisins par sommet   .
  40 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c .        .     .        . 1 : probleme                               .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57       character*6 nompro
  58       parameter ( nompro = 'VCEQU5' )
  59 c
  60 #include "nblang.h"
  61 c
  62 c 0.2. ==> communs
  63 c
  64 #include "envex1.h"
  65 c
  66 #include "nombno.h"
  67 #include "nombar.h"
  68 #include "nbutil.h"
  69 #include "envca1.h"
  70 #include "impr02.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer entlo1, entlo2
  75       integer noehom(nbnoto), arehom(nbarto)
  76       integer somare(2,nbarto), np2are(nbarto)
  77       integer povoso(0:nbnoto), voisom(nvosom)
  78       integer ulsort, langue, codret
  79 c
  80 c 0.4. ==> variables locales
  81 c
  82       integer entab2
  83       integer iaux, jaux, nbrhom, ndaux
  84       integer iaux1, iaux2
  85 c
  86       integer nbmess
  87       parameter ( nbmess = 10 )
  88       character*80 texte(nblang,nbmess)
  89 c
  90 c 0.5. ==> initialisations
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 1. initialisations
  95 c====
  96 c
  97 c 1.1. ==> messages
  98 c
  99 #include "impr01.h"
 100 c
 101 #ifdef _DEBUG_HOMARD_
 102       write (ulsort,texte(langue,1)) 'Entree', nompro
 103       call dmflsh (iaux)
 104 #endif
 105 c
 106       texte(1,4) = '(''Il devrait l''''etre aussi de'',i10,'' ?'')'
 107       texte(1,5) = '(''Infos donnees en numerotation HOMARD :'')'
 108       texte(1,6) = '(a,i10,'' : est homologue de'',i10)'
 109       texte(1,7) =
 110      > '(''. Noeuds homologues de l''''arete'',i10,'' :'',i2,''/2'')'
 111 c
 112       texte(2,4) = '(''It also should be with #'',i10)'
 113       texte(2,5) = '(''Infos given with HOMARD # :'')'
 114       texte(2,6) = '(a,i10,'' : is homologous with'',i10)'
 115       texte(2,7) =
 116      > '(''. Homologous nodes of edge'',i10,'' :'',i2,''/2'')'
 117 c
 118       codret = 0
 119 c
 120 c====
 121 c 2. definir ou completer les relations d'equivalence entre les noeuds
 122 c    lies a une paire d'aretes
 123 c====
 124 c
 125       entab2 = abs(entlo2)
 126 c
 127 c 2.1. ==> decompte du nombre de noeuds homologues eventuels deja
 128 c          enregistrees
 129 c
 130       if ( codret.eq.0 ) then
 131 c
 132       nbrhom = 0
 133       do 211 , iaux = 1 , 2
 134         ndaux = abs(noehom(somare(iaux,entlo1)))
 135         do 212 , jaux = 1 , 2
 136 c
 137           if ( ndaux.eq.somare(jaux,entab2) ) then
 138             nbrhom = nbrhom + 1
 139           endif
 140 c
 141   212   continue
 142   211 continue
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,texte(langue,7)) entlo1, nbrhom
 146 #endif
 147 c
 148       endif
 149 c
 150 c 2.2. ==> si aucun noeud n'a d'homologue : on met en relation celui qui
 151 c          limite une autre arete homologue avec celui qui lui
 152 c          correspond dans l'arete homologue.
 153 c          le second noeud est traite en 2.3.
 154 c
 155        if ( codret.eq.0 ) then
 156 c
 157        if ( nbrhom.eq.0 ) then
 158 c
 159          call vcequn ( entlo1, entlo2,
 160      >                 noehom, arehom,
 161      >                 somare, povoso, voisom,
 162      >                 ulsort, langue, codret)
 163 c
 164          nbrhom = 1
 165 c
 166        endif
 167 c
 168        endif
 169 c
 170 c 2.3. ==> s'il reste un seul noeud sans homologue : on le met
 171 c          en equivalence avec son semblable sur l'autre arete
 172 c
 173       if ( codret.eq.0 ) then
 174 c
 175       if ( nbrhom.le.1 ) then
 176 c
 177         iaux1 = 0
 178         iaux2 = 0
 179         do 231 , iaux = 1 , 2
 180           if ( noehom(somare(iaux,entlo1)).eq.0 ) then
 181             iaux1 = iaux
 182           endif
 183           if ( noehom(somare(iaux,entab2)).eq.0 ) then
 184             iaux2 = iaux
 185           endif
 186   231   continue
 187 c
 188         if ( iaux1.ne.0 .and. iaux2.ne.0 ) then
 189           noehom(somare(iaux1,entlo1)) = - somare(iaux2,entab2)
 190           noehom(somare(iaux2,entab2)) = somare(iaux1,entlo1)
 191         else
 192           codret = 3
 193         endif
 194 c
 195       endif
 196 c
 197       endif
 198 c
 199 c 2.4. ==> on verifie qu'il ne reste plus aucun noeud sans son
 200 c          homologue
 201 c
 202       if ( codret.eq.0 ) then
 203 c
 204       if ( nbrhom.ne.2 ) then
 205 c
 206         nbrhom = 0
 207         do 241 , iaux = 1 , 2
 208           ndaux = abs(noehom(somare(iaux,entlo1)))
 209           do 242 , jaux = 1 , 2
 210 c
 211             if ( ndaux.eq.somare(jaux,entab2) ) then
 212               nbrhom = nbrhom + 1
 213             endif
 214 c
 215   242     continue
 216   241   continue
 217 c
 218         if ( nbrhom.ne.2 ) then
 219           codret = 3
 220         endif
 221 c
 222       endif
 223 c
 224       endif
 225 c
 226 c 2.5. ==> en degre 2, on associe les deux noeuds milieux si ce n'est
 227 c          pas deja fait
 228 c
 229       if ( codret.eq.0 ) then
 230 c
 231       if ( degre.eq.2 ) then
 232 c
 233         if ( noehom(np2are(entlo1)).eq.0 ) then
 234           noehom(np2are(entlo1)) = np2are(entab2)
 235         else
 236           if ( abs(noehom(np2are(entlo1))).ne.np2are(entab2) ) then
 237             write (ulsort,texte(langue,6)) mess14(langue,2,-1),
 238      >                   np2are(entlo1), noehom(np2are(entlo1))
 239             write (ulsort,texte(langue,4)) np2are(entab2)
 240             write (ulsort,texte(langue,5))
 241             codret = 5
 242           endif
 243         endif
 244 c
 245         if ( noehom(np2are(entab2)).eq.0 ) then
 246           noehom(np2are(entab2)) = np2are(entlo1)
 247         else
 248           if ( abs(noehom(np2are(entab2))).ne.np2are(entlo1) ) then
 249             write (ulsort,texte(langue,6)) mess14(langue,2,-1),
 250      >                   np2are(entab2), noehom(np2are(entab2))
 251             write (ulsort,texte(langue,4)) np2are(entlo1)
 252             write (ulsort,texte(langue,5))
 253             codret = 5
 254           endif
 255         endif
 256 c
 257       endif
 258 c
 259       endif
 260 c
 261 c====
 262 c 3. la fin
 263 c====
 264 c
 265       if ( codret.ne.0 ) then
 266 c
 267 #include "envex2.h"
 268 c
 269       write (ulsort,texte(langue,1)) 'Sortie', nompro
 270       write (ulsort,texte(langue,2)) codret
 271 c
 272       endif
 273 c
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,texte(langue,1)) 'Sortie', nompro
 276       call dmflsh (iaux)
 277 #endif
 278 c
 279       end