1 subroutine cmdera ( nomail,
2 > indnoe, indnp2, indnim, indare,
4 > indtet, indhex, indpen,
5 > lgopts, taopts, lgetco, taetco,
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 Creation du Maillage - DERAffinement
29 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . nomail . e . ch8 . nom de l'objet contenant le maillage .
34 c . indnoe . s . 1 . nombre de noeuds restants apres deraff. .
35 c . indnp2 . s . 1 . nombre de noeuds p2 restants apres deraff. .
36 c . indnim . s . 1 . nombre de noeuds internes restants ap deraf.
37 c . indare . s . 1 . nombre d'aretes restantes apres deraff. .
38 c . indtri . s . 1 . nombre de triangles restants apres deraff. .
39 c . indqua . s . 1 . nombre de quads restants apres deraff. .
40 c . indtet . s . 1 . nombre de tetraedres restants apres deraff..
41 c . indhex . s . 1 . nombre de hexaedres restants apres deraff. .
42 c . indpen . s . 1 . indice du dernier pentaedre cree .
43 c . lgopts . e . 1 . longueur du tableau des options caracteres .
44 c . taopts . e . lgopts . tableau des options caracteres .
45 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
46 c . taetco . e . lgetco . tableau de l'etat courant .
47 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
48 c . langue . e . 1 . langue des messages .
49 c . . . . 1 : francais, 2 : anglais .
50 c . codret . e/s . 1 . code de retour des modules .
51 c . . . . 0 : pas de probleme .
52 c ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'CMDERA' )
90 integer indnoe, indnp2, indnim, indare, indtri, indqua
91 integer indtet, indhex, indpen
94 character*8 taopts(lgopts)
97 integer taetco(lgetco)
99 integer ulsort, langue, codret
101 c 0.4. ==> variables locales
103 integer codava, nretap, nrsset
104 integer iaux, jaux, ideb, ifin
107 integer codre1, codre2, codre3, codre4, codre5
108 integer codre6, codre7, codre8
110 integer pdecar, pdecfa
111 integer phetno, pcoono, pareno
112 integer phetar, psomar, pfilar, pmerar, pnp2ar
113 integer phettr, paretr, pfiltr, ppertr, pnivtr, adnmtr
114 integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu
115 integer phette, ptrite, pcotrt, pfilte, pperte
116 integer phethe, pquahe, pcoquh, pfilhe, pperhe, adnmhe
117 integer phetpe, pfacpe, pcofap, pfilpe, pperpe
118 integer pfamno, pcfano
125 integer pfacar, pposif
126 integer nbpere, pdispe, pancpe, pnoupe
127 integer nbhere, pdishe, panche, pnouhe
128 integer nbtere, pdiste, pancte, pnoute
129 cgn integer nbpyre, pdispy, pancpy, pnoupy
130 integer pdispy, pancpy, pnoupy
131 integer nbqure, pdisqu, pancqu, pnouqu
132 integer nbtrre, pdistr, panctr, pnoutr
133 integer nbarre, pdisar, pancar, pnouar
134 integer nbnore, pdisno, pancno, pnouno
135 integer nbp2re, nbimre
136 integer adhono, adhoar, adhotr, adhoqu
137 integer ptrav3, ptrav4
142 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
143 character*8 nhtetr, nhhexa, nhpyra, nhpent
145 character*8 nhvois, nhsupe, nhsups
146 character*8 nnoupy, nnoupe, nnouhe, nnoute
147 character*8 nnouqu, nnoutr, nnouar, nnouno
148 character*8 ndispy, ndispe, ndishe, ndiste
149 character*8 ndisqu, ndistr, ndisar, ndisno
150 character*8 ntrav1, ntrav2, ntrav3, ntrav4
153 parameter ( nbmess = 10 )
154 character*80 texte(nblang,nbmess)
156 c 0.5. ==> initialisations
168 c ______________________________________________________________________
176 c=======================================================================
177 if ( codava.eq.0 ) then
178 c=======================================================================
180 c 1.3. ==> les messages
184 #ifdef _DEBUG_HOMARD_
185 write (ulsort,texte(langue,1)) 'Entree', nompro
189 texte(1,4) = '(/,a6,'' DERAFFINEMENT STANDARD DU MAILLAGE'')'
190 texte(1,5) = '(41(''=''),/)'
192 texte(2,4) = '(/,a6,'' STANDARD UNREFINEMENT OF MESH'')'
193 texte(2,5) = '(36(''=''),/)'
195 c 1.4. ==> le numero de sous-etape
198 nrsset = taetco(2) + 1
201 call utcvne ( nretap, nrsset, saux, iaux, codret )
205 write (ulsort,texte(langue,4)) saux
206 write (ulsort,texte(langue,5))
211 c 2. recuperation des pointeurs
214 c 2.1. ==> structure generale
216 if ( codret.eq.0 ) then
218 #ifdef _DEBUG_HOMARD_
219 write (ulsort,90002) '2.1. ==> structure generale'
222 #ifdef _DEBUG_HOMARD_
223 write (ulsort,texte(langue,3)) 'UTNOMH', nompro
226 call utnomh ( nomail,
228 > degre, maconf, homolo, hierar,
229 > rafdef, nbmane, typcca, typsfr, maextr,
232 > nhnoeu, nhmapo, nharet,
234 > nhtetr, nhhexa, nhpyra, nhpent,
236 > nhvois, nhsupe, nhsups,
237 > ulsort, langue, codret)
243 if ( codret.eq.0 ) then
245 #ifdef _DEBUG_HOMARD_
246 write (ulsort,90002) '2.2. ==> tableaux'
250 if ( homolo.ge.1 ) then
253 #ifdef _DEBUG_HOMARD_
254 write (ulsort,texte(langue,3)) 'UTAD01', nompro
256 call utad01 ( iaux, nhnoeu,
258 > pfamno, pcfano, jaux,
259 > pcoono, pareno, adhono, jaux,
260 > ulsort, langue, codret )
262 call gmnomc ( nomail//'.InfoSupE', nhsupe, codre0 )
264 codret = max ( abs(codre0), codret )
267 if ( degre.eq.2 ) then
270 if ( homolo.ge.2 ) then
273 #ifdef _DEBUG_HOMARD_
274 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
276 call utad02 ( iaux, nharet,
277 > phetar, psomar, pfilar, pmerar,
278 > pfamar, jaux, jaux,
279 > jaux, pnp2ar, jaux,
280 > jaux, adhoar, jaux,
281 > ulsort, langue, codret )
283 if ( nbtrto.ne.0 ) then
286 if ( mod(mailet,2).eq.0 ) then
289 if ( homolo.ge.3 ) then
292 #ifdef _DEBUG_HOMARD_
293 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
295 call utad02 ( iaux, nhtria,
296 > phettr, paretr, pfiltr, ppertr,
297 > pfamtr, jaux, jaux,
298 > pnivtr, jaux, jaux,
299 > adnmtr, adhotr, jaux,
300 > ulsort, langue, codret )
304 if ( nbquto.ne.0 ) then
307 if ( mod(mailet,3).eq.0 ) then
310 if ( homolo.ge.3 ) then
313 #ifdef _DEBUG_HOMARD_
314 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
316 call utad02 ( iaux, nhquad,
317 > phetqu, parequ, pfilqu, pperqu,
318 > pfamqu, jaux, jaux,
319 > pnivqu, jaux, jaux,
320 > adnmqu, adhoqu, jaux,
321 > ulsort, langue, codret )
325 if ( nbteto.ne.0 ) then
328 #ifdef _DEBUG_HOMARD_
329 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
331 call utad02 ( iaux, nhtetr,
332 > phette, ptrite, pfilte, pperte,
333 > pfamte, jaux, jaux,
334 > jaux, pcotrt, jaux,
336 > ulsort, langue, codret )
340 if ( nbheto.ne.0 ) then
343 if ( mod(mailet,5).eq.0 ) then
346 #ifdef _DEBUG_HOMARD_
347 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
349 call utad02 ( iaux, nhhexa,
350 > phethe, pquahe, pfilhe, pperhe,
351 > pfamhe, jaux, jaux,
352 > jaux, pcoquh, jaux,
353 > adnmhe, jaux, jaux,
354 > ulsort, langue, codret )
358 if ( nbpeto.ne.0 ) then
361 #ifdef _DEBUG_HOMARD_
362 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
364 call utad02 ( iaux, nhpent,
365 > phetpe, pfacpe, pfilpe, pperpe,
366 > pfampe, jaux, jaux,
367 > jaux, pcofap, jaux,
369 > ulsort, langue, codret )
375 if ( codret.eq.0 ) then
378 #ifdef _DEBUG_HOMARD_
379 write (ulsort,texte(langue,3)) 'UTAD04', nompro
381 call utad04 ( iaux, nhvois,
382 > jaux, jaux, pposif, pfacar,
384 > jaux, jaux, jaux, jaux,
389 > ulsort, langue, codret )
393 if ( codret.eq.0 ) then
396 call gmadoj ( ntrav1, pdecar, iaux, codre1 )
398 call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
400 codre0 = min ( codre1, codre2 )
401 codret = max ( abs(codre0), codret,
403 cgn call gmprsx (nompro//'- DECARE', ntrav1)
404 cgn call gmprot (nompro//'- DECARE', ntrav1, 1659, 1662)
405 cgn if ( nbquto.eq.0 ) then
406 cgn call gmprot (nompro//'- DECFAC', ntrav2, 2, nbtrto+1)
408 cgn call gmprsx (nompro//'- DECFAC', ntrav2)
413 c 2.3. ==> allocations supplementaires
415 #ifdef _DEBUG_HOMARD_
416 write (ulsort,90002) '2.3. alloc supplementaires ; codret', codret
419 c 2.3.1. ==> Renumerotation des noeuds
421 if ( codret.eq.0 ) then
423 call gmobal ( nhnoeu//'.Deraffin', codre0 )
424 if ( codre0.eq.2 ) then
425 call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codret )
427 elseif ( codre0.eq.0 ) then
428 call gmaloj ( nhnoeu//'.Deraffin', ' ', nouvno, pancno, codret )
430 if ( codret.eq.0 ) then
431 do 231 , iaux = 1, nouvno
432 imem(pancno+iaux-1) = iaux
441 if ( codret.eq.0 ) then
443 call gmaloj ( nharet//'.Deraffin', ' ', nouvar, pancar, codre1 )
444 call gmaloj ( nhtria//'.Deraffin', ' ', nouvtr, panctr, codre2 )
445 call gmaloj ( nhquad//'.Deraffin', ' ', nouvqu, pancqu, codre3 )
446 call gmaloj ( nhtetr//'.Deraffin', ' ', nouvte, pancte, codre4 )
447 call gmaloj ( nhhexa//'.Deraffin', ' ', nouvhe, panche, codre5 )
448 call gmaloj ( nhpent//'.Deraffin', ' ', nouvpe, pancpe, codre6 )
449 call gmaloj ( nhpyra//'.Deraffin', ' ', nouvpy, pancpy, codre7 )
451 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
453 codret = max ( abs(codre0), codret,
454 > codre1, codre2, codre3, codre4, codre5,
458 call gmalot ( nnouno, 'entier ', iaux, pnouno, codre1 )
460 call gmalot ( nnouar, 'entier ', iaux, pnouar, codre2 )
462 call gmalot ( nnoutr, 'entier ', iaux, pnoutr, codre3 )
464 call gmalot ( nnouqu, 'entier ', iaux, pnouqu, codre4 )
466 call gmalot ( nnoute, 'entier ', iaux, pnoute, codre5 )
468 call gmalot ( nnouhe, 'entier ', iaux, pnouhe, codre6 )
470 call gmalot ( nnoupe, 'entier ', iaux, pnoupe, codre7 )
472 call gmalot ( nnoupy, 'entier ', iaux, pnoupy, codre8 )
474 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
475 > codre6, codre7, codre8 )
476 codret = max ( abs(codre0), codret,
477 > codre1, codre2, codre3, codre4, codre5,
478 > codre6, codre7, codre8 )
480 call gmalot ( ndisno, 'entier ', nouvno, pdisno, codre1 )
481 call gmalot ( ndisar, 'entier ', nouvar, pdisar, codre2 )
482 call gmalot ( ndistr, 'entier ', nouvtr, pdistr, codre3 )
483 call gmalot ( ndisqu, 'entier ', nouvqu, pdisqu, codre4 )
484 call gmalot ( ndiste, 'entier ', nouvte, pdiste, codre5 )
485 call gmalot ( ndishe, 'entier ', nouvhe, pdishe, codre6 )
486 call gmalot ( ndispe, 'entier ', nouvpe, pdispe, codre7 )
487 call gmalot ( ndispy, 'entier ', nouvpy, pdispy, codre8 )
489 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
490 > codre6, codre7, codre8 )
491 codret = max ( abs(codre0), codret,
492 > codre1, codre2, codre3, codre4, codre5,
493 > codre6, codre7, codre8 )
495 iaux = max ( nbarto, nbtrto, nbquto, nbteto, nbheto, nbpeto )
496 call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre1 )
497 call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre2 )
499 codre0 = min ( codre1, codre2 )
500 codret = max ( abs(codre0), codret,
506 c 3. regroupement des entites
509 c 3.1. ==> initialisation des tableaux de "disparition"
510 c Par convention, une valeur 0 indique la conservation et
511 c une autre valeur la disparition de l'entite concernee par la liste
513 #ifdef _DEBUG_HOMARD_
514 write (ulsort,90002) '3.1. Init tableaux disp ; codret', codret
517 if ( codret.eq.0 ) then
520 ifin = pdisno + nouvno - 1
521 do 311 , iaux = ideb , ifin
526 ifin = pdisar + nouvar - 1
527 do 312 , iaux = ideb , ifin
532 ifin = pdistr + nouvtr - 1
533 do 313 , iaux = ideb , ifin
538 ifin = pdisqu + nouvqu - 1
539 do 314 , iaux = ideb , ifin
544 ifin = pdiste + nouvte - 1
545 do 315 , iaux = ideb , ifin
550 ifin = pdishe + nouvhe - 1
551 do 316 , iaux = ideb , ifin
556 ifin = pdispe + nouvpe - 1
557 do 317 , iaux = ideb , ifin
562 ifin = pdispy + nouvpy - 1
563 do 318 , iaux = ideb , ifin
569 c 3.2. ==> regroupement des tetraedres
570 #ifdef _DEBUG_HOMARD_
571 write (ulsort,90002) '3.2 regroupement tetr ; codret', codret
574 if ( codret.eq.0 ) then
576 if ( nbteto.ne.0 ) then
578 #ifdef _DEBUG_HOMARD_
579 write (ulsort,texte(langue,3)) 'CMDRTE', nompro
583 > imem(paretr), imem(pdecfa),
584 > imem(ptrite), imem(phette),
585 > imem(pfilte), imem(pdisar), imem(pdistr), imem(pdiste),
586 > imem(pareno), imem(psomar), imem(pcotrt), imem(pdisno),
587 > imem(pnp2ar), imem(ppertr), codret )
593 c 3.3. ==> regroupement des hexaedres
594 #ifdef _DEBUG_HOMARD_
595 write (ulsort,90002) '3.3 regroupement hexa ; codret', codret
598 if ( codret.eq.0 ) then
600 if ( nbheto.ne.0 ) then
602 #ifdef _DEBUG_HOMARD_
603 write (ulsort,texte(langue,3)) 'CMDRHE', nompro
607 > imem(parequ), imem(pdecfa),
608 > imem(pquahe), imem(phethe),
609 > imem(pfilhe), imem(pdisar), imem(pdisqu), imem(pdishe),
610 > imem(psomar), imem(pdisno),
611 > imem(pnp2ar), codret )
617 c 3.4. ==> regroupement des pentaedres
618 #ifdef _DEBUG_HOMARD_
619 write (ulsort,90002) '3.4 regroupement pent ; codret', codret
622 if ( codret.eq.0 ) then
624 if ( nbpeto.ne.0 ) then
626 #ifdef _DEBUG_HOMARD_
627 write (ulsort,texte(langue,3)) 'CMDRPE', nompro
631 > imem(paretr), imem(pdecfa),
632 > imem(pfacpe), imem(phetpe),
634 > imem(pdisar), imem(pdistr), imem(pdisqu), imem(pdispe),
636 > imem(pnp2ar), codret )
642 c 3.5. ==> regroupement des triangles
643 #ifdef _DEBUG_HOMARD_
644 write (ulsort,90002) '3.5 regroupement tria ; codret', codret
647 if ( codret.eq.0 ) then
649 if ( nbtrto.ne.0 ) then
651 #ifdef _DEBUG_HOMARD_
652 write (ulsort,texte(langue,3)) 'CMDRTR', nompro
656 > imem(paretr), imem(pdecfa),
657 > imem(phettr), imem(pfiltr), imem(adnmtr),
658 > imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu),
659 > imem(pdecar), imem(pfilar),
660 > imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar),
661 > imem(phetno), codret )
667 c 3.6. ==> regroupement des quadrangles
668 #ifdef _DEBUG_HOMARD_
669 write (ulsort,90002) '3.6 regroupement quad ; codret', codret
672 if ( codret.eq.0 ) then
674 if ( nbquto.ne.0 ) then
676 #ifdef _DEBUG_HOMARD_
677 write (ulsort,texte(langue,3)) 'CMDRQU', nompro
681 > imem(parequ), imem(pdecfa),
682 > imem(phetqu), imem(pfilqu), imem(adnmqu),
683 > imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu),
684 > imem(pdecar), imem(pfilar),
685 > imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar),
686 > imem(phetno), codret )
692 c 3.7. ==> regroupement des aretes
693 #ifdef _DEBUG_HOMARD_
694 write (ulsort,90002) '3.7 regroupement aret ; codret', codret
697 if ( codret.eq.0 ) then
699 #ifdef _DEBUG_HOMARD_
700 write (ulsort,texte(langue,3)) 'CMDRAR', nompro
704 > imem(phetar), imem(pfilar), imem(pnp2ar), imem(psomar),
706 > imem(pdisar), imem(pdisno), imem(pdistr), imem(pdisqu),
707 > imem(phetno), imem(pposif), imem(pfacar), codret )
712 c 4. suppression des entites
715 c 4.1. ==> suppression des tetraedres
716 #ifdef _DEBUG_HOMARD_
717 write (ulsort,90002) '4.1. suppression tetr ; codret', codret
720 if ( codret.eq.0 ) then
722 if ( nbteto.ne.0 ) then
724 #ifdef _DEBUG_HOMARD_
725 write (ulsort,texte(langue,3)) 'UTSUTE', nompro
728 call utsute ( imem(pdiste),
729 > imem(phette), imem(pperte), imem(pfilte),
730 > imem(ptrite), imem(pcotrt),
731 > imem(pareno), imem(psomar), imem(paretr),
732 > imem(pancte), imem(pnoute),
746 c 4.2. ==> suppression des hexaedres
747 #ifdef _DEBUG_HOMARD_
748 write (ulsort,90002) '4.2. suppression hexa ; codret', codret
751 if ( codret.eq.0 ) then
753 if ( nbheto.ne.0 ) then
755 #ifdef _DEBUG_HOMARD_
756 write (ulsort,texte(langue,3)) 'UTSUHE', nompro
759 call utsuhe ( imem(pdishe),
760 > imem(phethe), imem(pperhe), imem(pfilhe),
761 > imem(panche), imem(pnouhe),
774 c 4.3. ==> suppression des pentaedres
775 #ifdef _DEBUG_HOMARD_
776 write (ulsort,90002) '4.3. suppression pent ; codret', codret
779 if ( codret.eq.0 ) then
781 if ( nbpeto.ne.0 ) then
783 #ifdef _DEBUG_HOMARD_
784 write (ulsort,texte(langue,3)) 'UTSUPE', nompro
787 call utsupe ( imem(pdispe),
788 > imem(phetpe), imem(pperpe), imem(pfilpe),
789 > imem(pancpe), imem(pnoupe),
802 c 4.4. ==> suppression des triangles
803 #ifdef _DEBUG_HOMARD_
804 write (ulsort,90002) '4.4. suppression tria ; codret', codret
807 if ( codret.eq.0 ) then
809 if ( nbtrto.ne.0 ) then
811 #ifdef _DEBUG_HOMARD_
812 write (ulsort,texte(langue,3)) 'UTSUTR', nompro
815 call utsutr ( imem(pdistr),
816 > imem(phettr), imem(ppertr), imem(pfiltr),
817 > imem(panctr), imem(pnoutr),
830 c 4.5. ==> suppression des quadrangles
831 #ifdef _DEBUG_HOMARD_
832 write (ulsort,90002) '4.5. suppression quad ; codret', codret
835 if ( codret.eq.0 ) then
837 if ( nbquto.ne.0 ) then
839 #ifdef _DEBUG_HOMARD_
840 write (ulsort,texte(langue,3)) 'UTSUQU', nompro
843 call utsuqu ( imem(pdisqu),
844 > imem(phetqu), imem(pperqu), imem(pfilqu),
845 > imem(pancqu), imem(pnouqu),
858 c 4.6. ==> suppression des aretes
859 #ifdef _DEBUG_HOMARD_
860 write (ulsort,90002) '4.6. suppression aret ; codret', codret
863 if ( codret.eq.0 ) then
865 #ifdef _DEBUG_HOMARD_
866 write (ulsort,texte(langue,3)) 'UTSUAR', nompro
869 call utsuar ( imem(pdisar),
870 > imem(phetar), imem(pmerar), imem(pfilar),
871 > imem(pancar), imem(pnouar),
878 c 4.7. ==> suppression des noeuds
879 #ifdef _DEBUG_HOMARD_
880 write (ulsort,90002) '4.7. suppression noeuds ; codret', codret
883 if ( codret.eq.0 ) then
885 #ifdef _DEBUG_HOMARD_
886 write (ulsort,texte(langue,3)) 'UTSUNO', nompro
889 call utsuno ( nbnoto, nouvno, imem(pdisno),
890 > imem(phetno), imem(pancno), imem(pnouno),
891 > nbnore, nbp2re, nbimre )
900 c 5. compactage des numerotations
903 c 5.1. ==> compactage des tetraedres
904 #ifdef _DEBUG_HOMARD_
905 write (ulsort,90002) '5.1. compactage tetr ; codret', codret
908 if ( codret.eq.0 ) then
910 if ( nbteto.ne.0 ) then
912 #ifdef _DEBUG_HOMARD_
913 write (ulsort,texte(langue,3)) 'UTCNTE', nompro
917 > imem(ptrite), imem(pcotrt), imem(phette), imem(pfamte),
918 > imem(pfilte), imem(pperte), imem(pancte), imem(pnoute),
919 > imem(pnoutr), nbtere,
920 > imem(ptrav3), imem(ptrav4) )
927 c 5.2. ==> compactage des hexaedres
928 #ifdef _DEBUG_HOMARD_
929 write (ulsort,90002) '5.2. compactage hexa ; codret', codret
932 if ( codret.eq.0 ) then
934 if ( nbheto.ne.0 ) then
936 #ifdef _DEBUG_HOMARD_
937 write (ulsort,texte(langue,3)) 'UTCNHE', nompro
940 > imem(pquahe), imem(pcoquh), imem(phethe), imem(pfamhe),
941 > imem(pfilhe), imem(pperhe), imem(adnmqu),
942 > imem(panche), imem(pnouhe),
943 > imem(pnouqu), nbhere,
944 > imem(ptrav3), imem(ptrav4) )
950 c 5.3. ==> compactage des pentaedres
951 #ifdef _DEBUG_HOMARD_
952 write (ulsort,90002) '5.3. compactage pent ; codret', codret
955 if ( codret.eq.0 ) then
957 if ( nbpeto.ne.0 ) then
959 #ifdef _DEBUG_HOMARD_
960 write (ulsort,texte(langue,3)) 'UTCNPE', nompro
963 > imem(pfacpe), imem(pcofap), imem(phetpe), imem(pfampe),
964 > imem(pfilpe), imem(pperpe), imem(pancpe), imem(pnoupe),
965 > imem(pnoutr), imem(pnouqu), nbpere,
966 > imem(ptrav3), imem(ptrav4) )
972 c 5.4. ==> compactage des triangles
973 #ifdef _DEBUG_HOMARD_
974 write (ulsort,90002) '5.4. compactage tria ; codret', codret
977 if ( codret.eq.0 ) then
979 if ( nbtrto.ne.0 ) then
982 if ( mod(mailet,2).eq.0 ) then
985 if ( homolo.ge.3 ) then
988 #ifdef _DEBUG_HOMARD_
989 write (ulsort,texte(langue,3)) 'UTCNTR', nompro
992 > imem(phettr), imem(pfamtr), imem(pdecfa), imem(pnivtr),
993 > imem(pfiltr), imem(ppertr),
994 > tbiaux, imem(adnmtr), imem(adhotr),
996 > imem(panctr), imem(pnoutr), imem(pnouar), imem(paretr),
998 > imem(ptrav3), imem(ptrav4) )
1004 c 5.5. ==> compactage des quadrangles
1005 #ifdef _DEBUG_HOMARD_
1006 write (ulsort,90002) '5.5. compactage quad ; codret', codret
1009 if ( codret.eq.0 ) then
1011 if ( nbquto.ne.0 ) then
1014 if ( mod(mailet,3).eq.0 ) then
1017 if ( homolo.ge.3 ) then
1020 #ifdef _DEBUG_HOMARD_
1021 write (ulsort,texte(langue,3)) 'UTCNQU', nompro
1024 > imem(phetqu), imem(pfamqu), imem(pdecfa), imem(pnivqu),
1025 > imem(pfilqu), imem(pperqu),
1026 > tbiaux, imem(adnmqu),
1028 > imem(pancqu), imem(pnouqu), imem(pnouar), imem(parequ),
1030 > imem(ptrav3), imem(ptrav4) )
1036 c 5.6. ==> compactage des aretes
1037 #ifdef _DEBUG_HOMARD_
1038 write (ulsort,90002) '5.6. compactage aret ; codret', codret
1041 if ( codret.eq.0 ) then
1043 #ifdef _DEBUG_HOMARD_
1044 write (ulsort,texte(langue,3)) 'UTCNAR', nompro
1047 > imem(psomar), imem(phetar), imem(pfamar), imem(pdecar),
1048 > imem(pfilar), imem(pmerar), imem(adhoar), imem(pnp2ar),
1049 > imem(paretr), imem(parequ),
1050 > imem(pposif), imem(pfacar),
1051 > imem(pancar), imem(pnouar), imem(pnouno),
1052 > nbtrre, nbqure, nbarre,
1053 > imem(ptrav3), imem(ptrav4) )
1057 c 5.7. ==> compactage des noeuds
1058 #ifdef _DEBUG_HOMARD_
1059 write (ulsort,90002) '5.7. compactage noeuds ; codret', codret
1062 if ( codret.eq.0 ) then
1065 if ( mod(mailet,2).eq.0 ) then
1068 if ( mod(mailet,3).eq.0 ) then
1071 if ( homolo.ge.1 ) then
1074 #ifdef _DEBUG_HOMARD_
1075 write (ulsort,texte(langue,3)) 'UTCNNO', nompro
1079 > imem(phetno), imem(pfamno), imem(pareno), imem(adhono),
1083 > imem(pnouar), imem(pnouno), nbnoto )
1091 #ifdef _DEBUG_HOMARD_
1092 write (ulsort,90002) '6. Menage ; codret', codret
1095 if ( codret.eq.0 ) then
1097 call gmlboj ( nnouno, codre1 )
1098 call gmlboj ( nnouar, codre2 )
1099 call gmlboj ( nnoutr, codre3 )
1100 call gmlboj ( nnouqu, codre4 )
1101 call gmlboj ( nnoute, codre5 )
1102 call gmlboj ( nnouhe, codre6 )
1103 call gmlboj ( nnoupe, codre7 )
1104 call gmlboj ( nnoupy, codre8 )
1106 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1107 > codre6, codre7, codre8 )
1108 codret = max ( abs(codre0), codret,
1109 > codre1, codre2, codre3, codre4, codre5,
1110 > codre6, codre7, codre8 )
1112 call gmlboj ( ndisno, codre1 )
1113 call gmlboj ( ndisar, codre2 )
1114 call gmlboj ( ndistr, codre3 )
1115 call gmlboj ( ndisqu, codre4 )
1116 call gmlboj ( ndiste, codre5 )
1117 call gmlboj ( ndishe, codre6 )
1118 call gmlboj ( ndispe, codre7 )
1119 call gmlboj ( ndispy, codre8 )
1121 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1122 > codre6, codre7, codre8 )
1123 codret = max ( abs(codre0), codret,
1124 > codre1, codre2, codre3, codre4, codre5,
1125 > codre6, codre7, codre8 )
1127 call gmlboj ( ntrav3, codre1 )
1128 call gmlboj ( ntrav4, codre2 )
1130 codre0 = min ( codre1, codre2 )
1131 codret = max ( abs(codre0), codret,
1140 if ( codret.ne.0 ) then
1144 write (ulsort,texte(langue,1)) 'Sortie', nompro
1145 write (ulsort,texte(langue,2)) codret
1149 #ifdef _DEBUG_HOMARD_
1150 write (ulsort,texte(langue,1)) 'Sortie', nompro
1154 c=======================================================================
1156 c=======================================================================