1 subroutine mmag10 ( somare,
4 > nbjois, nbpejs, tbaux1, tbaux2,
7 > nbduno, nbduar, nbdutr,
8 > nbnotn, nbartn, nbtrtn, nbqutn,
9 > nbtetn, nbpetn, nbhetn,
10 > nbjoit, nbpejt, nbtrjt,
11 > nbjoiq, nbhejq, nbqujq,
17 > ntra51, ptra51, ntra52, ptra52,
19 > ulsort, langue, codret )
20 c ______________________________________________________________________
24 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
26 c Version originale enregistree le 18 juin 1996 sous le numero 96036
27 c aupres des huissiers de justice Simart et Lavoir a Clamart
28 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
29 c aupres des huissiers de justice
30 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
32 c HOMARD est une marque deposee d'Electricite de France
38 c ______________________________________________________________________
40 c Modification de Maillage - AGregat - phase 1.0
42 c Connaissant le nombre et les caracteristiques des pentaedres
43 c a creer pour les joints simples :
44 c . Decompte du nombre de noeuds, aretes, quadrangles a creer
45 c . Decompte du nombre de joints multiples
46 c ______________________________________________________________________
48 c . nom . e/s . taille . description .
49 c .____________________________________________________________________.
50 c . somare . e .2*nbarto. numeros des extremites d'arete .
51 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
52 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
53 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
54 c . nbjois . e . 1 . nombre de joints simples .
55 c . nbpejs . e . 1 . nombre de pentaedres de joints simples .
56 c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : .
57 c . . . . (1,i) : numero du triangle a dupliquer .
58 c . . . . (2,i) : numero du joint simple cree .
59 c . . . . (3,i) : tetraedre du cote min(fammed) .
60 c . . . . (4,i) : tetraedre du cote max(fammed) .
61 c . tbaux2 . es . 4** . Pour le i-eme joint : .
62 c . . . . Numeros des familles MED des volumes .
63 c . . . . jouxtant le pentaedre/hexaedre, classes du .
64 c . . . . plus petit (1,i) au plus grand .
65 c . . . . 0, si pas de volume voisin .
66 c . tbau30 . s . 8** . Pour la i-eme duplication de noeud : .
67 c . . . . (1,i) : noeud a dupliquer .
68 c . . . . (2,i) : arete construite sur le noeud .
69 c . . . . (3,i) : noeud cree cote min(fammed) .
70 c . . . . (4,i) : noeud cree cote max(fammed) .
71 c . . . . (5,i) : numero du joint simple cree .
72 c . . . . (6,i) : arete entrant dans le cote 1 .
73 c . . . . (7,i) : arete entrant dans le cote 2 .
74 c . . . . (8,i) : ordre de multiplicite .
75 c . tbau40 . s . 6** . Pour la i-eme duplication d'arete : .
76 c . . . . (1,i) : arete a dupliquer .
77 c . . . . (2,i) : arete creee cote min(fammed) .
78 c . . . . (3,i) : arete creee cote max(fammed) .
79 c . . . . (4,i) : numero du joint simple cree .
80 c . . . . (5,i) : ordre de multiplicite .
81 c . . . . (6,i) : arete d'orientation de joint .
82 c . tbau31 . s . 2** . Les triangles puis les quadrangles .
83 c . . . . construits sur un noeud multiple : .
84 c . . . . (1,i) : noeud multiple .
85 c . . . . (2,i) : numero du joint multiple cree .
86 c . tbau41 . s . 4** . Les pentaedres de joint triple, puis les .
87 c . . . . hexaedres de joint quadruple : .
88 c . . . . (1,i) : arete multiple .
89 c . . . . (2,i) : numero du joint .
90 c . . . . Pour le i-eme pentaedre de joint triple : .
91 c . . . . (3,i) : triangle cree cote 1er sommet .
92 c . . . . (4,i) : triangle cree cote 2nd sommet .
93 c . . . . Pour le i-eme hexaedre de joint quadruple :.
94 c . . . . (3,i) : quadrangle cree cote 1er sommet .
95 c . . . . (4,i) : quadrangle cree cote 2nd sommet .
96 c . nbduno . s . 1 . nombre de duplications de noeuds .
97 c . nbduar . s . 1 . nombre de duplications d'aretes .
98 c . nbdutr . s . 1 . nombre de duplications de triangles .
99 c . nbnotn . s . 1 . nombre de noeuds total nouveau .
100 c . nbartn . s . 1 . nombre d'aretes total nouveau .
101 c . nbtrtn . s . 1 . nombre de triangles total nouveau .
102 c . nbqutn . s . 1 . nombre de quadrangles total nouveau .
103 c . nbtetn . s . 1 . nombre de tetraaedres total nouveau .
104 c . nbpetn . s . 1 . nombre de pentaedres total nouveau .
105 c . nbhetn . s . 1 . nombre d'hexaedres total nouveau .
106 c . nbjoit . s . 1 . nombre de joints triples .
107 c . nbpejt . s . 1 . nombre de pentaedres de joints triples .
108 c . nbtrjt . s . 1 . nombre de triangles de joints triples .
109 c . nbjoiq . s . 1 . nombre de joints quadruples .
110 c . nbhejq . s . 1 . nombre d'hexaedres de joints quadruples .
111 c . nbqujq . s . 1 . nombre de quad. crees pour j. quadruples .
112 c . nbjp06 . s . 1 . nombre de joints ponctuels ordre 6 .
113 c . nbte06 . s . 1 . nombre de tetr. des j. ponctuels d'ordre 6 .
114 c . nbjp09 . s . 1 . nombre de joints ponctuels ordre 9 .
115 c . nbpe09 . s . 1 . nombre de pent. des j. ponctuels d'ordre 9 .
116 c . nbjp12 . s . 1 . nombre de joints ponctuels ordre 12 .
117 c . nbhe12 . s . 1 . nombre de hexa. des j. ponctuels d'ordre 12.
118 c . nbvojm . s . 1 . nombre de volumes de joints multiples .
119 c . tbaux5 . --- . 4** . Pour la i-eme duplication d'arete : .
120 c . . . . (1,i), (2,i), (3,i), (4,i) .
121 c . . . . numeros ordonnes des joints simples crees .
122 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
123 c . langue . e . 1 . langue des messages .
124 c . . . . 1 : francais, 2 : anglais .
125 c . codret . es . 1 . code de retour des modules .
126 c . . . . 0 : pas de probleme .
127 c ______________________________________________________________________
130 c 0. declarations et dimensionnement
133 c 0.1. ==> generalites
139 parameter ( nompro = 'MMAG10' )
156 integer somare(2,nbarto)
157 integer aretri(nbtrto,3)
158 integer tritet(nbtecf,4), cotrte(nbtecf,4)
159 integer nbjois, nbpejs
160 integer tbaux1(4,nbpejs), tbaux2(4,*)
161 integer tbau30(8,*), tbau40(6,*)
162 integer tbau31(2,*), tbau41(4,*)
165 integer nbduno, nbduar, nbdutr
166 integer nbnotn, nbartn, nbtrtn, nbqutn
167 integer nbtetn, nbpetn, nbhetn
168 integer nbjoit, nbpejt, nbtrjt
169 integer nbjoiq, nbhejq, nbqujq
170 integer nbjp06, nbte06
171 integer nbjp09, nbpe09
172 integer nbjp12, nbhe12
174 integer ptra51, ptra52, ptra53
176 character*8 ntra51, ntra52, ntra53
178 integer ulsort, langue, codret
180 c 0.4. ==> variables locales
182 integer codre1, codre2, codre3
186 #ifdef _DEBUG_HOMARD_
189 integer indnoe, indare
190 integer multax, multnx
193 parameter ( muarmx = 4 )
194 integer nbarmu(muarmx)
197 parameter ( munomx = 12 )
198 integer nbnomu(munomx)
201 parameter ( nbmess = 30 )
202 character*80 texte(nblang,nbmess)
204 c 0.5. ==> initialisations
205 c ______________________________________________________________________
214 #ifdef _DEBUG_HOMARD_
215 write (ulsort,texte(langue,1)) 'Entree', nompro
221 #ifdef _DEBUG_HOMARD_
222 write (ulsort,texte(langue,12)) nbjois
223 write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs
226 c 1.2. ==> Constantes
235 #ifdef _DEBUG_HOMARD_
236 write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr
240 c 2. Reperage des joints simples
243 if ( codret.eq.0 ) then
247 #ifdef _DEBUG_HOMARD_
248 write (ulsort,texte(langue,3)) 'MMAG11', nompro
250 call mmag11 ( somare,
253 > nbpejs, tbaux1, tbaux2,
255 > nbduno, nbduar, nbdutr,
257 > ulsort, langue, codret )
263 if ( codret.eq.0 ) then
265 #ifdef _DEBUG_HOMARD_
266 write (ulsort,texte(langue,11)) mess14(langue,3,-1),indnoe-nbnoto
267 write (ulsort,texte(langue,11)) mess14(langue,3,1), indare-nbarto
268 write (ulsort,texte(langue,11)) mess14(langue,3,2), 2*nbdutr
269 write (ulsort,texte(langue,11)) mess14(langue,3,4), nbduar
274 nbtrtn = nbtrto + 2*nbdutr
277 #ifdef _DEBUG_HOMARD_
278 write (ulsort,texte(langue,10)) mess14(langue,3,-1), nbnotn
279 write (ulsort,texte(langue,10)) mess14(langue,3,1), nbartn
280 write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn
281 write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn
287 c 3. Reperage des joints multiples
292 c 3.1. ==> Recherche des aretes et des noeuds multiples
294 if ( codret.eq.0 ) then
296 #ifdef _DEBUG_HOMARD_
297 write (ulsort,texte(langue,3)) 'MMAG12', nompro
299 call mmag12 ( muarmx, nbarmu, multax,
300 > munomx, nbnomu, multnx,
304 > ulsort, langue, codret )
308 c 3.2. ==> Allocation
310 if ( codret.eq.0 ) then
313 do 32 , iaux = 4 , multnx
314 jaux = jaux + nbnomu(iaux)
317 iaux = (1+2*4)*nbnomu(6)
318 call gmalot ( ntra51, 'entier ', iaux, ptra51, codre1 )
320 iaux = (1+2*5)*nbnomu(9)
321 call gmalot ( ntra52, 'entier ', iaux, ptra52, codre2 )
323 iaux = (1+2*6)*nbnomu(12)
324 call gmalot ( ntra53, 'entier ', iaux, ptra53, codre3 )
326 codre0 = min ( codre1, codre2, codre3 )
327 codret = max ( abs(codre0), codret,
328 > codre1, codre2, codre3 )
332 c 3.3. ==> Creation des mailles a partir des aretes et noeuds multiples
334 if ( codret.eq.0 ) then
336 #ifdef _DEBUG_HOMARD_
337 write (ulsort,texte(langue,3)) 'MMAG13', nompro
339 call mmag13 ( muarmx, nbarmu, multax, multnx,
342 > nbduno, nbduar, nbtrtn, nbqutn,
345 > imem(ptra51), imem(ptra52), imem(ptra53),
346 > nbjoit, nbpejt, nbtrjt,
347 > nbjoiq, nbhejq, nbqujq,
352 > ulsort, langue, codret )
364 c 4.1. ==> Nouvelles entites
366 if ( codret.eq.0 ) then
368 nbtrtn = nbtrtn + nbtrjt
369 nbqutn = nbqutn + nbqujq
370 nbtetn = nbteto + nbte06
371 nbpetn = nbpejs + nbpejt + nbpe09
372 nbhetn = nbhejq + nbhe12
374 nbvojm = nbpejt + nbhejq
376 #ifdef _DEBUG_HOMARD_
377 write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn
378 write (ulsort,texte(langue,10)) mess14(langue,3,3), nbtetn
379 write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn
380 write (ulsort,texte(langue,10)) mess14(langue,3,7), nbpetn
381 write (ulsort,texte(langue,10)) mess14(langue,3,6), nbhetn
386 c 4.2. ==> Joints triples
388 if ( nbjoit.gt.0 ) then
390 if ( codret.eq.0 ) then
392 write (ulsort,texte(langue,13)) nbjoit
393 write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpejt
394 #ifdef _DEBUG_HOMARD_
395 write (ulsort,texte(langue,11)) mess14(langue,3,2), nbtrjt
398 #ifdef _DEBUG_HOMARD_
401 kaux = nbjois + nbjoit
402 do 42 , iaux = jaux, kaux
403 write (ulsort,1421) iaux-nbjois,
404 > tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux)
408 1420 format( /,5x,41('*'),
409 > /,5x,'* Joint t *',3(' Joint s *'),
411 1421 format(4x,4(' *',i8),' *')
412 1422 format(5x,41('*'),/)
419 c 4.3. ==> Joints quadruples
421 if ( nbjoiq.gt.0 ) then
423 if ( codret.eq.0 ) then
425 write (ulsort,texte(langue,14)) nbjoiq
426 write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhejq
427 #ifdef _DEBUG_HOMARD_
428 write (ulsort,texte(langue,11)) mess14(langue,3,4), nbqujq
431 #ifdef _DEBUG_HOMARD_
433 jaux = nbjois + nbjoit + 1
434 kaux = nbjois + nbjoit + nbjoiq
435 do 43 , iaux = jaux, kaux
436 write (ulsort,1431) iaux-nbjois-nbjoit,
437 > tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux), tbaux2(4,iaux)
441 1430 format( /,5x,51('*'),
442 > /,5x,'* Joint q *',4(' Joint s *'),
444 1431 format(4x,5(' *',i8),' *')
445 1432 format(5x,51('*'),/)
452 c 4.4. ==> Joints ponctuels
454 if ( nbjp06.gt.0 ) then
456 if ( codret.eq.0 ) then
458 write (ulsort,texte(langue,21)) 6, nbjp06
459 write (ulsort,texte(langue,11)) mess14(langue,3,3), nbte06
465 if ( nbjp09.gt.0 ) then
467 if ( codret.eq.0 ) then
469 write (ulsort,texte(langue,21)) 9, nbjp09
470 write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpe09
476 if ( nbjp12.gt.0 ) then
478 if ( codret.eq.0 ) then
480 write (ulsort,texte(langue,21)) 12, nbjp12
481 write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhe12
491 if ( codret.ne.0 ) then
495 write (ulsort,texte(langue,1)) 'Sortie', nompro
496 write (ulsort,texte(langue,2)) codret
500 #ifdef _DEBUG_HOMARD_
501 write (ulsort,texte(langue,1)) 'Sortie', nompro