1 subroutine sftqqu ( bilan,
2 > lenoeu, larete, lequad,
4 > somare, filare, np2are,
5 > hetqua, arequa, filqua,
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
24 c ______________________________________________________________________
26 c Suivi de Frontiere - Test Qualite - QUadrangle
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 . 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 .
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 ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'SFTQQU' )
66 double precision rapqmx
67 parameter ( rapqmx = 5.0d0 )
86 integer lenoeu, larete, lequad
88 double precision coonoe(nbnoto,sdim)
90 integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
91 integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
93 integer ulsort, langue, codret
95 c 0.4. ==> variables locales
98 integer a1, a2, a3, a4
99 integer sp, sq, spn, sqn
101 integer inloc, inloc1, inloc2, inloc3
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
117 parameter ( nbmess = 10 )
118 character*80 texte(nblang,nbmess)
120 c 0.5. ==> initialisations
121 c ______________________________________________________________________
129 #ifdef _DEBUG_HOMARD_
130 write (ulsort,texte(langue,1)) 'Entree', nompro
136 texte(1,4) = '(''Aretes du quadrangle'',i10'' :'',4i10)'
137 texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)'
139 texte(2,4) = '(''Edges of quadrangle #'',i10'' :'',4i10)'
140 texte(2,5) = '(''Cancellation of BF for node # : '',i10)'
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
152 c 1.2. ==> Tout va bien a priori
159 c 2. Reperage des caracteristiques du quadrangle pere
161 c 2.1. ==> Reperage local des aretes
163 a1 = arequa(lequad,1)
164 a2 = arequa(lequad,2)
165 a3 = arequa(lequad,3)
166 a4 = arequa(lequad,4)
168 #ifdef _DEBUG_HOMARD_
169 write (ulsort,texte(langue,4)) lequad, a1, a2, a3, a4
172 c 2.2. ==> Recherche des sommets
174 c som(4) = sa4a1 a4 sa3a4 = som(3)
181 c som(1) = sa1a2 a2 sa2a3 = som(2)
184 cgn print *,a1, a2, a3, a4
186 call utsoqu ( somare, a1, a2, a3, a4,
187 > som(1), som(2), som(3), som(4) )
188 cgn write (ulsort,*) 'Sommets : ', som
192 if ( larete.eq.arequa(lequad,iaux) ) then
199 if ( codret.eq.0 ) then
203 inloc1 = per1a4(1,inloc)
206 inloc2 = per1a4(2,inloc)
209 inloc3 = per1a4(3,inloc)
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)
219 c 2.3. ==> Autres caracteristiques
220 c . Qualite du quadrangle de depart
221 c . Coordonnees du noeud sur la frontiere
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)
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
237 etat = mod(hetqua(lequad),100)
242 c 3. Test de qualite du decoupage standard
244 #ifdef _DEBUG_HOMARD_
245 write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret
248 if ( etat.eq.4 .or. typsfr.gt.2 ) then
250 if ( codret.eq.0 ) then
254 c .-----------------------.-----------------------.
261 c inloc1 . .s0 .inloc3
262 c sp0 .-----------------------.-----------------------.sq0
270 c .-----------------------.-----------------------.
274 c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas
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)
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))
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)
295 do 31 , iaux = 1 , sdim
296 v1(iaux) = coonoe(sp0,iaux)
297 v2(iaux) = coocen(iaux)
298 v3(iaux) = conoqu(1,iaux)
302 if ( sdim.eq.2 ) then
303 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
305 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
308 cgn write (ulsort,*) 'Du bon cote de sp0/s0 :', memeco
310 if ( .not. memeco ) then
315 c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas
318 do 32 , iaux = 1 , sdim
319 v1(iaux) = coonoe(sq0,iaux)
323 if ( sdim.eq.2 ) then
324 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
326 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
329 cgn write (ulsort,*) 'Du bon cote de sq0/s0 :', memeco
331 if ( .not. memeco ) then
336 c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas
339 do 33 , iaux = 1 , sdim
340 v2(iaux) = coonoe(sq,iaux)
344 if ( sdim.eq.2 ) then
345 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
347 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
350 cgn write (ulsort,*) 'Du bon cote de sq0/sq :', memeco
352 if ( .not. memeco ) then
357 c 3.4. ==> On verifie que le noeud lenoeu ne traverse pas
360 do 34 , iaux = 1 , sdim
361 v1(iaux) = coonoe(sp0,iaux)
365 if ( sdim.eq.2 ) then
366 call utsen2 ( memeco, v1, v3, v2, coopro, iaux )
368 call utsen3 ( memeco, v1, v3, v2, coopro, iaux )
371 cgn write (ulsort,*) 'Du bon cote de sp0/sp :', memeco
373 if ( .not. memeco ) then
378 c 3.5. ==> Qualites des fils avec le noeud deplace
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)
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
389 do 352 , iaux = 1 , sdim
390 conoqu(1,iaux) = coonoe(sq,iaux)
391 conoqu(2,iaux) = coonoe(sq0,iaux)
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
397 c On limite le facteur d'accroissement
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
411 c 4. Test de qualite du decoupage de conformite
413 #ifdef _DEBUG_HOMARD_
414 write (ulsort,*) '4. test decoupage en 3 ; codret = ', codret
417 if ( ( etat.ge.31 .and. etat.le.34 ) .or. typsfr.gt.2 ) then
419 if ( codret.eq.0 ) then
423 c .---------------.----------------.
439 c .--------------------------------.
442 c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas
445 do 41 , iaux = 1 , sdim
446 v1(iaux) = coonoe(sp,iaux)
447 v2(iaux) = coonoe(spn,iaux)
448 v3(iaux) = coonoe(sq,iaux)
452 if ( sdim.eq.2 ) then
453 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
455 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
458 cgn write (ulsort,*) 'Du bon cote de sp/spn :', memeco
460 if ( .not. memeco ) then
465 c 4.2. ==> On verifie que le noeud lenoeu ne traverse pas
468 do 42 , iaux = 1 , sdim
469 v2(iaux) = coonoe(sqn,iaux)
473 if ( sdim.eq.2 ) then
474 call utsen2 ( memeco, v3, v2, v1, coopro, iaux )
476 call utsen3 ( memeco, v3, v2, v1, coopro, iaux )
479 cgn write (ulsort,*) 'Du bon cote de sq/sqn :', memeco
481 if ( .not. memeco ) then
486 c 4.3. ==> On verifie que le noeud lenoeu ne traverse pas
489 do 43 , iaux = 1 , sdim
490 v1(iaux) = coonoe(spn,iaux)
494 if ( sdim.eq.2 ) then
495 call utsen2 ( memeco, v1, v2, v3, coopro, iaux )
497 call utsen3 ( memeco, v1, v2, v3, coopro, iaux )
500 cgn write (ulsort,*) 'Du bon cote de spn/sqn :', memeco
502 if ( .not. memeco ) then
507 c 4.4. ==> Qualite future des triangles issus du decoupage
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)
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
518 do 442 , iaux = 1 , sdim
519 conotr(1,iaux) = coonoe(sqn,iaux)
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
525 do 443 , iaux = 1 , sdim
526 conotr(2,iaux) = coonoe(sq,iaux)
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
532 c On limite le facteur d'accroissement
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
548 #ifdef _DEBUG_HOMARD_
549 write (ulsort,*) '5. la fin ; codret = ', codret
554 #ifdef _DEBUG_HOMARD_
555 if ( bilan.ne.0 ) then
556 write(ulsort,texte(langue,5)) lenoeu
560 if ( codret.ne.0 ) then
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
573 #ifdef _DEBUG_HOMARD_
574 write (ulsort,texte(langue,1)) 'Sortie', nompro