src/tool/Suivi_Frontiere/sftqtr.F

   1       subroutine sftqtr ( bilan, bascul,
   2      >                    lenoeu, larete, letria,
   3      >                    coonoe,
   4      >                    somare, filare, np2are,
   5      >                    hettri, aretri,
   6      >                    ulsort, langue, codret)
   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   Suivi de Frontiere - Test Qualite - TRiangle
  27 c   -        -           -    -         --
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . bilan  .   s .   1    . bilan du controle de l'arete               .
  33 c .        .     .        . 0 : pas de probleme                        .
  34 c .        .     .        . 1 : probleme                               .
  35 c . bascul .   s .    1   . vrai pour une bascule d'arete              .
  36 c . lenoeu . e   .    1   . noeud en cours d'examen                    .
  37 c . larete . e   .    1   . arete en cours d'examen                    .
  38 c . letria . e   .    1   . triangle en cours d'examen                 .
  39 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  40 c .        .     . *sdim  .                                            .
  41 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  42 c . filare . e   . nbarto . premiere fille des aretes                  .
  43 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  44 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  45 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  47 c . langue . e   .    1   . langue des messages                        .
  48 c .        .     .        . 1 : francais, 2 : anglais                  .
  49 c . codret . es  .    1   . code de retour des modules                 .
  50 c .        .     .        . 0 : pas de probleme                        .
  51 c .        .     .        . x : probleme                               .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'SFTQTR' )
  65 c
  66       double precision rapqmx
  67       parameter ( rapqmx = 5.0d0 )
  68 c
  69 #include "nblang.h"
  70 c
  71 c 0.2. ==> communs
  72 c
  73 #include "envex1.h"
  74 #include "envca1.h"
  75 c
  76 #include "nombno.h"
  77 #include "nombar.h"
  78 #include "nombtr.h"
  79 #include "impr02.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer bilan
  84 c
  85       logical bascul
  86 c
  87       integer lenoeu, larete, letria
  88 c
  89       double precision coonoe(nbnoto,sdim)
  90 c
  91       integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
  92       integer hettri(nbtrto), aretri(nbtrto,3)
  93 c
  94       integer ulsort, langue, codret
  95 c
  96 c 0.4. ==> variables locales
  97 c
  98       integer iaux
  99       integer a1, a2, a3
 100       integer sa1a2, sa2a3, sa3a1
 101       integer sn, sp, sq
 102       integer np, nq
 103       integer arep, areq
 104       integer etat
 105 c
 106       double precision coopro(3)
 107       double precision conotr(3,3)
 108       double precision v1(3), v2(3), v3(3)
 109       double precision quaper
 110       double precision quafi1, quafi2, quafi3, quafi5, quafi6
 111       double precision daux1, daux2
 112 c
 113       logical memeco
 114 c
 115       integer nbmess
 116       parameter ( nbmess = 10 )
 117       character*80 texte(nblang,nbmess)
 118 c
 119 c 0.5. ==> initialisations
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. initialisations
 124 c====
 125 c
 126 #include "impr01.h"
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,1)) 'Entree', nompro
 130       call dmflsh (iaux)
 131 #endif
 132 c
 133 c 1.1. ==> messages
 134 c
 135       texte(1,4) = '(''Aretes du triangle'',i10'' :'',3i10)'
 136       texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)'
 137 c
 138       texte(2,4) = '(''Edges of triangle #'',i10'' :'',3i10)'
 139       texte(2,5) = '(''Cancellation of BF for node # : '',i10)'
 140 c
 141  1000 format('... ',a,' :',3g13.5)
 142  1001 format('... ',a,' :',i10,', ',3g13.5)
 143  1002 format('... Test du ',a,' :',4i10)
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,1002) mess14(langue,1,-1), lenoeu
 147       write (ulsort,1001) 'n', lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim)
 148       write (ulsort,1002) mess14(langue,1, 1), larete
 149       write (ulsort,1002) mess14(langue,1, 2), letria
 150 #endif
 151 c
 152 c 1.2. ==> Tout va bien a priori
 153 c
 154       bilan = 0
 155 c
 156       codret = 0
 157 c
 158 c====
 159 c 2. Reperage des caracteristiques du triangle pere
 160 c====
 161 c 2.1. ==> Reperage local des aretes
 162 c
 163       a1 = aretri(letria,1)
 164       a2 = aretri(letria,2)
 165       a3 = aretri(letria,3)
 166 c
 167 #ifdef _DEBUG_HOMARD_
 168       write (ulsort,texte(langue,4)) letria, a1, a2, a3
 169 #endif
 170 c
 171 c 2.2. ==> Recherche des sommets
 172 c                          sa2a3
 173 c                            *
 174 c                           . .
 175 c                          .   .
 176 c                         .     .
 177 c                     a3 .       . a2
 178 c                       .         .
 179 c                      .           .
 180 c                     .             .
 181 c               sa3a1*---------------*sa1a2
 182 c                           a1
 183 c
 184       call utsotr ( somare, a1, a2, a3,
 185      >              sa1a2, sa2a3, sa3a1 )
 186 c
 187       if ( larete.eq.a1 ) then
 188         sp = sa1a2
 189         sq = sa3a1
 190         sn = sa2a3
 191         arep = a3
 192         areq = a2
 193       elseif ( larete.eq.a2 ) then
 194         sp = sa2a3
 195         sq = sa1a2
 196         sn = sa3a1
 197         arep = a1
 198         areq = a3
 199       elseif ( larete.eq.a3 ) then
 200         sp = sa3a1
 201         sq = sa2a3
 202         sn = sa1a2
 203         arep = a2
 204         areq = a1
 205       else
 206         codret = 12
 207       endif
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,1001) 'sp', sp, (coonoe(sp,iaux),iaux=1,sdim)
 210       write (ulsort,1001) 'sq', sq, (coonoe(sq,iaux),iaux=1,sdim)
 211       write (ulsort,1001) 'sn', sn, (coonoe(sn,iaux),iaux=1,sdim)
 212       write (ulsort,1001) 'arep', arep
 213       write (ulsort,1001) 'areq', areq
 214 #endif
 215 c
 216 c 2.3. ==> Autres caracteristiques
 217 c          . Qualite du triangle de depart
 218 c          . Coordonnees du noeud sur la frontiere
 219 c          . Etat
 220 c
 221       if ( codret.eq.0 ) then
 222 c
 223       do 23 , iaux = 1 , sdim
 224         conotr(1,iaux) = coonoe(sp,iaux)
 225         conotr(2,iaux) = coonoe(sq,iaux)
 226         conotr(3,iaux) = coonoe(sn,iaux)
 227         coopro(iaux)   = coonoe(lenoeu,iaux)
 228    23 continue
 229 cgn      write (ulsort,1001) 'n ', lenoeu, (coopro(iaux),iaux = 1 ,sdim)
 230 cgn      write (ulsort,1002) 'triangle pere', sp, sq, sn
 231       call utqtr0 ( quaper, daux2, sdim, conotr )
 232 cgn      write (ulsort,1000) 'Qualite pere  ', quaper
 233 cgn      write (ulsort,1000) 'Surface pere  ', daux2
 234 c
 235       etat = mod(hettri(letria),10)
 236 c
 237       endif
 238 c
 239 c====
 240 c 3. Test de qualite du decoupage standard
 241 c====
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret
 244 #endif
 245 c
 246       if ( etat.eq.4 .or. typsfr.gt.2 ) then
 247 c
 248         if ( codret.eq.0 ) then
 249 c
 250 c                             larete
 251 c       sp                    lenoeu                      sq
 252 c        .-----------------------.-----------------------.
 253 c         .                     . .                     .
 254 c          .                   .   .                   .
 255 c           .                 .     .                 .
 256 c            .    Fils1      .       .     Fils3     .
 257 c             .             .         .             .
 258 c              .           .           .           .
 259 c               .         .             .         .
 260 c                .       .     Fils2     .       .
 261 c                 .     .                 .     .
 262 c                  .   .                   .   .
 263 c           areq    . .                     . .   arep
 264 c                    .-----------------------.
 265 c                 nq  .                     . np
 266 c                      .                   .
 267 c                       .                 .
 268 c                        .     Fils4     .
 269 c                         .             .
 270 c                          .           .
 271 c                           .         .
 272 c                            .       .
 273 c                             .     .
 274 c                              .   .
 275 c                               . .
 276 c                                .
 277 c                               sn
 278 c
 279 c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas
 280 c          le segment np/nq
 281 c
 282         if ( typsfr.le.2 ) then
 283           np = somare(2,filare(arep))
 284           nq = somare(2,filare(areq))
 285         else
 286           np = np2are(arep)
 287           nq = np2are(areq)
 288         endif
 289 cgn      write (ulsort,1001) 'np', np, (coonoe(np,iaux),iaux = 1 ,sdim)
 290 cgn      write (ulsort,1001) 'nq', nq, (coonoe(nq,iaux),iaux = 1 ,sdim)
 291 c
 292         do 31 , iaux = 1 , sdim
 293           v1(iaux) = coonoe(np,iaux)
 294           v2(iaux) = coonoe(nq,iaux)
 295           v3(iaux) = conotr(1,iaux)
 296    31   continue
 297 c
 298         iaux = 0
 299         if ( sdim.eq.2 ) then
 300           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 301         else
 302           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 303 c                               np  nq  sp  N
 304         endif
 305 cgn      write (ulsort,*) 'Du bon cote de np/nq :', memeco
 306 c
 307         if ( .not. memeco ) then
 308           bilan = 1
 309           goto 50
 310         endif
 311 c
 312 c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas
 313 c          le segment sp/nq
 314 c
 315         do 32 , iaux = 1 , sdim
 316           v1(iaux) = conotr(2,iaux)
 317    32   continue
 318 c
 319         iaux = 0
 320         if ( sdim.eq.2 ) then
 321           call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
 322         else
 323           call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
 324         endif
 325 c                               sp  nq  sq  N
 326 cgn      write (ulsort,*) 'Du bon cote de sp/sn :', memeco
 327 c
 328         if ( .not. memeco ) then
 329           bilan = 1
 330           goto 50
 331         endif
 332 c
 333 c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas
 334 c          le segment sq/np
 335 c
 336         do 33 , iaux = 1 , sdim
 337           v2(iaux) = coonoe(np,iaux)
 338    33   continue
 339 c
 340         iaux = 0
 341         if ( sdim.eq.2 ) then
 342           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 343         else
 344           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 345         endif
 346 c                               sq  np  sp  N
 347 cgn      write (ulsort,*) 'Du bon cote de sq/sn :', memeco
 348 c
 349         if ( .not. memeco ) then
 350           bilan = 1
 351           goto 50
 352         endif
 353 c
 354 c 3.4. ==> Qualites des fils avec le noeud deplace
 355 c 3.4.1. ==> Les triangles de cote
 356 c
 357         do 3411 , iaux = 1 , sdim
 358           conotr(2,iaux) = coonoe(nq,iaux)
 359           conotr(3,iaux) = coopro(iaux)
 360  3411   continue
 361 cgn        write (ulsort,1002) 'triangle fils 1', sp, nq, lenoeu
 362         call utqtr0 ( quafi1, daux2, sdim, conotr )
 363 cgn        write (ulsort,1000) 'Qualite fils 1', quafi1
 364 cgn        write (ulsort,1000) 'Surface fils 1', daux1
 365 c
 366         do 3412 , iaux = 1 , sdim
 367           conotr(1,iaux) = coonoe(sq,iaux)
 368           conotr(2,iaux) = coonoe(np,iaux)
 369  3412   continue
 370 cgn        write (ulsort,1002) 'triangle fils 3', sq, np, lenoeu
 371         call utqtr0 ( quafi3, daux2, sdim, conotr )
 372 cgn        write (ulsort,1000) 'Qualite fils 3', quafi3
 373 cgn        write (ulsort,1000) 'Surface fils 3', daux1
 374 c
 375 cgn        write (ulsort,1000) 'max 1 3', max(quafi1,quafi3)
 376 cgn        write (ulsort,1000) 'seuil  ', quaper*rapqmx
 377         if ( max(quafi1,quafi3).gt.quaper*rapqmx ) then
 378           bilan = 1
 379           goto 50
 380         endif
 381 c
 382 c 3.4.2. ==> Les triangles centraux
 383 c            . Decoupage standard ou avec bascule d'aretes
 384 c
 385         do 3421 , iaux = 1 , sdim
 386           conotr(1,iaux) = coonoe(nq,iaux)
 387  3421   continue
 388 cgn        write (ulsort,1002) 'triangle fils 2', nq, np, lenoeu
 389         call utqtr0 ( quafi2, daux2, sdim, conotr )
 390 cgn        write (ulsort,1000) 'Qualite fils 2', quafi2
 391 cgn        write (ulsort,1000) 'Surface fils 2', daux1
 392 c
 393         daux1 = max(quaper,quafi2)
 394 c
 395 c       Test de la bascule d'arete : np-nq est remplace par sn-lenoeu
 396 c       les triangles Fils2 et Fils4 sont remplaces
 397 c
 398         if ( typsfr.le.2 ) then
 399 c
 400           do 3422 , iaux = 1 , sdim
 401             conotr(2,iaux) = coonoe(sn,iaux)
 402  3422     continue
 403 cgn        write (ulsort,1002) 'triangle fils 5', nq, sn, lenoeu
 404           call utqtr0 ( quafi5, daux2, sdim, conotr )
 405 cgn        write (ulsort,1000) 'Qualite fils 5', quafi5
 406 cgn        write (ulsort,1000) 'Surface fils 5', daux1
 407 c
 408           do 3423 , iaux = 1 , sdim
 409             conotr(1,iaux) = coonoe(np,iaux)
 410  3423     continue
 411 cgn        write (ulsort,1002) 'triangle fils 6', np, sn, lenoeu
 412           call utqtr0 ( quafi6, daux2, sdim, conotr )
 413 cgn        write (ulsort,1000) 'Qualite fils 6', quafi6
 414 cgn        write (ulsort,1000) 'Surface fils 6', daux1
 415 c
 416           daux2 = max(quafi6,quafi5)
 417 c
 418 cgn        write (ulsort,1000) 'max 5 6', daux2
 419 cgn        write (ulsort,1000) 'max p 2', daux1
 420 c
 421           if ( daux1.lt.daux2 ) then
 422             bascul = .false.
 423           else
 424 cgn        write (ulsort,*) '- On bascule -'
 425             bascul = .true.
 426             daux1 = daux2
 427           endif
 428 c
 429         endif
 430 c
 431 cgn        write (ulsort,1000) 'max 2 4', daux1
 432 cgn        write (ulsort,1000) 'seuil  ', quaper*rapqmx
 433         if ( daux1.gt.quaper*rapqmx ) then
 434           bilan = 1
 435           goto 50
 436         endif
 437 c
 438         endif
 439 c
 440       endif
 441 c
 442 c====
 443 c 4. Test de qualite du decoupage de conformite
 444 c====
 445 #ifdef _DEBUG_HOMARD_
 446       write (ulsort,*) '4. test decoupage en 2 ; codret = ', codret
 447 #endif
 448 c
 449       if ( etat.eq.2 .or. typsfr.gt.2 ) then
 450 c
 451         if ( codret.eq.0 ) then
 452 c
 453 c                            larete
 454 c       sp                   lenoeu                      sq
 455 c        .-----------------------.-----------------------.
 456 c         .                      .                      .
 457 c          .                     .                     .
 458 c           .                    .                    .
 459 c            .                   .                   .
 460 c             .                  .                  .
 461 c              .                 .                 .
 462 c               .                .                .
 463 c                .               .               .
 464 c                 .              .              .
 465 c                  .             .             .
 466 c           areq    .            .            .   arep
 467 c                    .           .           .
 468 c                     .          .          .
 469 c                      .         .         .
 470 c                       .        .        .
 471 c                        .       .       .
 472 c                         .      .      .
 473 c                          .     .     .
 474 c                           .    .    .
 475 c                            .   .   .
 476 c                             .  .  .
 477 c                              . . .
 478 c                               ...
 479 c                                .
 480 c                               sn
 481 c
 482 c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas
 483 c          les segments sp/sn ou sq/sn
 484 c
 485         do 41 , iaux = 1 , sdim
 486           v1(iaux) = coonoe(sp,iaux)
 487           v2(iaux) = coonoe(sn,iaux)
 488           v3(iaux) = coonoe(sq,iaux)
 489    41   continue
 490 c
 491         iaux = 0
 492         if ( sdim.eq.2 ) then
 493           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 494         else
 495           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 496         endif
 497 c                               sp  sn  sq  N
 498 cgn      write (ulsort,*) 'Du bon cote de sp/sn :', memeco
 499 c
 500         if ( .not. memeco ) then
 501           bilan = 1
 502           goto 50
 503         endif
 504 c
 505         iaux = 0
 506         if ( sdim.eq.2 ) then
 507           call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
 508         else
 509           call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
 510         endif
 511 c                               sq  sn  sp  N
 512 cgn      write (ulsort,*) 'Du bon cote de sq/sn :', memeco
 513 c
 514         if ( .not. memeco ) then
 515           bilan = 1
 516           goto 50
 517         endif
 518 c
 519 c 4.2. ==> Qualite future des triangles issus du decoupage
 520 c
 521         do 421 , iaux = 1 , sdim
 522           conotr(1,iaux) = coopro(iaux)
 523           conotr(2,iaux) = coonoe(sq,iaux)
 524           conotr(3,iaux) = coonoe(sn,iaux)
 525   421   continue
 526 cgn      write (ulsort,1002) 'triangle', lenoeu, sq, sn
 527         call utqtr0 ( quafi1, daux2, sdim, conotr )
 528 cgn      write (ulsort,1000) 'Qualite fils 1', quafi1
 529 c
 530         do 422 , iaux = 1 , sdim
 531           conotr(2,iaux) = coonoe(sp,iaux)
 532   422   continue
 533 cgn      write (ulsort,1002) 'triangle', lenoeu, sp, sn
 534         call utqtr0 ( quafi2, daux2, sdim, conotr )
 535 cgn      write (ulsort,1000) 'Qualite fils 2', quafi2
 536 c
 537 c       On limite le facteur d'accroissement
 538 c
 539 cgn        write (ulsort,1000) 'max 1 2', max(quafi1,quafi2)
 540 cgn        write (ulsort,1000) 'seuil  ', quaper*rapqmx*2.d0
 541         if ( max(quafi1,quafi2).gt.quaper*rapqmx*2.d0 ) then
 542           bilan = 1
 543           goto 50
 544         endif
 545 c
 546       endif
 547 c
 548       endif
 549 c
 550 c====
 551 c 5. La fin
 552 c====
 553 #ifdef _DEBUG_HOMARD_
 554       write (ulsort,*) '5. la fin ; codret = ', codret
 555 #endif
 556 c
 557    50 continue
 558 c
 559 #ifdef _DEBUG_HOMARD_
 560       if ( bilan.ne.0 ) then
 561         write(ulsort,texte(langue,5)) lenoeu
 562       endif
 563 #endif
 564 c
 565       if ( codret.ne.0 ) then
 566 c
 567 #include "envex2.h"
 568 c
 569       write (ulsort,texte(langue,1)) 'Sortie', nompro
 570       write (ulsort,texte(langue,2)) codret
 571       write (ulsort,1001) mess14(langue,2,-1), lenoeu,
 572      >                               (coopro(iaux),iaux=1,sdim)
 573       write (ulsort,1001) mess14(langue,2, 1), larete
 574       write (ulsort,1001) mess14(langue,2, 2), letria
 575 c
 576       endif
 577 c
 578 #ifdef _DEBUG_HOMARD_
 579       write (ulsort,texte(langue,1)) 'Sortie', nompro
 580       call dmflsh (iaux)
 581 #endif
 582 c
 583       end