src/tool/Suivi_Frontiere/sftqqu.F

   1       subroutine sftqqu ( bilan,
   2      >                    lenoeu, larete, lequad,
   3      >                    coonoe,
   4      >                    somare, filare, np2are,
   5      >                    hetqua, arequa, filqua,
   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
  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 - QUadrangle
  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 . lenoeu . e   .    1   . noeud en cours d'examen                    .
  36 c . larete . e   .    1   . arete en cours d'examen                    .
  37 c . lequad . e   .    1   . quadrangle en cours d'examen               .
  38 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  39 c .        .     . *sdim  .                                            .
  40 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
  41 c . filare . e   . nbarto . premiere fille des aretes                  .
  42 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  43 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . filqua . e   . nbquto . premier fils des quadrangles               .
  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 = 'SFTQQU' )
  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 "nombqu.h"
  79 #include "impr02.h"
  80 #include "ope1a4.h"
  81 c
  82 c 0.3. ==> arguments
  83 c
  84       integer bilan
  85 c
  86       integer lenoeu, larete, lequad
  87 c
  88       double precision coonoe(nbnoto,sdim)
  89 c
  90       integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
  91       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
  92 c
  93       integer ulsort, langue, codret
  94 c
  95 c 0.4. ==> variables locales
  96 c
  97       integer iaux
  98       integer a1, a2, a3, a4
  99       integer sp, sq, spn, sqn
 100       integer s0, sp0, sq0
 101       integer inloc, inloc1, inloc2, inloc3
 102       integer etat
 103       integer som(4)
 104 c
 105       double precision coopro(3)
 106       double precision coocen(3)
 107       double precision conoqu(4,3)
 108       double precision conotr(3,3)
 109       double precision v1(3), v2(3), v3(3)
 110       double precision quaper
 111       double precision quafi1, quafi2, quafi3
 112       double precision daux1
 113 c
 114       logical memeco
 115 c
 116       integer nbmess
 117       parameter ( nbmess = 10 )
 118       character*80 texte(nblang,nbmess)
 119 c
 120 c 0.5. ==> initialisations
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. initialisations
 125 c====
 126 c
 127 #include "impr01.h"
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,1)) 'Entree', nompro
 131       call dmflsh (iaux)
 132 #endif
 133 c
 134 c 1.1. ==> messages
 135 c
 136       texte(1,4) = '(''Aretes du quadrangle'',i10'' :'',4i10)'
 137       texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)'
 138 c
 139       texte(2,4) = '(''Edges of quadrangle #'',i10'' :'',4i10)'
 140       texte(2,5) = '(''Cancellation of BF for node # : '',i10)'
 141 c
 142  1001 format('... ',a,' :',i10,', ',3g13.5)
 143 #ifdef _DEBUG_HOMARD_
 144 cgn 1000 format('... ',a,' :',3g13.5)
 145  1002 format('... Test du ',a,' :',4i10)
 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, 4), lequad
 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 quadrangle pere
 160 c====
 161 c 2.1. ==> Reperage local des aretes
 162 c
 163       a1 = arequa(lequad,1)
 164       a2 = arequa(lequad,2)
 165       a3 = arequa(lequad,3)
 166       a4 = arequa(lequad,4)
 167 c
 168 #ifdef _DEBUG_HOMARD_
 169       write (ulsort,texte(langue,4)) lequad, a1, a2, a3, a4
 170 #endif
 171 c
 172 c 2.2. ==> Recherche des sommets
 173 c
 174 c    som(4) = sa4a1   a4   sa3a4 = som(3)
 175 c                 ._________.
 176 c                 .         .
 177 c                 .         .
 178 c               a1.         .a3
 179 c                 .         .
 180 c                 ._________.
 181 c    som(1) = sa1a2   a2   sa2a3 = som(2)
 182 c
 183 cgn      print *,larete
 184 cgn      print *,a1, a2, a3, a4
 185 c
 186       call utsoqu ( somare, a1, a2, a3, a4,
 187      >              som(1), som(2), som(3), som(4) )
 188 cgn      write (ulsort,*) 'Sommets : ', som
 189 c
 190       codret = 22
 191       do 22 , iaux = 1 , 4
 192         if ( larete.eq.arequa(lequad,iaux) ) then
 193           inloc = iaux
 194           codret = 0
 195         endif
 196    22 continue
 197 cgn      print *,inloc
 198 c
 199       if ( codret.eq.0 ) then
 200 c
 201       sp = som(inloc)
 202 c
 203       inloc1 = per1a4(1,inloc)
 204       spn = som(inloc1)
 205 c
 206       inloc2 = per1a4(2,inloc)
 207       sqn = som(inloc2)
 208 c
 209       inloc3 = per1a4(3,inloc)
 210       sq = som(inloc3)
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,1001) 'sp ',  sp, (coonoe(sp ,iaux),iaux=1,sdim)
 214       write (ulsort,1001) 'spn', spn, (coonoe(spn,iaux),iaux=1,sdim)
 215       write (ulsort,1001) 'sq ',  sq, (coonoe(sq ,iaux),iaux=1,sdim)
 216       write (ulsort,1001) 'sqn', sqn, (coonoe(sqn,iaux),iaux=1,sdim)
 217 #endif
 218 c
 219 c 2.3. ==> Autres caracteristiques
 220 c          . Qualite du quadrangle de depart
 221 c          . Coordonnees du noeud sur la frontiere
 222 c          . Etat
 223 c
 224       do 23 , iaux = 1 , sdim
 225         conoqu(1,iaux) = coonoe(sp,iaux)
 226         conoqu(2,iaux) = coonoe(spn,iaux)
 227         conoqu(3,iaux) = coonoe(sqn,iaux)
 228         conoqu(4,iaux) = coonoe(sq,iaux)
 229         coopro(iaux)   = coonoe(lenoeu,iaux)
 230    23 continue
 231 cgn      write (ulsort,1001) 'n ', lenoeu, (coopro(iaux),iaux = 1 ,sdim)
 232 cgn      write (ulsort,1002) 'quadrangle pere', sp, spn, sqn, sq
 233       call utqqu0 ( quaper, daux1, sdim, conoqu )
 234 cgn      write (ulsort,1000) 'Qualite pere  ', quaper
 235 cgn      write (ulsort,1000) 'Surface pere  ', daux1
 236 c
 237       etat = mod(hetqua(lequad),100)
 238 c
 239       endif
 240 c
 241 c====
 242 c 3. Test de qualite du decoupage standard
 243 c====
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret
 246 #endif
 247 c
 248       if ( etat.eq.4 .or. typsfr.gt.2 ) then
 249 c
 250         if ( codret.eq.0 ) then
 251 c
 252 c                           larete/inloc
 253 c       sp                    lenoeu                     sq
 254 c        .-----------------------.-----------------------.
 255 c        .                       .                       .
 256 c        .                       .                       .
 257 c        .                       .                       .
 258 c        .                       .                       .
 259 c        .                       .                       .
 260 c        .                       .                       .
 261 c inloc1 .                       .s0                     .inloc3
 262 c    sp0 .-----------------------.-----------------------.sq0
 263 c        .                       .                       .
 264 c        .                       .                       .
 265 c        .                       .                       .
 266 c        .        Fils1          .       Fils2           .
 267 c        .                       .                       .
 268 c        .                       .                       .
 269 c        .                       .                       .
 270 c        .-----------------------.-----------------------.
 271 c       spn                                             sqn
 272 c                               inloc2
 273 c
 274 c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas
 275 c          le segment sp0/s0
 276 c
 277         if ( typsfr.le.2 ) then
 278           sp0 = somare(2,filare(arequa(lequad,inloc1)))
 279           sq0 = somare(2,filare(arequa(lequad,inloc3)))
 280           s0 = somare(2,arequa(filqua(lequad),2))
 281           do 311 , iaux = 1 , sdim
 282             coocen(iaux) = coonoe(s0,iaux)
 283   311     continue
 284         else
 285           sp0 = np2are(arequa(lequad,inloc1))
 286           sq0 = np2are(arequa(lequad,inloc3))
 287           do 312 , iaux = 1 , sdim
 288             coocen(iaux) = 0.5d0*(coonoe(sp0,iaux)+coonoe(sq0,iaux))
 289   312     continue
 290         endif
 291 cgn      write (ulsort,1001) 'sp0', sp0, (coonoe(sp0,iaux),iaux=1,sdim)
 292 cgn      write (ulsort,1001) 'sq0', sq0, (coonoe(sq0,iaux),iaux=1,sdim)
 293 cgn      write (ulsort,1001) 's0 ',  s0, (coocen(iaux),iaux=1,sdim)
 294 c
 295         do 31 , iaux = 1 , sdim
 296           v1(iaux) = coonoe(sp0,iaux)
 297           v2(iaux) = coocen(iaux)
 298           v3(iaux) = conoqu(1,iaux)
 299    31   continue
 300 c
 301         iaux = 0
 302         if ( sdim.eq.2 ) then
 303           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 304         else
 305           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 306         endif
 307 c                              sp0  s0  sp  N
 308 cgn      write (ulsort,*) 'Du bon cote de sp0/s0 :', memeco
 309 c
 310         if ( .not. memeco ) then
 311           bilan = 1
 312           goto 50
 313         endif
 314 c
 315 c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas
 316 c          le segment sq0/s0
 317 c
 318         do 32 , iaux = 1 , sdim
 319           v1(iaux) = coonoe(sq0,iaux)
 320    32   continue
 321 c
 322         iaux = 0
 323         if ( sdim.eq.2 ) then
 324           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 325         else
 326           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 327         endif
 328 c                              sq0  s0  sp  N
 329 cgn      write (ulsort,*) 'Du bon cote de sq0/s0 :', memeco
 330 c
 331         if ( .not. memeco ) then
 332           bilan = 1
 333           goto 50
 334         endif
 335 c
 336 c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas
 337 c          le segment sq0/sq
 338 c
 339         do 33 , iaux = 1 , sdim
 340           v2(iaux) = coonoe(sq,iaux)
 341    33   continue
 342 c
 343         iaux = 0
 344         if ( sdim.eq.2 ) then
 345           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 346         else
 347           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 348         endif
 349 c                              sq0  sq  sp  N
 350 cgn      write (ulsort,*) 'Du bon cote de sq0/sq :', memeco
 351 c
 352         if ( .not. memeco ) then
 353           bilan = 1
 354           goto 50
 355         endif
 356 c
 357 c 3.4. ==> On verifie que le noeud lenoeu ne traverse pas
 358 c          le segment sp0/sp
 359 c
 360         do 34 , iaux = 1 , sdim
 361           v1(iaux) = coonoe(sp0,iaux)
 362    34   continue
 363 c
 364         iaux = 0
 365         if ( sdim.eq.2 ) then
 366           call utsen2 ( memeco, v1, v3, v2, coopro, iaux )
 367         else
 368           call utsen3 ( memeco, v1, v3, v2, coopro, iaux )
 369         endif
 370 c                              sp0  sp  sq  N
 371 cgn      write (ulsort,*) 'Du bon cote de sp0/sp :', memeco
 372 c
 373         if ( .not. memeco ) then
 374           bilan = 1
 375           goto 50
 376         endif
 377 c
 378 c 3.5. ==> Qualites des fils avec le noeud deplace
 379 c
 380         do 351 , iaux = 1 , sdim
 381           conoqu(2,iaux) = coonoe(sp0,iaux)
 382           conoqu(3,iaux) = coocen(iaux)
 383           conoqu(4,iaux) = coopro(iaux)
 384   351   continue
 385 cgn      write (ulsort,1002) 'quadrangle', sp, sp0, s0, lenoeu
 386         call utqqu0 ( quafi1, daux1, sdim, conoqu )
 387 cgn        write (ulsort,1000) 'Qualite fils 1', quafi1
 388 c
 389         do 352 , iaux = 1 , sdim
 390           conoqu(1,iaux) = coonoe(sq,iaux)
 391           conoqu(2,iaux) = coonoe(sq0,iaux)
 392   352   continue
 393 cgn      write (ulsort,1002) 'quadrangle', sq, sq0, s0, lenoeu
 394         call utqqu0 ( quafi2, daux1, sdim, conoqu )
 395 cgn        write (ulsort,1000) 'Qualite fils 2', quafi2
 396 c
 397 c       On limite le facteur d'accroissement
 398 c
 399 cgn        write (ulsort,1000) 'max 1 2', max(quafi1,quafi2)
 400 cgn        write (ulsort,1000) 'seuil  ', quaper*rapqmx
 401         if ( max(quafi1,quafi2).gt.quaper*rapqmx ) then
 402           bilan = 1
 403           goto 50
 404         endif
 405 c
 406         endif
 407 c
 408       endif
 409 c
 410 c====
 411 c 4. Test de qualite du decoupage de conformite
 412 c====
 413 #ifdef _DEBUG_HOMARD_
 414       write (ulsort,*) '4. test decoupage en 3 ; codret = ', codret
 415 #endif
 416 c
 417       if ( ( etat.ge.31 .and. etat.le.34 ) .or. typsfr.gt.2 ) then
 418 c
 419         if ( codret.eq.0 ) then
 420 c
 421 c                   larete/inloc
 422 c       sp            lenoeu              sq
 423 c        .---------------.----------------.
 424 c        .              .  .              .
 425 c        .             .    .             .
 426 c        .            .      .            .
 427 c        .           .        .           .
 428 c        .          .          .          .
 429 c        .         .            .         .
 430 c        .        .              .        .
 431 c        .       .                .       .
 432 c        .      .                  .      .
 433 c        .     .                    .     .
 434 c        .    .                     .    .
 435 c        .   .                        .   .
 436 c        .  .                          .  .
 437 c        . .                            . .
 438 c        ..                              ..
 439 c        .--------------------------------.
 440 c       spn                              sqn
 441 c
 442 c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas
 443 c          le segment sp/spn
 444 c
 445         do 41 , iaux = 1 , sdim
 446           v1(iaux) = coonoe(sp,iaux)
 447           v2(iaux) = coonoe(spn,iaux)
 448           v3(iaux) = coonoe(sq,iaux)
 449    41   continue
 450 c
 451         iaux = 0
 452         if ( sdim.eq.2 ) then
 453           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 454         else
 455           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 456         endif
 457 c                               sp spn  sq  N
 458 cgn      write (ulsort,*) 'Du bon cote de sp/spn :', memeco
 459 c
 460         if ( .not. memeco ) then
 461           bilan = 1
 462           goto 50
 463         endif
 464 c
 465 c 4.2. ==> On verifie que le noeud lenoeu ne traverse pas
 466 c          le segment sq/sqn
 467 c
 468         do 42 , iaux = 1 , sdim
 469           v2(iaux) = coonoe(sqn,iaux)
 470    42   continue
 471 c
 472         iaux = 0
 473         if ( sdim.eq.2 ) then
 474           call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
 475         else
 476           call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
 477         endif
 478 c                               sq sqn  sp  N
 479 cgn      write (ulsort,*) 'Du bon cote de sq/sqn :', memeco
 480 c
 481         if ( .not. memeco ) then
 482           bilan = 1
 483           goto 50
 484         endif
 485 c
 486 c 4.3. ==> On verifie que le noeud lenoeu ne traverse pas
 487 c          le segment spn/sqn
 488 c
 489         do 43 , iaux = 1 , sdim
 490           v1(iaux) = coonoe(spn,iaux)
 491    43   continue
 492 c
 493         iaux = 0
 494         if ( sdim.eq.2 ) then
 495           call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
 496         else
 497           call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
 498         endif
 499 c                              spn sqn  sq  N
 500 cgn      write (ulsort,*) 'Du bon cote de spn/sqn :', memeco
 501 c
 502         if ( .not. memeco ) then
 503           bilan = 1
 504           goto 50
 505         endif
 506 c
 507 c 4.4. ==> Qualite future des triangles issus du decoupage
 508 c
 509         do 441 , iaux = 1 , sdim
 510           conotr(1,iaux) = coonoe(sp,iaux)
 511           conotr(2,iaux) = coonoe(spn,iaux)
 512           conotr(3,iaux) = coopro(iaux)
 513   441   continue
 514 cgn      write (ulsort,1002) 'triangle', sp, spn, lenoeu
 515         call utqtr0 ( quafi1, daux1, sdim, conotr )
 516 cgn      write (ulsort,1000) 'Qualite fils 1', quafi1
 517 c
 518         do 442 , iaux = 1 , sdim
 519           conotr(1,iaux) = coonoe(sqn,iaux)
 520   442   continue
 521 cgn      write (ulsort,1002) 'triangle', sqn, spn, lenoeu
 522         call utqtr0 ( quafi2, daux1, sdim, conotr )
 523 cgn      write (ulsort,1000) 'Qualite fils 2', quafi2
 524 c
 525         do 443 , iaux = 1 , sdim
 526           conotr(2,iaux) = coonoe(sq,iaux)
 527   443   continue
 528 cgn      write (ulsort,1002) 'triangle', sqn, sq, lenoeu
 529         call utqtr0 ( quafi3, daux1, sdim, conotr )
 530 cgn      write (ulsort,1000) 'Qualite fils 3', quafi3
 531 c
 532 c        On limite le facteur d'accroissement
 533 c
 534 cgn        write (ulsort,1000) 'max 1 2 3', max(quafi1,quafi2,quafi3)
 535 cgn        write (ulsort,1000) 'seuil  ', quaper*rapqmx*2.d0
 536          if ( max(quafi1,quafi2,quafi3).gt.quaper*rapqmx*2.d0 ) then
 537           bilan = 1
 538           goto 50
 539         endif
 540 c
 541       endif
 542 c
 543       endif
 544 c
 545 c====
 546 c 5.La fin
 547 c====
 548 #ifdef _DEBUG_HOMARD_
 549       write (ulsort,*) '5. la fin ; codret = ', codret
 550 #endif
 551 c
 552    50 continue
 553 c
 554 #ifdef _DEBUG_HOMARD_
 555       if ( bilan.ne.0 ) then
 556         write(ulsort,texte(langue,5)) lenoeu
 557       endif
 558 #endif
 559 c
 560       if ( codret.ne.0 ) then
 561 c
 562 #include "envex2.h"
 563 c
 564       write (ulsort,texte(langue,1)) 'Sortie', nompro
 565       write (ulsort,texte(langue,2)) codret
 566       write (ulsort,1001) mess14(langue,2,-1), lenoeu,
 567      >                               (coopro(iaux),iaux=1,sdim)
 568       write (ulsort,1001) mess14(langue,2, 1), larete
 569       write (ulsort,1001) mess14(langue,2, 4), lequad
 570 c
 571       endif
 572 c
 573 #ifdef _DEBUG_HOMARD_
 574       write (ulsort,texte(langue,1)) 'Sortie', nompro
 575       call dmflsh (iaux)
 576 #endif
 577 c
 578       end