src/tool/AV_Conversion/vcequa.F

   1       subroutine vcequa ( option,
   2      >                    arehom,
   3      >                    laret2, face2, face1,
   4      >                    trihom, quahom,
   5      >                    aretri, arequa,
   6      >                    posifa, facare,
   7      >                    ulsort, langue, codret)
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    aVant adaptation Conversion - EQUivalence - Arete
  29 c     -               -            ---           -
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . option . e   .    1   . variantes                                  .
  35 c .        .     .        .   2 : triangles                            .
  36 c .        .     .        .   4 : quadrangles                          .
  37 c . arehom . es  . nbarto . liste etendue des homologues par aretes    .
  38 c . laret2 . e   .    1   . numero global de l'arete de la face face2  .
  39 c . face2  . e   .    1   . numero global de la face sur la face 2     .
  40 c . face1  . e   .    1   . numero global de la face sur la face 1     .
  41 c . trihom . e   . nbtrto . ensemble des triangles homologues          .
  42 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
  43 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  46 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 1 : probleme                               .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'VCEQUA' )
  66 c
  67 #include "nblang.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 c
  73 #include "nombar.h"
  74 #include "nombtr.h"
  75 #include "nombqu.h"
  76 #include "impr02.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer option
  81       integer arehom(nbarto)
  82       integer laret2, face2, face1
  83       integer trihom(nbtrto), quahom(nbquto)
  84       integer aretri(nbtrto,3), arequa(nbquto,4)
  85       integer posifa(0:nbarto), facare(nbfaar)
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer laface, laret1, araux
  91       integer letria, lequad
  92       integer ideb, ifin
  93       integer iaux, jaux, kaux
  94 c
  95       logical afaire
  96 c
  97       integer nbmess
  98       parameter ( nbmess = 20 )
  99       character*80 texte(nblang,nbmess)
 100 c
 101 c 0.5. ==> initialisations
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 1. initialisations
 106 c====
 107 c
 108 c 1.1. ==> messages
 109 c
 110 #include "impr01.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,1)) 'Entree', nompro
 114       call dmflsh (iaux)
 115 #endif
 116 c
 117       texte(1,4) = '(''.. Examen de l''''arete'',i10,'' du '',a,i10)'
 118       texte(1,5) =
 119      >'(''Impossible de trouver l''''homologue de l''''arete'',i10)'
 120       texte(1,6) =
 121      >'(''... Examen de la face '',i10,'', voisine de l''''arete'',i10)'
 122       texte(1,7) = '(''... ==> Arete homologue de'',i10,'' :'',i10)'
 123       texte(1,8) = '(''.. Aretes du '',a,i10,'' :'',4i10)'
 124       texte(1,9) = '(/,''. Analyse des '',a,i10,'' et'',i10)'
 125       texte(1,10) = '(''.. L''''arete'',i10,'' est sur l''''axe.'')'
 126       texte(1,11) = '(''..... Rien a faire.'')'
 127       texte(1,20) = '(a,i10,'' est homologue du '',a,i10)'
 128 c
 129       texte(2,4) = '(''.. Examination of edge '',i10,'' of '',a,i10)'
 130       texte(2,5) =
 131      > '(''Homologous for edge #'',i10,''cannot be found.'')'
 132       texte(2,6) =
 133      > '(''... Examination of face '',i10,'', of edge '',i10)'
 134       texte(2,7) = '(''... ==> Homologous edge of'',i10,'' :'',i10)'
 135       texte(2,8) = '(''.. Edges of '',a,i10,'' :'',4i10)'
 136       texte(2,9) = '(/,''. Analysis of '',a,i10,'' and'',i10)'
 137       texte(2,10) = '(''.. Edge'',i10,'' is on the axis.'')'
 138       texte(2,11) = '(''..... No interest.'')'
 139       texte(2,20) =
 140      > '(a,''#'',i10,'' is homologous with '',a,''#'',i10)'
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143 cc      write (ulsort,texte(langue,9)) mess14(langue,3,option),
 144 cc     >                               face2, face1
 145       write (ulsort,texte(langue,4)) laret2, mess14(langue,1,option),
 146      >                               face2
 147       if ( option.eq.2 ) then
 148         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 149      >            face2, (aretri(face2,kaux), kaux = 1 , 3)
 150         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 151      >            face1, (aretri(face1,kaux), kaux = 1 , 3)
 152       else
 153         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 154      >            face2, (arequa(face2,kaux), kaux = 1 , 4)
 155         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 156      >            face1, (arequa(face1,kaux), kaux = 1 , 4)
 157       endif
 158 #endif
 159 c
 160 c 1.2. ==> on recherche l'arete laret1 de la face face1 qui est
 161 c          homologue de l'arete numero laret2 dans la face face2
 162 c          a priori, on n'a rien trouve
 163 c
 164       laret1 = 0
 165 c
 166 c====
 167 c 2. on commence par voir si l'arete laret2 n'appartiendrait pas
 168 c    aux deux faces. Cela veut dire qu'elle est sur l'axe
 169 c    si c'est le cas, on l'enregistre et c'est bon
 170 c====
 171 c
 172       if ( codret.eq.0 ) then
 173 c
 174       if ( option.eq.2 ) then
 175         do 21 , kaux = 1 , 3
 176           if ( laret2.eq.aretri(face1,kaux) ) then
 177             laret1 = laret2
 178           endif
 179    21   continue
 180       else
 181         do 22 , kaux = 1 , 4
 182           if ( laret2.eq.arequa(face1,kaux) ) then
 183             laret1 = laret2
 184           endif
 185    22   continue
 186       endif
 187 c
 188       if ( laret1.ne.0 ) then
 189         arehom(laret1) = laret1
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192         write (ulsort,texte(langue,10)) laret2
 193         write (ulsort,texte(langue,7)) laret2, laret1
 194 #endif
 195       endif
 196 c
 197       endif
 198 c
 199 c====
 200 c 3. quand l'arete laret2 n'est pas sur l'axe, on boucle sur toutes les
 201 c    faces qui possedent l'arete laret2 et on s'interesse a celles qui :
 202 c    . ne sont pas la face courante
 203 c    . ont une homologue
 204 c
 205 c    on cherche alors l'arete commune entre cette homologue et la
 206 c    face face1 : c'est celle a mettre en equivalence
 207 c    cela part du principe que les voisinages sont obligatoirement les
 208 c    memes sur les deux faces.
 209 c
 210 c====
 211 c
 212       if ( codret.eq.0 ) then
 213 c
 214       if ( laret1.eq.0 ) then
 215 c
 216       ideb = posifa(laret2-1)+1
 217       ifin = posifa(laret2)
 218 c
 219       do 30 , iaux = ideb , ifin
 220 c
 221         laface = facare(iaux)
 222 c
 223 #ifdef _DEBUG_HOMARD_
 224         write (ulsort,texte(langue,6)) laface, laret2
 225 #endif
 226 c
 227         afaire = .false.
 228 c
 229         if ( laface.gt.0 ) then
 230 c
 231 c 3.1. ==> laface est un triangle
 232 c          on poursuit s'il a un homologue et si ce n'est pas le
 233 c          triangle courant
 234 c
 235           letria = trihom(laface)
 236           if ( letria.ne.0 ) then
 237             if ( option.eq.4 ) then
 238               afaire = .true.
 239             else
 240               if ( laface.ne.face2 ) then
 241                 afaire = .true.
 242               endif
 243             endif
 244           endif
 245 c
 246           if ( afaire ) then
 247 c
 248 c           on cherche parmi les aretes de letria, situe sur la face 1,
 249 c           celle qui est commune au triangle homologue face1.
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,20)) '... '//mess14(langue,2,2),
 253      >          letria, mess14(langue,1,2), laface
 254       write (ulsort,texte(langue,8)) mess14(langue,1,2),
 255      >          letria, (aretri(letria,kaux), kaux = 1 , 3)
 256 #endif
 257             do 311 , jaux = 1 , 3
 258               araux = aretri(letria,jaux)
 259               if ( option.eq.2 ) then
 260                 do 312 , kaux = 1 , 3
 261                   if ( araux.eq.aretri(face1,kaux) ) then
 262                     if ( laret1.eq.0 ) then
 263                       laret1 = aretri(face1,kaux)
 264                     else
 265                       codret = 312
 266                     endif
 267                   endif
 268   312           continue
 269               else
 270                 do 313 , kaux = 1 , 4
 271                   if ( araux.eq.arequa(face1,kaux) ) then
 272                     if ( laret1.eq.0 ) then
 273                       laret1 = arequa(face1,kaux)
 274                     else
 275                       codret = 313
 276                     endif
 277                   endif
 278   313           continue
 279               endif
 280   311       continue
 281 c
 282           endif
 283 c
 284 c 3.2. ==> laface est un quadrangle
 285 c          on poursuit s'il a un homologue et si ce n'est pas le
 286 c          quadrangle courant
 287 c
 288         else
 289 c
 290           lequad = abs(quahom(abs(laface)))
 291           if ( lequad.ne.0 ) then
 292             if ( option.eq.2 ) then
 293               afaire = .true.
 294             else
 295               if ( abs(laface).ne.face2 ) then
 296                 afaire = .true.
 297               endif
 298             endif
 299           endif
 300 c
 301           if ( afaire ) then
 302 c
 303 c           on cherche parmi les aretes de lequad, situe sur la face 1,
 304 c           celle qui est commune au quadrangle homologue face1.
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,texte(langue,20)) '... '//mess14(langue,2,4),
 308      >          lequad, mess14(langue,1,4), abs(laface)
 309       write (ulsort,texte(langue,8)) mess14(langue,1,4),
 310      >          lequad, (arequa(lequad,kaux), kaux = 1 , 4)
 311 #endif
 312             do 321 , jaux = 1 , 4
 313               araux = arequa(lequad,jaux)
 314               if ( option.eq.2 ) then
 315                 do 322 , kaux = 1 , 3
 316                   if ( araux.eq.aretri(face1,kaux) ) then
 317                     if ( laret1.eq.0 ) then
 318                       laret1 = aretri(face1,kaux)
 319                     else
 320                       codret = 322
 321                     endif
 322                   endif
 323   322           continue
 324               else
 325                 do 323 , kaux = 1 , 4
 326                   if ( araux.eq.arequa(face1,kaux) ) then
 327                     if ( laret1.eq.0 ) then
 328                       laret1 = arequa(face1,kaux)
 329                     else
 330                       codret = 323
 331                     endif
 332                   endif
 333   323           continue
 334               endif
 335   321       continue
 336 c
 337 #ifdef _DEBUG_HOMARD_
 338           else
 339              write (ulsort,texte(langue,11))
 340 #endif
 341           endif
 342 c
 343         endif
 344 c
 345    30 continue
 346 c
 347 c 3.3. ==> enregistrement
 348 c          par construction, laret1 est sur la face 1 et laret2 sur
 349 c          la face 2 ; d'ou les signes dans arehom
 350 c
 351       if ( laret1.ne.0 ) then
 352 #ifdef _DEBUG_HOMARD_
 353         write (ulsort,texte(langue,7)) laret2, laret1
 354 #endif
 355         arehom(laret2) =   laret1
 356         arehom(laret1) = - laret2
 357       else
 358         codret = 5
 359       endif
 360 c
 361       endif
 362 c
 363       endif
 364 c
 365 c====
 366 c 4. la fin
 367 c====
 368 c
 369       if ( codret.ne.0 ) then
 370 c
 371 #include "envex2.h"
 372 c
 373       write (ulsort,texte(langue,1)) 'Sortie', nompro
 374       write (ulsort,texte(langue,2)) codret
 375       write (ulsort,texte(langue,20)) mess14(langue,2,option), face1,
 376      >                                mess14(langue,1,option), face2
 377       if ( option.eq.2 ) then
 378         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 379      >            face2, (aretri(face2,kaux), kaux = 1 , 3)
 380         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 381      >            face1, (aretri(face1,kaux), kaux = 1 , 3)
 382       else
 383         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 384      >            face2, (arequa(face2,kaux), kaux = 1 , 4)
 385         write (ulsort,texte(langue,8)) mess14(langue,1,option),
 386      >            face1, (arequa(face1,kaux), kaux = 1 , 4)
 387       endif
 388       write (ulsort,texte(langue,5)) laret2
 389 c
 390       endif
 391 c
 392 #ifdef _DEBUG_HOMARD_
 393       write (ulsort,texte(langue,1)) 'Sortie', nompro
 394       call dmflsh (iaux)
 395 #endif
 396 c
 397       end