1 subroutine mmag41 ( coonoe, somare, aretri,
6 > grfmpo, grfmtl, grfmtb,
7 > nbgrfm, nomgro, lgnogr,
11 > ulsort, langue, codret )
12 c ______________________________________________________________________
16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
19 c aupres des huissiers de justice Simart et Lavoir a Clamart
20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
21 c aupres des huissiers de justice
22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
24 c HOMARD est une marque deposee d'Electricite de France
30 c ______________________________________________________________________
32 c Modification de Maillage - AGRegat - phase 4.1
34 c Taille des joints simples
35 c ______________________________________________________________________
37 c Remarque : ce programme est une copie de utb13c
38 c ______________________________________________________________________
40 c . nom . e/s . taille . description .
41 c .____________________________________________________________________.
42 c . coonoe . e . nbnoto . coordonnees des noeuds .
44 c . somare . e .2*nbarto. numeros des extremites d'arete .
45 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
46 c . fampen . e . nbpeto . famille des pentaedres .
47 c . cfapen . e . nctfpe*. codes des familles des pentaedres .
48 c . . . nbfpen . 1 : famille MED .
49 c . . . . 2 : type de pentaedres .
50 c . . . . 3 : famille des tetraedres de conformite .
51 c . . . . 4 : famille des pyramides de conformite .
52 c . nbpejs . e . 1 . nombre de pentaedres de joints simples .
53 c . nbjois . e . 1 . nombre de joints simples .
54 c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : .
55 c . . . . (1,i) : numero du triangle a dupliquer .
56 c . . . . (2,i) : numero du joint simple cree .
57 c . . . . (3,i) : tetraedre du cote min(fammed) .
58 c . . . . (4,i) : tetraedre du cote max(fammed) .
59 c . nbfmed . e . 1 . nombre de familles au sens MED .
60 c . numfam . e . nbfmed . numero des familles au sens MED .
61 c . grfmpo . e .0:nbfmed. pointeur des groupes des familles .
62 c . grfmtl . e . * . taille des groupes des familles .
63 c . grfmtb . e .10ngrouc. table des groupes des familles .
64 c . nbgrfm . e . 1 . nombre de groupes .
65 c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) .
66 c . lgnogr . e . nbgrfm . longueur des noms des groupes .
67 c . famnum . a . * . famille : numero avec une valeur .
68 c . famval . a . * . famille : la valeur .
69 c . lifagr . a . * . liste des familles contenant le groupe .
70 c . ulbila . e . 1 . unite logique d'ecriture du bilan .
71 c . ulsort . e . 1 . unite logique de la sortie generale .
72 c . langue . e . 1 . langue des messages .
73 c . . . . 1 : francais, 2 : anglais .
74 c . codret . s . 1 . code de retour des modules .
75 c . . . . 0 : pas de probleme .
76 c . . . . 1 : probleme .
77 c .____________________________________________________________________.
80 c 0. declarations et dimensionnement
83 c 0.1. ==> generalites
89 parameter ( nompro = 'MMAG41' )
110 double precision coonoe(nbnoto,sdim)
112 integer nbpejs, nbjois
113 integer somare(2,nbarto), aretri(nbtrto,3)
114 integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
115 integer tbaux1(4,nbpejs)
117 integer nbfmed, numfam(nbfmed)
118 integer grfmpo(0:nbfmed)
120 integer nbgrfm, lgnogr(nbgrfm)
122 character*8 grfmtb(*)
123 character*8 nomgro(*)
126 double precision famval(*)
131 integer ulsort, langue, codret
133 c 0.4. ==> variables locales
135 integer iaux, jaux, kaux
137 integer sa1a2, sa2a3, sa3a1
140 double precision v2(3), v3(3), vn(3)
141 double precision daux
144 parameter (nbmess = 30 )
145 character*80 texte(nblang,nbmess)
147 c 0.5. ==> initialisations
148 c ______________________________________________________________________
156 #ifdef _DEBUG_HOMARD_
157 write (ulsort,texte(langue,1)) 'Entree', nompro
165 #ifdef _DEBUG_HOMARD_
166 write (ulsort,90002) 'nbjois', nbjois
167 write (ulsort,90002) 'nbpejs', nbpejs
173 c 2. calcul des surfaces
176 c 2.1. ==> initialisation
178 do 21 , iaux = 1 , nbjois
184 do 22 , numpen = 1 , nbpejs
186 letria = tbaux1(1,numpen)
188 #ifdef _DEBUG_HOMARD_
189 write (ulsort,90002) 'numpen', numpen
190 write (ulsort,texte(langue,4)) ' ', mess14(langue,1,2), letria
191 write (ulsort,texte(langue,18)) ' ',mess14(langue,1,7),
195 c 2.2.1. ==> les aretes et les noeuds du triangle
197 iaux = aretri(letria,1)
198 jaux = aretri(letria,2)
199 kaux = aretri(letria,3)
201 call utsotr ( somare, iaux, jaux, kaux,
202 > sa1a2, sa2a3, sa3a1 )
204 c 2.2.2. ==> calcul de la surface
205 c on rappelle que la surface d'un triangle est egale
206 c a la moitie de la norme du produit vectoriel de deux
207 c des vecteurs representant les aretes.
209 v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1)
210 v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2)
211 v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3)
213 v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1)
214 v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2)
215 v3(3) = coonoe(sa3a1,3) - coonoe(sa1a2,3)
217 vn(1) = v2(2)*v3(3) - v2(3)*v3(2)
218 vn(2) = v2(3)*v3(1) - v2(1)*v3(3)
219 vn(3) = v2(1)*v3(2) - v2(2)*v3(1)
221 daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) )
225 c 2.2.3. ==> stockage dans le bon joint
227 iaux = tbaux1(2,numpen)
228 famnum(iaux) = cfapen(cofamd,fampen(numpen))
229 famval(iaux) = famval(iaux) + daux
230 cgn if ( iaux.ge.1 ) then
231 cgn write (ulsort,90002) 'noeuds', sa1a2, sa2a3, sa3a1
232 cgn write (ulsort,92010) '==> surface =', daux
233 cgn write (ulsort,90002) 'iaux, fampen, fammed', iaux,
234 cgn > fampen(numpen),cfapen(cofamd,fampen(numpen))
235 cgn write (ulsort,92010) '==> cumul =',famval(iaux)
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,*) '3. impression ; codret =', codret
245 write (ulsort,91010) (famnum(iaux),iaux=1,nbjois)
246 write (ulsort,92010) (famval(iaux),iaux=1,nbjois)
251 #ifdef _DEBUG_HOMARD_
252 write (ulsort,texte(langue,3)) 'UTB13E_j_simple', nompro
254 call utb13e ( kaux, iaux,
256 > grfmpo, grfmtl, grfmtb,
257 > nbgrfm, nomgro, lgnogr,
258 > nbjois, famnum, famval,
261 > ulsort, langue, codret )
267 if ( codret.ne.0 ) then
271 write (ulsort,texte(langue,1)) 'Sortie', nompro
272 write (ulsort,texte(langue,2)) codret
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,texte(langue,1)) 'Sortie', nompro