1 subroutine utequa ( nbquto, nbqual, nbnoal, sdim,
2 > coonoe, somare, arequa,
3 > nmprog, avappr, ulbila,
4 > ulsort, langue, codret )
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c UTilitaire - Examen des QUAdrangles
27 c ______________________________________________________________________
29 c . nom . e/s . taille . description .
30 c .____________________________________________________________________.
31 c . nbquto . e . 1 . nombre de quadrangles a examiner .
32 c . nbqual . e . 1 . nombre de quadrangles pour les allocations .
33 c . nbnoal . e . 1 . nombre de noeuds pour les allocations .
34 c . sdim . e . 1 . dimension du maillage .
35 c . coonoe . e . nbnoal . coordonnees des noeuds .
37 c . somare . e . 2*nbar . numeros des extremites d'arete .
38 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
39 c . nmprog . e . char* . nom du programme a pister .
40 c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" .
41 c . . . . 2 : impression apres l'appel a "nmprog" .
42 c . ulbila . e . 1 . unite logique d'ecriture du bilan .
43 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
44 c . langue . e . 1 . langue des messages .
45 c . . . . 1 : francais, 2 : anglais .
46 c . codret . es . 1 . code de retour des modules .
47 c . . . . 0 : pas de probleme .
48 c . . . . >0 : probleme dans le controle .
49 c ______________________________________________________________________
52 c 0. declarations et dimensionnement
55 c 0.1. ==> generalites
61 parameter ( nompro = 'UTEQUA' )
72 integer nbquto, nbqual, nbnoal, sdim
74 integer arequa(nbqual,4)
76 double precision coonoe(nbnoal,sdim)
83 integer ulsort, langue, codret
85 c 0.4. ==> variables locales
88 integer iaux, jaux, kaux, laux
90 integer a1, a2, a3, a4
91 integer sa1a2, sa2a3, sa3a4, sa4a1
94 double precision v1(3), v2(3), v3(3), v4(3)
95 double precision v12(3), v34(3)
101 parameter ( nbmess = 20 )
102 character*80 texte(nblang,nbmess)
104 c 0.5. ==> initialisations
106 data saux01 / 'x', 'y', 'z' /
107 c ______________________________________________________________________
115 #ifdef _DEBUG_HOMARD_
116 write (ulsort,texte(langue,1)) 'Entree', nompro
120 texte(1,5) = '(5x,''Controle des '',i10,1x,a)'
121 texte(1,6) = '(a,'' numero '',i10)'
122 texte(1,7) = '(''Les '',a,'' sont :'',4i10)'
123 texte(1,8) = '(''Les '',a,'' sont confondus :'',4i10)'
124 texte(1,10) = '(''Le '',a,'' est croise.'')'
126 > '(5x,''Pas de probleme dans la definition des quadrangles'',/)'
127 texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
128 texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
129 texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
130 texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
132 texte(2,5) = '(5x,''Control of '',i10,1x,a)'
133 texte(2,6) = '(a,'' # '',i10)'
134 texte(2,7) = '(''The '',a,'' are :'',4i10)'
135 texte(2,8) = '(''The '',a,'' are similar :'',4i10)'
136 texte(2,10) = '(''The '',a,'' is overlapped.'')'
137 texte(2,16) = '(5x,''No problem with quadrangle definition'',/)'
138 texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
139 texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
140 texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
141 texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
143 1000 format('Arete a',i1,' :',i10,' de',i10,' a',i10)
144 1001 format('Noeud',i10,' :', 3(2x,a,' =',g12.5) )
146 #ifdef _DEBUG_HOMARD_
147 if ( avappr.ge.0 .and. avappr.le.2 ) then
148 write (ulsort,texte(langue,18+avappr)) nmprog
150 write (ulsort,texte(langue,17)) nmprog, avappr
153 write (ulsort,texte(langue,5)) nbquto, mess14(langue,3,4)
155 c 1.3. ==> constantes
163 ccc do 20 , iaux = 1 , nbquto
166 #ifdef _DEBUG_HOMARD_
167 write (ulsort,texte(langue,6)) mess14(langue,2,4), iaux
172 c 2.1. ==> les aretes doivent etre differentes ...
186 write (ulsort,texte(langue,6)) mess14(langue,2,4), iaux
187 write (ulsort,texte(langue,8)) mess14(langue,3,1), a1,a2,a3,a4
188 write (ulbila,texte(langue,6)) mess14(langue,2,4), iaux
189 write (ulbila,texte(langue,8)) mess14(langue,3,1), a1,a2,a3,a4
192 c 2.2. ==> les aretes doivent se suivre ...
194 if ( codre0.eq.0 ) then
203 #ifdef _DEBUG_HOMARD_
204 write (ulsort,texte(langue,3)) 'UTVAR0', nompro
206 call utvar0 ( jaux, iaux, kaux, listar, somare,
207 > ulbila, ulsort, langue, codre0 )
211 c 2.3. ==> les sommets doivent etre differents ...
213 if ( codre0.eq.0 ) then
215 #ifdef _DEBUG_HOMARD_
216 write (ulsort,texte(langue,3)) 'UTSOQU', nompro
218 call utsoqu ( somare, a1, a2, a3, a4,
219 > sa1a2, sa2a3, sa3a4, sa4a1 )
221 if ( sa1a2.eq.sa2a3 .or.
222 > sa1a2.eq.sa3a4 .or.
223 > sa1a2.eq.sa4a1 .or.
224 > sa2a3.eq.sa3a4 .or.
225 > sa2a3.eq.sa4a1 .or.
226 > sa1a2.eq.sa4a1 ) then
230 if ( ulsort.ne.ulbila ) then
236 do 23 , kaux = 1 , jaux
238 if ( kaux.eq.1 ) then
244 write (ulaux,texte(langue,8)) mess14(langue,3,-1),
245 > sa1a2, sa2a3, sa3a4, sa4a1
246 write(ulaux,*) 'a1',somare(1,a1),somare(2,a1)
247 write(ulaux,*) coonoe(somare(1,a1),1),coonoe(somare(1,a1),2)
248 > ,coonoe(somare(1,a1),3)
249 write(ulaux,*) coonoe(somare(2,a1),1),coonoe(somare(2,a1),2)
250 > ,coonoe(somare(2,a1),3)
251 write(ulaux,*) 'a2',somare(1,a2),somare(2,a2)
252 write(ulaux,*) coonoe(somare(1,a2),1),coonoe(somare(1,a2),2)
253 > ,coonoe(somare(1,a2),3)
254 write(ulaux,*) coonoe(somare(2,a2),1),coonoe(somare(2,a2),2)
255 > ,coonoe(somare(2,a2),3)
256 write(ulaux,*) 'a3',somare(1,a3),somare(2,a3)
257 write(ulaux,*) coonoe(somare(1,a3),1),coonoe(somare(1,a3),2)
258 > ,coonoe(somare(1,a3),3)
259 write(ulaux,*) coonoe(somare(2,a3),1),coonoe(somare(2,a3),2)
260 > ,coonoe(somare(2,a3),3)
261 write(ulaux,*) 'a4',somare(1,a4),somare(2,a4)
262 write(ulaux,*) coonoe(somare(1,a4),1),coonoe(somare(1,a4),2)
263 > ,coonoe(somare(1,a4),3)
264 write(ulaux,*) coonoe(somare(2,a4),1),coonoe(somare(2,a4),2)
265 > ,coonoe(somare(2,a4),3)
266 write(ulaux,*) coonoe(sa1a2,1), coonoe(sa1a2,2),
268 write(ulaux,*) coonoe(sa2a3,1), coonoe(sa2a3,2),
270 write(ulaux,*) coonoe(sa3a4,1), coonoe(sa3a4,2),
272 write(ulaux,*) coonoe(sa4a1,1), coonoe(sa4a1,2),
281 c 2.4. ==> il ne faut pas croiser ...
282 c pour cela, il faut que les deux produits vectoriels
283 c a1xa2 et a3xa4 soient dans la meme orientation. On teste
284 c si leur produit scalaire est >0
285 c Remarque : cela suppose que le quadrangle est plan
287 c sa4a1 a4 sa3a4 sa4a1 sa2a3
291 c a1. .a3 a1. . . .a3
297 c sa1a2 a2 sa2a3 sa1a2 sa3a4
300 if ( codre0.eq.0 ) then
302 if ( sdim.eq.2 ) then
304 v1(1) = coonoe(sa4a1,1) - coonoe(sa1a2,1)
305 v1(2) = coonoe(sa4a1,2) - coonoe(sa1a2,2)
307 v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1)
308 v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2)
310 v3(1) = coonoe(sa2a3,1) - coonoe(sa3a4,1)
311 v3(2) = coonoe(sa2a3,2) - coonoe(sa3a4,2)
313 v4(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1)
314 v4(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2)
316 c v12 represente le produit vectoriel a1xa2.
318 v12(3) = v1(1)*v2(2) - v1(2)*v2(1)
320 c v34 represente le produit vectoriel a3xa4.
322 v34(3) = v3(1)*v4(2) - v3(2)*v4(1)
326 #ifdef _DEBUG_HOMARD_
327 if ( iaux.eq.1 ) then
328 write (ulsort,texte(langue,7)) mess14(langue,3,-1),
329 > sa1a2, sa2a3, sa3a4, sa4a1
330 write (ulsort,1001) sa1a2,
331 > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim)
332 write (ulsort,1001) sa2a3,
333 > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim)
334 write (ulsort,1001) sa3a4,
335 > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim)
336 write (ulsort,1001) sa4a1,
337 > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim)
339 write (ulsort,1789) 'v1', v1(1), v1(2)
340 write (ulsort,1789) 'v2', v2(1), v2(2)
341 write (ulsort,1789) 'v3', v3(1), v3(2)
342 write (ulsort,1789) 'v4', v4(1), v4(2)
344 write (ulsort,1789) 'v12(3) = ', v12(3)
345 write (ulsort,1789) 'v34(3) = ', v34(3)
346 write (ulsort,1789) ' ==> daux =',daux
348 1789 format(a,' : ',2g13.5,a,g13.5)
353 v1(1) = coonoe(sa4a1,1) - coonoe(sa1a2,1)
354 v1(2) = coonoe(sa4a1,2) - coonoe(sa1a2,2)
355 v1(3) = coonoe(sa4a1,3) - coonoe(sa1a2,3)
357 v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1)
358 v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2)
359 v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3)
361 v3(1) = coonoe(sa2a3,1) - coonoe(sa3a4,1)
362 v3(2) = coonoe(sa2a3,2) - coonoe(sa3a4,2)
363 v3(3) = coonoe(sa2a3,3) - coonoe(sa3a4,3)
365 v4(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1)
366 v4(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2)
367 v4(3) = coonoe(sa4a1,3) - coonoe(sa3a4,3)
369 c v12 represente le produit vectoriel a1xa2.
371 v12(1) = v1(2)*v2(3) - v1(3)*v2(2)
372 v12(2) = v1(3)*v2(1) - v1(1)*v2(3)
373 v12(3) = v1(1)*v2(2) - v1(2)*v2(1)
375 c v34 represente le produit vectoriel a3xa4.
377 v34(1) = v3(2)*v4(3) - v3(3)*v4(2)
378 v34(2) = v3(3)*v4(1) - v3(1)*v4(3)
379 v34(3) = v3(1)*v4(2) - v3(2)*v4(1)
381 daux = v12(1)*v34(1) + v12(2)*v34(2) + v12(3)*v34(3)
383 #ifdef _DEBUG_HOMARD_
384 if ( iaux.eq.1 ) then
385 write (ulsort,texte(langue,7)) mess14(langue,3,-1),
386 > sa1a2, sa2a3, sa3a4, sa4a1
387 write (ulsort,1001) sa1a2,
388 > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim)
389 write (ulsort,1001) sa2a3,
390 > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim)
391 write (ulsort,1001) sa3a4,
392 > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim)
393 write (ulsort,1001) sa4a1,
394 > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim)
396 write (ulsort,1792) 'v1', v1(1), v1(2)
397 write (ulsort,1792) 'v2', v2(1), v2(2)
398 write (ulsort,1792) 'v3', v3(1), v3(2)
399 write (ulsort,1792) 'v4', v4(1), v4(2)
401 write (ulsort,1792) 'v12(1) = ', v12(1)
402 write (ulsort,1792) 'v12(2) = ', v12(2)
403 write (ulsort,1792) 'v12(3) = ', v12(3)
404 write (ulsort,1792) 'v34(1) = ', v34(1)
405 write (ulsort,1792) 'v34(2) = ', v34(2)
406 write (ulsort,1792) 'v34(3) = ', v34(3)
407 write (ulsort,1792) ' ==> daux =',daux
409 1792 format(a,' : ',2g13.5,a,g13.5)
414 if ( daux.le.0.d0 ) then
418 if ( ulsort.ne.ulbila ) then
424 do 24 , kaux = 1 , jaux
426 if ( kaux.eq.1 ) then
432 write (ulaux,texte(langue,6)) mess14(langue,2,4), iaux
433 write (ulaux,texte(langue,7)) mess14(langue,3,-1),
434 > sa1a2, sa2a3, sa3a4, sa4a1
435 write (ulaux,texte(langue,10)) mess14(langue,1,4)
436 write(ulaux,1001) sa1a2,
437 > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim)
438 write(ulaux,1001) sa2a3,
439 > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim)
440 write(ulaux,1001) sa3a4,
441 > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim)
442 write(ulaux,1001) sa4a1,
443 > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim)
444 cgn write(ulaux,*) coonoe(sa1a2,1), coonoe(sa1a2,2),
445 cgn > coonoe(sa1a2,3)
446 cgn write(ulaux,*) coonoe(sa2a3,1), coonoe(sa2a3,2),
447 cgn > coonoe(sa2a3,3)
448 cgn write(ulaux,*) coonoe(sa3a4,1), coonoe(sa3a4,2),
449 cgn > coonoe(sa3a4,3)
450 cgn write(ulaux,*) coonoe(sa4a1,1), coonoe(sa4a1,2),
451 cgn > coonoe(sa4a1,3)
452 write(ulaux,1000) 1,a1,somare(1,a1),somare(2,a1)
453 cgn write(ulaux,1001) somare(1,a1),coonoe(somare(1,a1),1),
454 cgn > coonoe(somare(1,a1),2),coonoe(somare(1,a1),3)
455 cgn write(ulaux,1001) somare(2,a1),coonoe(somare(2,a1),1),
456 cgn > coonoe(somare(2,a1),2),coonoe(somare(2,a1),3)
457 write(ulaux,1000) 2,a2,somare(1,a2),somare(2,a2)
458 cgn write(ulaux,1001) somare(1,a2),coonoe(somare(1,a2),1),
459 cgn > coonoe(somare(1,a2),2),coonoe(somare(1,a2),3)
460 cgn write(ulaux,1001) somare(2,a2),coonoe(somare(2,a2),1),
461 cgn > coonoe(somare(2,a2),2),coonoe(somare(2,a2),3)
462 write(ulaux,1000) 3,a3,somare(1,a3),somare(2,a3)
463 cgn write(ulaux,1001) somare(1,a3), coonoe(somare(1,a3),1),
464 cgn > coonoe(somare(1,a3),2),coonoe(somare(1,a3),3)
465 cgn write(ulaux,1001) somare(2,a3), coonoe(somare(2,a3),1),
466 cgn > coonoe(somare(2,a3),2),coonoe(somare(2,a3),3)
467 write(ulaux,1000) 4,a4,somare(1,a4),somare(2,a4)
468 cgn write(ulaux,1001) somare(1,a4), coonoe(somare(1,a4),1),
469 cgn > coonoe(somare(1,a4),2),coonoe(somare(1,a4),3)
470 cgn write(ulaux,1001) somare(2,a4), coonoe(somare(2,a4),1),
471 cgn > coonoe(somare(2,a4),2),coonoe(somare(2,a4),3)
479 c 2.5. ==> cumul des erreurs
481 codret = codret + codre0
485 c 2.6. ==> tout va bien
487 if ( codret.eq.0 ) then
488 write (ulsort,texte(langue,16))
489 write (ulbila,texte(langue,16))
496 if ( codret.ne.0 ) then
500 write (ulsort,texte(langue,1)) 'Sortie', nompro
501 write (ulsort,texte(langue,2)) codret
505 #ifdef _DEBUG_HOMARD_
506 write (ulsort,texte(langue,1)) 'Sortie', nompro