1 subroutine mmagf0 ( nbjoto, nbjois, nbjoit, nbjoiq,
2 > nbjp06, nbjp09, nbjp12,
3 > nhnoeu, nhmapo, nharet, nhtria, nhquad,
4 > nhtetr, nhhexa, nhpyra, nhpent,
6 > ulsort, langue, codret )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
27 c Modification de Maillage - AGregat - Famille - phase 0
29 c Creation des nouvelles familles MED
30 c ______________________________________________________________________
32 c . nom . e/s . taille . description .
33 c .____________________________________________________________________.
34 c . nbjoto . e . 1 . nombre total de joints .
35 c . nbjois . e . 1 . nombre de joints simples .
36 c . nbjoit . e . 1 . nombre de joints triples .
37 c . nbjoiq . e . 1 . nombre de joints quadruples .
38 c . nbjp06 . e . 1 . nombre de joints ponctuels ordre 6 .
39 c . nbjp09 . e . 1 . nombre de joints ponctuels ordre 9 .
40 c . nbjp12 . e . 1 . nombre de joints ponctuels ordre 12 .
41 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
42 c . langue . e . 1 . langue des messages .
43 c . . . . 1 : francais, 2 : anglais .
44 c . codret . es . 1 . code de retour des modules .
45 c . . . . 0 : pas de probleme .
46 c ______________________________________________________________________
49 c 0. declarations et dimensionnement
52 c 0.1. ==> generalites
58 parameter ( nompro = 'MMAGF0' )
86 integer nbjoto, nbjois, nbjoit, nbjoiq
87 integer nbjp06, nbjp09, nbjp12
89 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
90 character*8 nhtetr, nhhexa, nhpyra, nhpent
91 character*8 nhsupe, nhsups
93 integer ulsort, langue, codret
95 c 0.4. ==> variables locales
98 integer codre1, codre2, codre3, codre4, codre5
101 integer nbfmed, nbfme0, nbfmaj
102 integer lgte6n, lgte60
103 integer lgts2n, lgts20
104 integer adtae5, adtae6, adtae9, adtas2, adtas4
106 integer nctfen, nbfaen, pcfaen
112 #ifdef _DEBUG_HOMARD_
113 integer pfamno, pcfano
114 integer pfammp, pcfamp
115 integer pfamar, pcfaar
116 integer pfamtr, pcfatr
120 integer pfampy, pcfapy
126 character*8 nhqufa, nhtefa, nhpefa, nhhefa
130 parameter ( nbmess = 10 )
131 character*80 texte(nblang,nbmess)
133 c 0.5. ==> initialisations
134 c ______________________________________________________________________
143 #ifdef _DEBUG_HOMARD_
144 write (ulsort,texte(langue,1)) 'Entree', nompro
148 texte(1,4) = '(''Decalage dans les numeros des familles :'',i5)'
150 >'(''Ancien nombre de familles HOMARD de '',a,'' :'',i5)'
152 >'(''Nouveau nombre de familles HOMARD de '',a,'' :'',i5)'
153 texte(1,7) = '(''Nombre de familles MED '',a,'' :'',i5)'
155 texte(2,4) = '(''Shift with numbers of the families :'',i5)'
157 >'(''Old number of HOMARD families of '',a,'' :'',i5)'
159 >'(''New number of HOMARD families of '',a,'' :'',i5)'
160 texte(2,7) = '(''Number of MED families '',a,'' :'',i5)'
165 c 2. Gestion des tableaux
167 c 2.1. ==> Familles des quadrangles : uniquement la famille libre
170 #ifdef _DEBUG_HOMARD_
171 write (ulsort,texte(langue,6)) mess14(langue,3,4), nbfqua
174 if ( codret.eq.0 ) then
176 call gmnomc ( nhquad//'.Famille', nhqufa, codret )
180 if ( codret.eq.0 ) then
184 #ifdef _DEBUG_HOMARD_
185 write (ulsort,texte(langue,3)) 'UTFAM1_qu', nompro
188 call utfam1 ( iaux, nhqufa, pcfaqu,
189 > nctfqu, jaux, nbfqua,
190 > ulsort, langue, codret )
194 c 2.2. ==> Familles des tetraedres
198 if ( nbjp06.ne.0 ) then
200 nbftet = nbfte0 + nbjp06
201 #ifdef _DEBUG_HOMARD_
202 write (ulsort,texte(langue,5)) mess14(langue,3,3), nbfte0
203 write (ulsort,texte(langue,6)) mess14(langue,3,3), nbftet
206 if ( codret.eq.0 ) then
208 call gmnomc ( nhtetr//'.Famille', nhtefa, codret )
212 if ( codret.eq.0 ) then
216 #ifdef _DEBUG_HOMARD_
217 write (ulsort,texte(langue,3)) 'UTFAM1_te', nompro
220 call utfam1 ( iaux, nhtefa, pcfate,
221 > nctfte, nbfte0, nbftet,
222 > ulsort, langue, codret )
228 c 2.3. ==> Familles des pentaedres
230 nbfpen = 1 + nbjois + nbjoit + nbjp09
231 #ifdef _DEBUG_HOMARD_
232 write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfpen
235 if ( codret.eq.0 ) then
237 call gmnomc ( nhpent//'.Famille', nhpefa, codret )
241 if ( codret.eq.0 ) then
245 #ifdef _DEBUG_HOMARD_
246 write (ulsort,texte(langue,3)) 'UTFAM1_pe', nompro
249 call utfam1 ( iaux, nhpefa, pcfape,
250 > nctfpe, jaux, nbfpen,
251 > ulsort, langue, codret )
255 c 2.4. ==> Familles des hexaedres
257 if ( nbjoiq.ne.0 ) then
259 nbfhex = 1 + nbjoiq + nbjp12
260 #ifdef _DEBUG_HOMARD_
261 write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfhex
264 if ( codret.eq.0 ) then
266 call gmnomc ( nhhexa//'.Famille', nhhefa, codret )
270 if ( codret.eq.0 ) then
274 #ifdef _DEBUG_HOMARD_
275 write (ulsort,texte(langue,3)) 'UTFAM1_he', nompro
278 call utfam1 ( iaux, nhhefa, pcfahe,
279 > nctfhe, jaux, nbfhex,
280 > ulsort, langue, codret )
287 c 3. Memorisation des familles MED
290 #ifdef _DEBUG_HOMARD_
291 write (ulsort,*) '5.2. ; codret = ', codret
293 cgn call gmprsx(nompro,nhpefa//'.Codes')
294 cgn call gmprsx(nompro,nhsupe)
295 cgn call gmprsx(nompro,nhsupe//'.Tab5')
296 cgn call gmprsx(nompro,nhsupe//'.Tab6')
297 cgn call gmprsx(nompro,nhsupe//'.Tab9')
298 cgn call gmprsx(nompro,nhsups)
299 cgn call gmprsx(nompro,nhsups//'.Tab2')
300 cgn call gmprsx(nompro,nhsups//'.Tab4')
302 c 3.1. ==> Nombre de familles MED
304 #ifdef _DEBUG_HOMARD_
305 write (ulsort,*) '3.1. Nombre familles MED ; codret = ', codret
310 if ( codret.eq.0 ) then
312 call gmliat ( nhsupe, 9, nbfme0, codret )
316 c Nombre de familles MED ajoute :
317 c Pour un type de mailles, il y a 1 famille MED de moins que
321 if ( nbfhex.gt.0 ) then
322 nbfmaj = nbfmaj + nbfhex - 1
324 nbfmaj = nbfmaj + nbjp06
326 nbfmed = nbfme0 + nbfmaj
328 #ifdef _DEBUG_HOMARD_
329 write (ulsort,texte(langue,7)) 'avant', nbfme0
330 write (ulsort,texte(langue,5)) mess14(langue,3,3), nbfte0
331 write (ulsort,texte(langue,6)) mess14(langue,3,3), nbftet
332 write (ulsort,texte(langue,6)) mess14(langue,3,6), nbfhex
333 write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfpen
334 write (ulsort,texte(langue,7)) 'apres', nbfmed
337 c 3.1. ==> Gestions des groupes
338 #ifdef _DEBUG_HOMARD_
339 write (ulsort,*) '3.1. Groupes ; codret = ', codret
342 if ( codret.eq.0 ) then
344 call gmliat ( nhsupe, 6, lgte60, codre1 )
345 call gmliat ( nhsups, 2, lgts20, codre2 )
347 codre0 = min ( codre1, codre2 )
348 codret = max ( abs(codre0), codret,
353 if ( codret.eq.0 ) then
355 call gmecat ( nhsupe, 5, nbfmed, codre1 )
356 lgte6n = lgte60 + 10*2*nbfmaj
357 call gmecat ( nhsupe, 6, lgte6n, codre2 )
358 call gmecat ( nhsupe, 9, nbfmed, codre3 )
359 lgts2n = lgts20 + 10*2*nbfmaj
360 call gmecat ( nhsups, 2, lgts2n, codre4 )
362 call gmecat ( nhsups, 4, iaux, codre5 )
364 codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
365 codret = max ( abs(codre0), codret,
366 > codre1, codre2, codre3, codre4, codre5 )
370 if ( codret.eq.0 ) then
372 call gmmod ( nhsupe//'.Tab5', adtae5,
373 > 1, 1, nbfme0+1, nbfmed+1, codre1 )
374 call gmmod ( nhsupe//'.Tab6', adtae6,
375 > 1, 1, lgte60, lgte6n, codre2 )
376 call gmmod ( nhsupe//'.Tab9', adtae9,
377 > 1, 1, nbfme0, nbfmed, codre3 )
378 call gmmod ( nhsups//'.Tab2', adtas2,
379 > 1, 1, lgts20, lgts2n, codre4 )
380 call gmmod ( nhsups//'.Tab4', adtas4,
381 > 1, 1, 10*nbfme0, 10*nbfmed, codre5 )
383 codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
384 codret = max ( abs(codre0), codret,
385 > codre1, codre2, codre3, codre4, codre5 )
390 c 4. Recherche du decalage dans les numeros de familles MED de mailles
392 #ifdef _DEBUG_HOMARD_
393 write (ulsort,*) '4. decalage ; codret = ', codret
396 if ( codret.eq.0 ) then
400 do 40 , typenh = 0 , 4
402 if ( codret.eq.0 ) then
404 if ( typenh.eq.0 ) then
408 elseif ( typenh.eq.1 ) then
412 elseif ( typenh.eq.2 ) then
416 elseif ( typenh.eq.3 ) then
420 elseif ( typenh.eq.4 ) then
428 if ( nbfaen.gt.0 ) then
430 #ifdef _DEBUG_HOMARD_
432 write (ulsort,*) mess14(langue,4,typenh)
433 write (ulsort,*) 'nbfaen', nbfaen
434 write (ulsort,*) 'nctfen', nctfen
437 if ( codret.eq.0 ) then
439 call gmadoj ( nhenti//'.Famille.Codes',
440 > pcfaen, iaux, codret )
444 if ( codret.eq.0 ) then
446 do 401 , iaux = 1 , nbfaen
448 cgn write (ulsort,*)imem(pcfaen+(iaux-1)*nctfen+cofamd-1)
449 decafa = min(decafa,imem(pcfaen+(iaux-1)*nctfen+cofamd-1))
459 #ifdef _DEBUG_HOMARD_
460 write (ulsort,texte(langue,4)) decafa
466 c 5. Creation des tableaux
468 #ifdef _DEBUG_HOMARD_
469 write (ulsort,*) '5. Creation des tableaux ; codret = ', codret
472 if ( codret.eq.0 ) then
474 cgn call gmprsx(nompro,nhpefa//'.Codes')
475 cgn call gmprsx(nompro,nhsupe)
476 cgn call gmprsx(nompro,nhsupe//'.Tab5')
477 cgn call gmprsx(nompro,nhsupe//'.Tab6')
478 cgn call gmprsx(nompro,nhsupe//'.Tab9')
479 cgn call gmprsx(nompro,nhsups)
480 cgn call gmprsx(nompro,nhsups//'.Tab2')
481 cgn call gmprsx(nompro,nhsups//'.Tab4')
483 #ifdef _DEBUG_HOMARD_
484 write (ulsort,texte(langue,3)) 'MMAGF1', nompro
486 call mmagf1 ( decafa,
488 > imem(pcfate), nbfte0, imem(pcfape), imem(pcfahe),
490 > nbjois, nbjoit, nbjoiq,
491 > nbjp06, nbjp09, nbjp12,
492 > imem(adtae5), imem(adtae6), smem(adtas2),
493 > imem(adtae9), smem(adtas4),
495 > ulsort, langue, codret )
496 cgn call gmprsx(nompro,nhtefa//'.Codes')
497 cgn call gmprsx(nompro,nhpefa//'.Codes')
498 cgn call gmprsx(nompro,nhsupe)
499 cgn call gmprsx(nompro,nhsupe//'.Tab5')
500 cgn call gmprsx(nompro,nhsupe//'.Tab6')
501 cgn call gmprsx(nompro,nhsupe//'.Tab9')
502 cgn call gmprsx(nompro,nhsups)
503 cgn call gmprsx(nompro,nhsups//'.Tab2')
504 cgn call gmprsx(nompro,nhsups//'.Tab4')
508 #ifdef _DEBUG_HOMARD_
510 c 6. Impression eventuelle
512 #ifdef _DEBUG_HOMARD_
513 write (ulsort,*) '6. Impression eventuelle ; codret = ', codret
518 if ( codret.eq.0 ) then
520 #ifdef _DEBUG_HOMARD_
521 write (ulsort,texte(langue,3)) 'UTAD01', nompro
524 call utad01 ( iaux, nhnoeu,
526 > pfamno, pcfano, jaux,
527 > jaux, jaux, jaux, jaux,
528 > ulsort, langue, codret )
530 if ( nbmpto.ne.0 ) then
532 #ifdef _DEBUG_HOMARD_
533 write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro
536 call utad02 ( iaux, nhmapo,
537 > jaux, jaux, jaux , jaux,
538 > pfammp, pcfamp, jaux,
541 > ulsort, langue, codret )
545 #ifdef _DEBUG_HOMARD_
546 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
549 call utad02 ( iaux, nharet,
550 > jaux, jaux, jaux, jaux,
551 > pfamar, pcfaar, jaux,
554 > ulsort, langue, codret )
556 #ifdef _DEBUG_HOMARD_
557 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
560 call utad02 ( iaux, nhtria,
561 > jaux, jaux, jaux, jaux,
562 > pfamtr, pcfatr, jaux,
565 > ulsort, langue, codret )
567 #ifdef _DEBUG_HOMARD_
568 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
571 call utad02 ( iaux, nhquad,
572 > jaux, jaux, jaux, jaux,
573 > pfamqu, pcfaqu, jaux,
576 > ulsort, langue, codret )
578 #ifdef _DEBUG_HOMARD_
579 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
582 call utad02 ( iaux, nhtetr,
583 > jaux, jaux, jaux, jaux,
584 > pfamte, pcfate, jaux,
587 > ulsort, langue, codret )
589 if ( nbheto.ne.0 ) then
591 #ifdef _DEBUG_HOMARD_
592 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
595 call utad02 ( iaux, nhhexa,
596 > jaux, jaux, jaux, jaux,
597 > pfamhe, pcfahe, jaux,
600 > ulsort, langue, codret )
604 if ( nbpyto.ne.0 ) then
606 #ifdef _DEBUG_HOMARD_
607 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
610 call utad02 ( iaux, nhpyra,
611 > jaux, jaux, jaux, jaux,
612 > pfampy, pcfapy, jaux,
615 > ulsort, langue, codret )
619 if ( nbpeto.ne.0 ) then
621 #ifdef _DEBUG_HOMARD_
622 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
625 call utad02 ( iaux, nhpent,
626 > jaux, jaux, jaux, jaux,
627 > pfampe, pcfape, jaux,
630 > ulsort, langue, codret )
636 c 6.2 ==> Impressions
638 if ( codret.eq.0 ) then
641 #ifdef _DEBUG_HOMARD_
642 write (ulsort,texte(langue,3)) 'UTECFE', nompro
645 > imem(pfamno), imem(pcfano),
646 > imem(pfammp), imem(pcfamp),
647 > imem(pfamar), imem(pcfaar),
648 > imem(pfamtr), imem(pcfatr),
649 > imem(pfamqu), imem(pcfaqu),
650 > imem(pfamte), imem(pcfate),
651 > imem(pfamhe), imem(pcfahe),
652 > imem(pfampy), imem(pcfapy),
653 > imem(pfampe), imem(pcfape),
654 > ulsort, langue, codret )
663 if ( codret.ne.0 ) then
667 write (ulsort,texte(langue,1)) 'Sortie', nompro
668 write (ulsort,texte(langue,2)) codret
672 #ifdef _DEBUG_HOMARD_
673 write (ulsort,texte(langue,1)) 'Sortie', nompro