1 subroutine utb13c ( coonoe,
8 > grfmpo, grfmtl, grfmtb,
9 > nbgrfm, nomgro, lgnogr,
13 > ulsort, langue, codret )
14 c ______________________________________________________________________
18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
21 c aupres des huissiers de justice Simart et Lavoir a Clamart
22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
23 c aupres des huissiers de justice
24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
26 c HOMARD est une marque deposee d'Electricite de France
32 c ______________________________________________________________________
34 c UTilitaire - Bilan sur le maillage - option 13 - phase c
36 c ______________________________________________________________________
38 c surfaces des sous-domaines du maillage de calcul
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . coonoe . e . nbnoto . coordonnees des noeuds .
45 c . somare . e .2*nbarto. numeros des extremites d'arete .
46 c . hettri . e . nbtrto . historique de l'etat des triangles .
47 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
48 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
49 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
50 c . famtri . e . nbtrto . famille des triangles .
51 c . cfatri . e . nctftr*. codes des familles des triangles .
52 c . . . nbftri . 1 : famille MED .
53 c . . . . 2 : type de triangle .
54 c . . . . 3 : numero de surface de frontiere .
55 c . . . . 4 : famille des aretes internes apres raf.
56 c . . . . + l : appartenance a l'equivalence l .
57 c . famqua . e . nbquto . famille des quadrangles .
58 c . cfaqua . e . nctfqu*. codes des familles des quadrangles .
59 c . . . nbfqua . 1 : famille MED .
60 c . . . . 2 : type de quadrangle .
61 c . . . . 3 : numero de surface de frontiere .
62 c . . . . 4 : famille des aretes internes apres raf.
63 c . . . . 5 : famille des triangles de conformite .
64 c . . . . 6 : famille de sf active/inactive .
65 c . . . . + l : appartenance a l'equivalence l .
66 c . nbfmed . e . 1 . nombre de familles au sens MED .
67 c . numfam . e . nbfmed . numero des familles au sens MED .
68 c . grfmpo . e .0:nbfmed. pointeur des groupes des familles .
69 c . grfmtl . e . * . taille des groupes des familles .
70 c . grfmtb . e .10ngrouc. table des groupes des familles .
71 c . nbgrfm . e . 1 . nombre de groupes .
72 c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) .
73 c . lgnogr . e . nbgrfm . longueur des noms des groupes .
74 c . famnum . a . * . famille : numero avec une valeur .
75 c . famval . a . * . famille : la valeur .
76 c . lifagr . a . * . liste des familles contenant le groupe .
77 c . ulbila . e . 1 . unite logique d'ecriture du bilan .
78 c . ulsort . e . 1 . unite logique de la sortie generale .
79 c . langue . e . 1 . langue des messages .
80 c . . . . 1 : francais, 2 : anglais .
81 c . codret . s . 1 . code de retour des modules .
82 c . . . . 0 : pas de probleme .
83 c . . . . 1 : probleme .
84 c .____________________________________________________________________.
87 c 0. declarations et dimensionnement
90 c 0.1. ==> generalites
96 parameter ( nompro = 'UTB13C' )
116 double precision coonoe(nbnoto,sdim)
118 integer somare(2,nbarto)
119 integer hettri(nbtrto), aretri(nbtrto,3)
120 integer hetqua(nbquto), arequa(nbquto,4)
122 integer famtri(nbtrto), cfatri(nctftr,nbftri)
123 integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
125 integer nbfmed, numfam(nbfmed)
126 integer grfmpo(0:nbfmed)
128 integer nbgrfm, lgnogr(nbgrfm)
130 character*8 grfmtb(*)
131 character*8 nomgro(*)
134 double precision famval(*)
139 integer ulsort, langue, codret
141 c 0.4. ==> variables locales
143 integer iaux, jaux, kaux
144 integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1
145 integer a1, a2, a3, a4
146 integer letria, lequad
150 double precision v1(3), v2(3), v3(3), vn(3), vdiag(3)
151 double precision daux, daux1, daux2
154 parameter (nbmess = 20 )
155 character*80 texte(nblang,nbmess)
157 c 0.5. ==> initialisations
158 c ______________________________________________________________________
166 #ifdef _DEBUG_HOMARD_
167 write (ulsort,texte(langue,1)) 'Entree', nompro
171 texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)'
172 texte(1,5) = '(''. Examen du '',a,i8)'
173 texte(1,6) = '(''... Surface du '',a,i8,'' :'',g16.8)'
174 texte(1,7) = '(''..... Stockage'',i8,'' pour la famille '',i8)'
176 texte(2,4) = '(''Number of active '',a,'' : '',i8)'
177 texte(2,5) = '(''. Examination of '',a,''#'',i8)'
178 texte(2,6) = '(''... Surface of '',a,''#'',i8,'' :'',g14.6)'
179 texte(2,7) = '(''..... Save'',i8,'' for familiy # '',i8)'
183 #ifdef _DEBUG_HOMARD_
184 write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrac
185 write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquac
191 c 2. calcul des surfaces
194 c 2.1. ==> initialisation
198 if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then
200 jaux = nbtrac + nbquac
201 do 21 , iaux = 1 , jaux
205 #ifdef _DEBUG_HOMARD_
206 write (ulsort,*) 'jaux = ', jaux
211 c 2.2. ==> les zones maillees en triangles
213 if ( nbtrac.gt.0 ) then
215 do 22 , letria = 1, nbtrto
217 #ifdef _DEBUG_HOMARD_
218 write (ulsort,texte(langue,5)) mess14(langue,1,2), letria
221 if ( cfatri(cotyel,famtri(letria)).ne.0 ) then
223 etat = mod( hettri(letria) , 10 )
225 if ( etat.eq.0 ) then
227 c 2.2.1. ==> les aretes et les noeuds du triangle
229 iaux = aretri(letria,1)
230 jaux = aretri(letria,2)
231 kaux = aretri(letria,3)
233 call utsotr ( somare, iaux, jaux, kaux,
234 > sa1a2, sa2a3, sa3a1 )
236 c 2.2.2. ==> calcul de la surface
237 c on rappelle que la surface d'un triangle est egale
238 c a la moitie de la norme du produit vectoriel de deux
239 c des vecteurs representant les aretes.
241 if ( sdim.eq.2 ) then
243 v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1)
244 v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2)
246 v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1)
247 v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2)
249 daux = abs( v2(1)*v3(2) - v2(2)*v3(1) )
253 v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1)
254 v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2)
255 v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3)
257 v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1)
258 v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2)
259 v3(3) = coonoe(sa3a1,3) - coonoe(sa1a2,3)
261 vn(1) = v2(2)*v3(3) - v2(3)*v3(2)
262 vn(2) = v2(3)*v3(1) - v2(1)*v3(3)
263 vn(3) = v2(1)*v3(2) - v2(2)*v3(1)
265 daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) )
270 #ifdef _DEBUG_HOMARD_
271 write (ulsort,texte(langue,6)) mess14(langue,1,2), letria, daux
274 c 2.2.3. ==> stockage dans la bonne famille
277 do 2231 , iaux = 1 , famnbv
278 if ( famnum(iaux).eq.cfatri(cofamd,famtri(letria)) ) then
285 famnum(jaux) = cfatri(cofamd,famtri(letria))
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,texte(langue,7)) jaux, famnum(jaux)
292 famval(jaux) = famval(jaux) + daux
302 c 2.3. ==> les zones maillees en quadrangles
304 if ( nbquac.gt.0 ) then
306 do 23 , lequad = 1, nbquto
308 #ifdef _DEBUG_HOMARD_
309 write (ulsort,texte(langue,5)) mess14(langue,1,4), lequad
312 if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then
314 etat = mod( hetqua(lequad) , 100 )
316 if ( etat.eq.0 ) then
318 c 2.3.1. ==> les aretes et les noeuds du quadrangle
320 a1 = arequa(lequad,1)
321 a2 = arequa(lequad,2)
322 a3 = arequa(lequad,3)
323 a4 = arequa(lequad,4)
325 call utsoqu ( somare, a1, a2, a3, a4,
326 > sa1a2, sa2a3, sa3a4, sa4a1 )
328 c 2.3.2. ==> calcul de la surface
329 c pour la calculer, on coupe le quadrangle en deux triangles
330 c on rappelle que la surface d'un triangle est egale
331 c a la moitie de la norme du produit vectoriel de deux
332 c des vecteurs representant les aretes.
333 c v1 : arete a1 (sa4a1-sa1a2)
334 c v2 : arete a4 (sa4a1-sa3a4)
335 c vdiag = diagonale(sa4a1-sa2a3)
348 if ( sdim.eq.2 ) then
350 v1(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1)
351 v1(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2)
353 v2(1) = coonoe(sa3a4,1) - coonoe(sa4a1,1)
354 v2(2) = coonoe(sa3a4,2) - coonoe(sa4a1,2)
356 vdiag(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1)
357 vdiag(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2)
359 daux1 = abs ( v1(1)*vdiag(2) - v1(2)*vdiag(1) )
361 daux2 = abs ( v2(1)*vdiag(2) - v2(2)*vdiag(1) )
365 v1(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1)
366 v1(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2)
367 v1(3) = coonoe(sa1a2,3) - coonoe(sa4a1,3)
369 v2(1) = coonoe(sa3a4,1) - coonoe(sa4a1,1)
370 v2(2) = coonoe(sa3a4,2) - coonoe(sa4a1,2)
371 v2(3) = coonoe(sa3a4,3) - coonoe(sa4a1,3)
373 vdiag(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1)
374 vdiag(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2)
375 vdiag(3) = coonoe(sa2a3,3) - coonoe(sa4a1,3)
377 vn(1) = v1(2)*vdiag(3) - v1(3)*vdiag(2)
378 vn(2) = v1(3)*vdiag(1) - v1(1)*vdiag(3)
379 vn(3) = v1(1)*vdiag(2) - v1(2)*vdiag(1)
381 daux1 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) )
383 vn(1) = v2(2)*vdiag(3) - v2(3)*vdiag(2)
384 vn(2) = v2(3)*vdiag(1) - v2(1)*vdiag(3)
385 vn(3) = v2(1)*vdiag(2) - v2(2)*vdiag(1)
387 daux2 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) )
391 daux = unsde * ( daux1 + daux2 )
393 #ifdef _DEBUG_HOMARD_
394 write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad, daux
397 c 2.3.3. ==> stockage dans la bonne famille
400 do 2331 , iaux = 1 , famnbv
401 if ( famnum(iaux).eq.cfaqua(cofamd,famqua(lequad)) ) then
408 famnum(jaux) = cfaqua(cofamd,famqua(lequad))
411 #ifdef _DEBUG_HOMARD_
412 write (ulsort,texte(langue,7)) jaux, famnum(jaux)
415 famval(jaux) = famval(jaux) + daux
428 #ifdef _DEBUG_HOMARD_
429 write (ulsort,*) '3. impression ; codret =', codret
430 write (ulsort,90002) 'famnbv', famnbv
433 if ( famnbv.ne.0 ) then
437 #ifdef _DEBUG_HOMARD_
438 write (ulsort,texte(langue,3)) 'UTB13E_fac', nompro
440 call utb13e ( kaux, iaux,
442 > grfmpo, grfmtl, grfmtb,
443 > nbgrfm, nomgro, lgnogr,
444 > famnbv, famnum, famval,
447 > ulsort, langue, codret )