1 subroutine sftqtr ( bilan, bascul,
2 > lenoeu, larete, letria,
4 > somare, filare, np2are,
6 > ulsort, langue, codret)
7 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
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
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c Suivi de Frontiere - Test Qualite - TRiangle
28 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 .
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 ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'SFTQTR' )
66 double precision rapqmx
67 parameter ( rapqmx = 5.0d0 )
87 integer lenoeu, larete, letria
89 double precision coonoe(nbnoto,sdim)
91 integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
92 integer hettri(nbtrto), aretri(nbtrto,3)
94 integer ulsort, langue, codret
96 c 0.4. ==> variables locales
100 integer sa1a2, sa2a3, sa3a1
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
116 parameter ( nbmess = 10 )
117 character*80 texte(nblang,nbmess)
119 c 0.5. ==> initialisations
120 c ______________________________________________________________________
128 #ifdef _DEBUG_HOMARD_
129 write (ulsort,texte(langue,1)) 'Entree', nompro
135 texte(1,4) = '(''Aretes du triangle'',i10'' :'',3i10)'
136 texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)'
138 texte(2,4) = '(''Edges of triangle #'',i10'' :'',3i10)'
139 texte(2,5) = '(''Cancellation of BF for node # : '',i10)'
141 1000 format('... ',a,' :',3g13.5)
142 1001 format('... ',a,' :',i10,', ',3g13.5)
143 1002 format('... Test du ',a,' :',4i10)
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
152 c 1.2. ==> Tout va bien a priori
159 c 2. Reperage des caracteristiques du triangle pere
161 c 2.1. ==> Reperage local des aretes
163 a1 = aretri(letria,1)
164 a2 = aretri(letria,2)
165 a3 = aretri(letria,3)
167 #ifdef _DEBUG_HOMARD_
168 write (ulsort,texte(langue,4)) letria, a1, a2, a3
171 c 2.2. ==> Recherche des sommets
181 c sa3a1*---------------*sa1a2
184 call utsotr ( somare, a1, a2, a3,
185 > sa1a2, sa2a3, sa3a1 )
187 if ( larete.eq.a1 ) then
193 elseif ( larete.eq.a2 ) then
199 elseif ( larete.eq.a3 ) then
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
216 c 2.3. ==> Autres caracteristiques
217 c . Qualite du triangle de depart
218 c . Coordonnees du noeud sur la frontiere
221 if ( codret.eq.0 ) then
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)
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
235 etat = mod(hettri(letria),10)
240 c 3. Test de qualite du decoupage standard
242 #ifdef _DEBUG_HOMARD_
243 write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret
246 if ( etat.eq.4 .or. typsfr.gt.2 ) then
248 if ( codret.eq.0 ) then
252 c .-----------------------.-----------------------.
256 c . Fils1 . . Fils3 .
264 c .-----------------------.
279 c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas
282 if ( typsfr.le.2 ) then
283 np = somare(2,filare(arep))
284 nq = somare(2,filare(areq))
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)
292 do 31 , iaux = 1 , sdim
293 v1(iaux) = coonoe(np,iaux)
294 v2(iaux) = coonoe(nq,iaux)
295 v3(iaux) = conotr(1,iaux)
299 if ( sdim.eq.2 ) then
300 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
302 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
305 cgn write (ulsort,*) 'Du bon cote de np/nq :', memeco
307 if ( .not. memeco ) then
312 c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas
315 do 32 , iaux = 1 , sdim
316 v1(iaux) = conotr(2,iaux)
320 if ( sdim.eq.2 ) then
321 call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
323 call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
326 cgn write (ulsort,*) 'Du bon cote de sp/sn :', memeco
328 if ( .not. memeco ) then
333 c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas
336 do 33 , iaux = 1 , sdim
337 v2(iaux) = coonoe(np,iaux)
341 if ( sdim.eq.2 ) then
342 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
344 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
347 cgn write (ulsort,*) 'Du bon cote de sq/sn :', memeco
349 if ( .not. memeco ) then
354 c 3.4. ==> Qualites des fils avec le noeud deplace
355 c 3.4.1. ==> Les triangles de cote
357 do 3411 , iaux = 1 , sdim
358 conotr(2,iaux) = coonoe(nq,iaux)
359 conotr(3,iaux) = coopro(iaux)
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
366 do 3412 , iaux = 1 , sdim
367 conotr(1,iaux) = coonoe(sq,iaux)
368 conotr(2,iaux) = coonoe(np,iaux)
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
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
382 c 3.4.2. ==> Les triangles centraux
383 c . Decoupage standard ou avec bascule d'aretes
385 do 3421 , iaux = 1 , sdim
386 conotr(1,iaux) = coonoe(nq,iaux)
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
393 daux1 = max(quaper,quafi2)
395 c Test de la bascule d'arete : np-nq est remplace par sn-lenoeu
396 c les triangles Fils2 et Fils4 sont remplaces
398 if ( typsfr.le.2 ) then
400 do 3422 , iaux = 1 , sdim
401 conotr(2,iaux) = coonoe(sn,iaux)
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
408 do 3423 , iaux = 1 , sdim
409 conotr(1,iaux) = coonoe(np,iaux)
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
416 daux2 = max(quafi6,quafi5)
418 cgn write (ulsort,1000) 'max 5 6', daux2
419 cgn write (ulsort,1000) 'max p 2', daux1
421 if ( daux1.lt.daux2 ) then
424 cgn write (ulsort,*) '- On bascule -'
431 cgn write (ulsort,1000) 'max 2 4', daux1
432 cgn write (ulsort,1000) 'seuil ', quaper*rapqmx
433 if ( daux1.gt.quaper*rapqmx ) then
443 c 4. Test de qualite du decoupage de conformite
445 #ifdef _DEBUG_HOMARD_
446 write (ulsort,*) '4. test decoupage en 2 ; codret = ', codret
449 if ( etat.eq.2 .or. typsfr.gt.2 ) then
451 if ( codret.eq.0 ) then
455 c .-----------------------.-----------------------.
482 c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas
483 c les segments sp/sn ou sq/sn
485 do 41 , iaux = 1 , sdim
486 v1(iaux) = coonoe(sp,iaux)
487 v2(iaux) = coonoe(sn,iaux)
488 v3(iaux) = coonoe(sq,iaux)
492 if ( sdim.eq.2 ) then
493 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
495 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
498 cgn write (ulsort,*) 'Du bon cote de sp/sn :', memeco
500 if ( .not. memeco ) then
506 if ( sdim.eq.2 ) then
507 call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
509 call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
512 cgn write (ulsort,*) 'Du bon cote de sq/sn :', memeco
514 if ( .not. memeco ) then
519 c 4.2. ==> Qualite future des triangles issus du decoupage
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)
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
530 do 422 , iaux = 1 , sdim
531 conotr(2,iaux) = coonoe(sp,iaux)
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
537 c On limite le facteur d'accroissement
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
553 #ifdef _DEBUG_HOMARD_
554 write (ulsort,*) '5. la fin ; codret = ', codret
559 #ifdef _DEBUG_HOMARD_
560 if ( bilan.ne.0 ) then
561 write(ulsort,texte(langue,5)) lenoeu
565 if ( codret.ne.0 ) then
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
578 #ifdef _DEBUG_HOMARD_
579 write (ulsort,texte(langue,1)) 'Sortie', nompro