src/tool/AV_Conversion/vcequ6.F

   1       subroutine vcequ6 ( option,
   2      >                    noehom, arehom,
   3      >                    trihom, quahom,
   4      >                    somare, aretri, arequa,
   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 6
  27 c     -               -            ---                 -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . option . e   .    1   . variantes                                  .
  33 c .        .     .        .   2 : triangles                            .
  34 c .        .     .        .   4 : quadrangles                          .
  35 c . noehom . es  . nbnoto . liste etendue des homologues par noeuds    .
  36 c . arehom . es  . nbarto . liste etendue des homologues par aretes    .
  37 c . trihom . e   . nbtrto . ensemble des triangles homologues          .
  38 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
  39 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  40 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  41 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  42 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  43 c . langue . e   .    1   . langue des messages                        .
  44 c .        .     .        . 1 : francais, 2 : anglais                  .
  45 c . codret . es  .    1   . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c .        .     .        . 1 : probleme                               .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59       character*6 nompro
  60       parameter ( nompro = 'VCEQU6' )
  61 c
  62 #include "nblang.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "nombno.h"
  69 #include "nombar.h"
  70 #include "nombtr.h"
  71 #include "nombqu.h"
  72 #include "impr02.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       integer option
  77       integer noehom(nbnoto), arehom(nbarto)
  78       integer trihom(nbtrto), quahom(nbquto)
  79       integer somare(2,nbarto)
  80       integer aretri(nbtrto,3), arequa(nbquto,4)
  81       integer ulsort, langue, codret
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85       integer entlo2, entlo1
  86       integer aretea(2), areteb(2)
  87       integer na(2), nb(2), nc(2)
  88       integer nbento, nbaret
  89       integer iaux, jaux, kaux
  90       integer iaux1, iaux2, iaux3, iaux4
  91 c
  92       integer nbmess
  93       parameter ( nbmess = 10 )
  94       character*80 texte(nblang,nbmess)
  95 c
  96 c 0.5. ==> initialisations
  97 c ______________________________________________________________________
  98 c
  99 c====
 100 c 1. initialisations
 101 c====
 102 c
 103 c 1.1. ==> messages
 104 c
 105 #include "impr01.h"
 106 c
 107 #ifdef _DEBUG_HOMARD_
 108       write (ulsort,texte(langue,1)) 'Entree', nompro
 109       call dmflsh (iaux)
 110 #endif
 111 c
 112       texte(1,4) = '(''Cote'',i2,'' : aretes'',i10,'' et'',i10)'
 113       texte(1,5) = '(''Arete'',i10,'' de'',i10,'' a'',i10)'
 114       texte(1,6) = '(''Noeud'',i10,'' sans homologue ?'')'
 115       texte(1,7) = '(a,i10,'' : est homologue de'',i10)'
 116       texte(1,8) =
 117      > '(''Les noeuds'',i10,'' et'',i10,'' devraient etre homologues'')'
 118       texte(1,9) = '(''.. Aretes du '',a,i10,'' :'',4i10)'
 119       texte(1,10) = '(/,''. Analyse des '',a,i10,'' et'',i10)'
 120 c
 121       texte(2,4) = '(''Face'',i2,'' : edges'',i10,'' and'',i10)'
 122       texte(2,5) = '(''Edge'',i10,'' from'',i10,'' to'',i10)'
 123       texte(2,6) = '(''Node'',i10,'' without any homologous ?'')'
 124       texte(2,7) = '(a,i10,'' : is homologous with'',i10)'
 125       texte(2,8) =
 126      > '(''Nodes'',i10,'' and'',i10,'' should be homologous'')'
 127       texte(2,9) = '(''.. Edges of '',a,i10,'' :'',4i10)'
 128       texte(2,10) = '(/,''. Analysis of '',a,i10,'' and'',i10)'
 129 c
 130       codret = 0
 131 c
 132 c====
 133 c 2. enrichissement de la structure sur les aretes a partir de la
 134 c    donnee des faces homologues
 135 c    ici, on traite les faces qui sont dans un coin de maillage.
 136 c    Autrement dit, il doit leur rester deux aretes sans homologues et
 137 c    qui se suivent :
 138 c
 139 c                X                     X----------------O
 140 c                ..                    .                .
 141 c                . .                   .                .
 142 c                .  .                  .                .
 143 c                .   .        ou       .                . OK
 144 c                .    .                .                .
 145 c                .     .               .                .
 146 c                .      .              .                .
 147 c                O-------O             O----------------O
 148 c                   OK                          OK
 149 c    on va rapprocher les aretes en comparant les noeuds homologues O.
 150 c    on en profitera pour enregistrer le dernier noeud X.
 151 c====
 152 c
 153       if ( option.eq.2 ) then
 154         nbento = nbtrto
 155         nbaret = 3
 156       else
 157         nbento = nbquto
 158         nbaret = 4
 159       endif
 160 c
 161       do 21 , entlo2 = 1 , nbento
 162 c
 163         if ( codret.eq.0 ) then
 164 c
 165         if ( option.eq.2 ) then
 166           entlo1 = trihom(entlo2)
 167         else
 168           entlo1 = quahom(entlo2)
 169         endif
 170 c
 171 c      on boucle uniquement sur les faces de la face periodique 2
 172 c
 173         if ( entlo1.gt.0 ) then
 174 c
 175 #ifdef _DEBUG_HOMARD_
 176           write (ulsort,texte(langue,10)) mess14(langue,3,option),
 177      >                                    entlo2, entlo1
 178 #endif
 179 c
 180 c 2.1. ==> reperage des deux aretes non encore enregistrees, sur
 181 c          chacun des cotes.
 182 c
 183           if ( codret.eq.0 ) then
 184 c
 185           do 211 , iaux = 1 , 2
 186 c
 187             aretea(iaux) = 0
 188             areteb(iaux) = 0
 189             if ( iaux.eq.1 ) then
 190               kaux = entlo1
 191             else
 192               kaux = entlo2
 193             endif
 194 #ifdef _DEBUG_HOMARD_
 195             if ( option.eq.2 ) then
 196               write (ulsort,texte(langue,9)) mess14(langue,1,option),
 197      >        kaux, (aretri(kaux,jaux), jaux = 1 , nbaret)
 198             else
 199               write (ulsort,texte(langue,9)) mess14(langue,1,option),
 200      >        kaux, (arequa(kaux,jaux), jaux = 1 , nbaret)
 201             endif
 202 #endif
 203 c
 204             do 212 , jaux = 1 , nbaret
 205 c
 206               iaux2 = 0
 207               if ( option.eq.2 ) then
 208                 if ( arehom(aretri(kaux,jaux)).eq.0 ) then
 209                   iaux2 = aretri(kaux,jaux)
 210                 endif
 211               else
 212                 if ( arehom(arequa(kaux,jaux)).eq.0 ) then
 213                   iaux2 = arequa(kaux,jaux)
 214                 endif
 215               endif
 216               if ( iaux2.ne.0 ) then
 217                 if ( aretea(iaux).eq.0 ) then
 218                   aretea(iaux) = iaux2
 219                 else
 220                   areteb(iaux) = iaux2
 221                 endif
 222               endif
 223 c
 224   212       continue
 225 c
 226   211     continue
 227 c
 228           if ( areteb(1).eq.0 .and. areteb(2).eq.0 ) then
 229             goto 21
 230           endif
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233           write (ulsort,texte(langue,4)) 1, aretea(1), areteb(1)
 234           write (ulsort,texte(langue,4)) 2, aretea(2), areteb(2)
 235 #endif
 236 c
 237           endif
 238 c
 239 c 2.2. ==> pour chaque cote, on repere les deux noeuds extremites
 240 c          et le noeud central
 241 c
 242 c              0----------------------X----------------------0
 243 c            NA(i)    aretea(i)     NB(i)    areteb(i)     NC(i)
 244 c
 245           if ( codret.eq.0 ) then
 246 c
 247           do 221 , iaux = 1 , 2
 248 c
 249             iaux1 = somare(1,aretea(iaux))
 250             iaux2 = somare(2,aretea(iaux))
 251             iaux3 = somare(1,areteb(iaux))
 252             iaux4 = somare(2,areteb(iaux))
 253 c
 254             if ( iaux1.eq.iaux3 ) then
 255               na(iaux) = iaux2
 256               nb(iaux) = iaux1
 257               nc(iaux) = iaux4
 258             elseif ( iaux1.eq.iaux4 ) then
 259               na(iaux) = iaux2
 260               nb(iaux) = iaux1
 261               nc(iaux) = iaux3
 262             elseif ( iaux2.eq.iaux3 ) then
 263               na(iaux) = iaux1
 264               nb(iaux) = iaux2
 265               nc(iaux) = iaux4
 266             elseif ( iaux2.eq.iaux4 ) then
 267               na(iaux) = iaux1
 268               nb(iaux) = iaux2
 269               nc(iaux) = iaux3
 270             else
 271               write (ulsort,texte(langue,5)) aretea(iaux), iaux1, iaux2
 272               write (ulsort,texte(langue,5)) areteb(iaux), iaux3, iaux4
 273               codret = 3
 274             endif
 275 c
 276   221     continue
 277 c
 278           endif
 279 c
 280 c 2.3. ==> on repere les homologues
 281 c
 282 c              0----------------------X----------------------0
 283 c            NA(i)    aretea(i)     NB(i)    areteb(i)     NC(i)
 284 c
 285           if ( codret.eq.0 ) then
 286 c
 287 c 2.3.1. ==> mise en equivalence des aretes
 288 c
 289           if ( abs(noehom(na(1))).eq.na(2) ) then
 290 c
 291             if ( abs(noehom(nc(1))).eq.nc(2) ) then
 292               iaux1 = aretea(2)
 293               iaux2 = areteb(2)
 294             else
 295               write (ulsort,texte(langue,7)) mess14(langue,2,-1),
 296      >                                       na(1), na(2)
 297               write (ulsort,texte(langue,8)) nc(1), nc(2)
 298               codret = 5
 299             endif
 300 c
 301           elseif ( abs(noehom(na(1))).eq.nc(2) ) then
 302 c
 303             if ( abs(noehom(nc(1))).eq.na(2) ) then
 304               iaux1 = areteb(2)
 305               iaux2 = aretea(2)
 306             else
 307               write (ulsort,texte(langue,7)) mess14(langue,2,-1),
 308      >                                       na(1), nc(2)
 309               write (ulsort,texte(langue,8)) nc(1), na(2)
 310               codret = 5
 311             endif
 312 c
 313           else
 314 c
 315             write (ulsort,texte(langue,6)) na(1)
 316             codret = 5
 317 c
 318           endif
 319 c
 320           endif
 321 c
 322           if ( codret.eq.0 ) then
 323 c
 324           arehom(aretea(1)) = -iaux1
 325           arehom(areteb(1)) = -iaux2
 326           arehom(iaux1) = aretea(1)
 327           arehom(iaux2) = areteb(1)
 328 c
 329 #ifdef _DEBUG_HOMARD_
 330           write (ulsort,texte(langue,7)) mess14(langue,2,1),
 331      >                                   iaux1, aretea(1)
 332           write (ulsort,texte(langue,7)) mess14(langue,2,1),
 333      >                                   iaux2, areteb(1)
 334 #endif
 335 c
 336           endif
 337 c
 338 c 2.3.2. ==> mise en equivalence du noeud central
 339 c
 340           if ( codret.eq.0 ) then
 341 c
 342           if ( noehom(nb(1)).eq.0 .and. noehom(nb(2)).eq.0 ) then
 343 c
 344             noehom(nb(1)) = -nb(2)
 345             noehom(nb(2)) = nb(1)
 346 c
 347           else
 348 c
 349             if ( noehom(nb(1)).ne.-nb(2) ) then
 350               write (ulsort,texte(langue,7)) mess14(langue,2,-1),
 351      >                                       nb(1), noehom(nb(1))
 352               write (ulsort,texte(langue,8)) nb(1), nb(2)
 353               codret = 5
 354             endif
 355 c
 356           endif
 357 c
 358           endif
 359 c
 360         endif
 361 c
 362         endif
 363 c
 364    21 continue
 365 c
 366 c====
 367 c 3. la fin
 368 c====
 369 c
 370       if ( codret.ne.0 ) then
 371 c
 372 #include "envex2.h"
 373 c
 374       write (ulsort,texte(langue,1)) 'Sortie', nompro
 375       write (ulsort,texte(langue,2)) codret
 376 c
 377       endif
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,texte(langue,1)) 'Sortie', nompro
 381       call dmflsh (iaux)
 382 #endif
 383 c
 384       end