1 subroutine vcmaco ( modhom, typcce, eleinc,
3 > nocman, nohman, typnom,
4 > ulsort, langue, codret )
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c aVant adaptation - Conversion de MAillage - COnnectivite
27 c ______________________________________________________________________
29 c cette conversion suppose que l'on ne garde du maillage
30 c que les elements suivants :
31 c . 0D : mailles-points
33 c . 2D : triangles, quadrangles
34 c . 3D : tetraedres, hexaedres, pentaedres, pyramides.
35 c le degre est 1 ou 2, mais il est le meme pour toutes les mailles.
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . modhom . e . 1 . mode de fonctionnement de homard .
41 c . . . . -5 : executable du suivi de frontiere .
42 c . . . . -4 : exec. de l'interface apres adaptation .
43 c . . . . -3 : exec. de l'interface avant adaptation .
44 c . . . . -2 : executable de l'information .
45 c . . . . -1 : executable de l'adaptation .
46 c . . . . 0 : executable autre .
47 c . . . . 1 : homard pur .
48 c . . . . 2 : information .
49 c . . . . 3 : modification de maillage sans adaptati.
50 c . . . . 4 : interpolation de la solution .
51 c . typcce . e . 1 . type du code de calcul en entree .
52 c . eleinc . e . 1 . elements incompatibles .
53 c . . . . 0 : on bloque s'il y en a .
54 c . . . . 1 : on les ignore s'il y en a .
55 c . tyconf . e . 1 . 0 : conforme (defaut) .
56 c . . . . 1 : non-conforme avec au minimum 2 aretes .
57 c . . . . non decoupees en 2 .
58 c . . . . 2 : non-conforme avec 1 seul noeud .
59 c . . . . pendant par arete .
60 c . . . . 3 : non-conforme fidele a l'indicateur .
61 c . . . . -1 : conforme, avec des boites pour les .
62 c . . . . quadrangles, hexaedres et pentaedres .
63 c . . . . -2 : non-conforme avec au maximum 1 arete .
64 c . . . . decoupee en 2 (boite pour les .
65 c . . . . quadrangles, hexaedres et pentaedres) .
66 c . maext0 . e . 1 . maillage extrude .
68 c . . . . 1 : selon X .
69 c . . . . 2 : selon Y .
70 c . . . . 3 : selon Z (cas de Saturne ou Neptune) .
71 c . nocman . e . char*8 . nom de l'objet maillage calcul iteration n .
72 c . nohman . es . char*8 . nom de l'objet maillage homard iteration n .
73 c . typnom . e . 1 . type du nom de l'objet maillage .
74 c . . . . 0 : le nom est a creer automatiquement .
75 c . . . . 1 : le nom est impose par l'appel .
76 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
77 c . langue . e . 1 . langue des messages .
78 c . . . . 1 : francais, 2 : anglais .
79 c . codret . es . 1 . code de retour des modules .
80 c . . . . 0 : pas de probleme .
81 c . . . . autre : probleme .
82 c ______________________________________________________________________
85 c 0. declarations et dimensionnement
88 c 0.1. ==> generalites
94 parameter ( nompro = 'VCMACO' )
130 integer modhom, typcce, eleinc, tyconf, maext0
133 character*8 nocman, nohman
135 integer ulsort, langue, codret
137 c 0.4. ==> variables locales
141 integer pnoemp, phetmp
142 integer pcoono, phetno, pareno
144 integer ppovos, pvoiso
145 integer pposif, pfacar
146 integer phetar, pfilar, pmerar, adars2
147 integer phettr, pfiltr, ppertr, pnivtr, paretr, adnmtr
148 integer phetqu, pfilqu, pperqu, pnivqu, parequ, adnmqu
149 integer ptrite, pcotrt, phette, pfilte, pperte
150 integer pquahe, pcoquh, phethe, pfilhe, pperhe, adnmhe
151 integer pfacpy, pcofay, phetpy, pfilpy, pperpy
152 integer pfacpe, pcofap, phetpe, pfilpe, pperpe
154 integer hfmdel, hnoeel
156 integer nbpqt, pinftb
158 integer pcexno, pcexmp, pcexar
159 integer pcextr, pcexqu
160 integer pcexte, pcexhe, pcexpy, pcexpe
163 integer adnohn, adnocn, adnoic
164 integer admphn, admpcn, admpic
165 integer adarhn, adarcn, adaric
166 integer adtrhn, adtrcn, adtric
167 integer adquhn, adqucn, adquic
168 integer adtehn, adtecn, adteic
169 integer adhehn, adhecn, adheic
170 integer adpyhn, adpycn, adpyic
171 integer adpehn, adpecn, adpeic
173 integer pfamen, pfamee, pnoeel, ptypel, pcoonc
174 integer pnuele, pnunoe
176 integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5
178 integer iaux, jaux, kaux, paux
179 integer codre1, codre2, codre3, codre4, codre5
180 integer codre6, codre7, codre8, codre0
181 integer nbnomb, adnomb
182 integer voarno, vofaar, vovoar, vovofa
184 integer nbardb, cpt, nbarne, rbarne
187 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
188 character*8 nhtetr, nhhexa, nhpyra, nhpent
190 character*8 nhvois, nhsupe, nhsups
191 character*8 ncinfo, ncnoeu, nccono, nccode
192 character*8 nccoex, ncfami
193 character*8 ncequi, ncfron, ncnomb
194 character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5
200 parameter ( nbmess = 10 )
201 character*80 texte(nblang,nbmess)
202 cmdc ---------------- MAILLES DOUBLES DEBUT --------------
203 cmd integer nbelnw, nbtenw
204 cmd character*80 nomfic
206 cmd integer adpoin, adtail, adtabl
208 cmdc ---------------- MAILLES DOUBLES FIN ----------------
210 c 0.5. ==> initialisations
211 c ______________________________________________________________________
219 #ifdef _DEBUG_HOMARD_
220 write (ulsort,texte(langue,1)) 'Entree', nompro
224 texte(1,4) = '(5x,''Estimation du nombre d''''aretes :'')'
225 texte(1,5) = '(7x,''Passage numero'',i5)'
226 texte(1,6) = '(5x,''Type de logiciel inconnu :'',i10,/)'
227 texte(1,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)'
229 > '(/,5x,i10,'' autres elements.'',/,5x,''Cela est interdit ...'')'
230 texte(1,10) ='(/,''On '',a,'' les elements incompatibles.'')'
232 texte(2,4) = '(5x,''Estimation of the number of edges:'')'
233 texte(2,5) = '(7x,''Pass #'',i5)'
234 texte(2,6) = '(5x,''This kind of software is unknown:'',i10,/)'
235 texte(2,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)'
237 > '(/,5x,i10,'' other elements.'',/,5x,''This is forbidden ...'')'
238 texte(2,10) ='(/,''Incompatible elements are '',a)'
246 #ifdef _DEBUG_HOMARD_
247 if ( eleinc.eq.0 ) then
248 write (ulsort,texte(langue,10)) 'bloque'
250 write (ulsort,texte(langue,10)) 'ignore'
254 #ifdef _DEBUG_HOMARD_
255 write (ulsort,90002) 'typcce', typcce
256 write (ulsort,90002) 'tyconf', tyconf
257 write (ulsort,90002) 'maext0', maext0
261 c 2. controle des elements a faces quadrangulaires
263 #ifdef _DEBUG_HOMARD_
264 write (ulsort,90002) '2. faces quadrangulaires ; codret', codret
267 if ( codret.eq.0 ) then
269 #ifdef _DEBUG_HOMARD_
270 write (ulsort,texte(langue,3)) 'UTAURQ', nompro
273 call utaurq ( modhom, eleinc,
276 > ulsort, langue, codret )
277 #ifdef _DEBUG_HOMARD_
278 write(ulsort,90002) 'nbelig', nbelig
284 c 3. recuperation des donnees du maillage d'entree
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,90002) '3. recuperation donnees ; codret', codret
290 c 3.1. ==> les noms des structures
291 #ifdef _DEBUG_HOMARD_
292 call gmprsx( nompro, nocman)
293 cgn call gmprsx( nompro, nocman//'.ConnNoeu')
294 cgn call gmprsx( nompro, nocman//'.ConnNoeu.Noeuds')
297 if ( codret.eq.0 ) then
299 #ifdef _DEBUG_HOMARD_
300 write (ulsort,texte(langue,3)) 'UTNOMC', nompro
302 call utnomc ( nocman,
304 > degre, mailet, maconf, homolo, hierar,
306 > ncinfo, ncnoeu, nccono, nccode,
308 > ncequi, ncfron, ncnomb,
309 > ulsort, langue, codret)
313 c 3.2. ==> les principales constantes
315 if ( codret.eq.0 ) then
317 call gmliat ( ncnoeu, 1, nbnoto, codre1 )
318 call gmliat ( ncnoeu, 2, nctfno, codre2 )
319 call gmliat ( ncnoeu, 3, dimcst, codre3 )
320 call gmliat ( nccono, 1, nbelem, codre4 )
321 call gmliat ( nccono, 2, nbmane, codre5 )
322 call gmadoj ( ncnomb, adnomb, iaux, codre6 )
324 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
326 codret = max ( abs(codre0), codret,
327 > codre1, codre2, codre3, codre4, codre5,
332 if ( codret.eq.0 ) then
334 #ifdef _DEBUG_HOMARD_
335 write (ulsort,texte(langue,3)) 'UTNBMC', nompro
337 call utnbmc ( imem(adnomb),
338 > nbmaae, nbmafe, nbmnei,
341 > nbmapo, nbsegm, nbtria, nbtetr,
342 > nbquad, nbhexa, nbpent, nbpyra,
343 > nbfmed, nbfmen, ngrouc,
345 > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu,
346 > ulsort, langue, codret )
350 c 3.3. ==> les adresses
352 if ( codret.eq.0 ) then
354 #ifdef _DEBUG_HOMARD_
355 write (ulsort,texte(langue,3)) 'UTAD11', nompro
358 call utad11 ( iaux, ncnoeu, nccono,
359 > pcoonc, pfamen, pnunoe, jaux,
360 > ptypel, pfamee, pnoeel, pnuele,
361 > ulsort, langue, codret )
365 if ( codret.eq.0 ) then
366 #ifdef _DEBUG_HOMARD_
367 write (ulsort,texte(langue,3)) 'UTAD12', nompro
371 call utad12 ( iaux, jaux,
373 > ulsort, langue, codret )
377 cmdc ---------------- MAILLES DOUBLES DEBUT --------------
378 cmdc 3.4. ==> menage des mailles dupliquees
380 cmdc 3.4.1. ==> Lecture du numero de la couche en cours
382 cmd if ( codret.eq.0 ) then
384 cmd nomfic = 'nrc.dat'
385 cmd inquire ( file = nomfic, exist = maildb )
389 cmd if ( maildb ) then
391 cmdcgn#ifdef _DEBUG_HOMARD_
392 cmd write (ulsort,*) 'MENAGE'
395 cmd if ( codret.eq.0 ) then
397 cmd call gmadoj ( ncfami//'.Numero', adnumf, iaux, codret )
401 cmd if ( codret.eq.0 ) then
402 cmdcgn call gmprsx(nompro,ncfami)
403 cmdcgn call gmprsx(nompro,ncfami//'.Numero')
404 cmdcgn call gmprsx(nompro,ncfami//'.Groupe')
405 cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Pointeur')
406 cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Taille')
407 cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Table')
409 cmdcgn#ifdef _DEBUG_HOMARD_
410 cmd write (ulsort,texte(langue,3)) 'UTRPTC', nompro
412 cmd call utrptc ( ncfami//'.Groupe',
414 cmd > adpoin, adtail, adtabl,
415 cmd > ulsort, langue, codret )
419 cmd if ( codret.eq.0 ) then
421 cmd call gmalot ( ntrav1, 'entier ', nbelem, ptrav1, codre1 )
423 cmd call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 )
425 cmd codre0 = min ( codre1, codre2 )
426 cmd codret = max ( abs(codre0), codret,
427 cmd > codre1, codre2 )
431 cmd if ( codret.eq.0 ) then
433 cmdcgn call gmprsx ( nompro, nccono//'.Noeuds')
434 cmdcgn write(ulsort,90003) 'norete', norete
435 cmdcgn write(ulsort,90002) 'nbeled', nbelem
436 cmdcgn write(ulsort,90002) 'nbtetd', nbtetr
437 cmdcgn#ifdef _DEBUG_HOMARD_
438 cmd write (ulsort,texte(langue,3)) 'VCMMEN', nompro
441 cmd > ( nbelem, nbelnw,
442 cmd > nbtetr, nbtenw,
443 cmd > imem(pnoeel), imem(pfamee), imem(ptypel), imem(pnuele),
445 cmd > imem(adpoin), imem(adtail), smem(adtabl),
446 cmd > imem(ptrav1), imem(ptrav2), imem(ptrav2+nbfmed),
447 cmd > ulsort, langue, codret )
451 cmd if ( codret.eq.0 ) then
453 cmd call gmmod ( nccono//'.Noeuds',
454 cmd > pnoeel, nbelem, nbelnw, nbmane, nbmane, codre1 )
455 cmd call gmmod ( nccono//'.Type',
456 cmd > ptypel, nbelem, nbelnw, 1, 1, codre2 )
457 cmd call gmmod ( nccono//'.FamilMED',
458 cmd > pfamee, nbelem, nbelnw, 1, 1, codre3 )
459 cmd call gmmod ( nccono//'.NumeExte',
460 cmd > pnuele, nbelem, nbelnw, 1, 1, codre4 )
461 cmd call gmecat ( nccono, 1, nbelnw, codre5 )
463 cmd codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
464 cmd codret = max ( abs(codre0), codret,
465 cmd > codre1, codre2, codre3, codre4, codre5 )
469 cmd if ( codret.eq.0 ) then
472 cmd numael = numael - nbtetr + nbtenw
473 cmd imem(adnomb+4) = numael
475 cmd imem(adnomb+14) = nbtetr
478 cmd if ( codret.eq.0 ) then
480 cmd call gmlboj ( ntrav1 , codre1 )
481 cmd call gmlboj ( ntrav2 , codre2 )
483 cmd codre0 = min ( codre1, codre2 )
484 cmd codret = max ( abs(codre0), codret,
485 cmd > codre1, codre2 )
491 cmdc ---------------- MAILLES DOUBLES FIN ----------------
497 #ifdef _DEBUG_HOMARD_
498 write (ulsort,90002) '4. preliminaires ; codret', codret
501 c 4.1.==> initialisations
503 if ( codret.eq.0 ) then
505 #ifdef _DEBUG_HOMARD_
506 write (ulsort,texte(langue,3)) 'UTINEI', nompro
508 call utinei ( modhom,
509 > ulsort, langue, codret )
513 c 4.2. ==> allocation de la tete du maillage HOMARD
515 if ( codret.eq.0 ) then
517 #ifdef _DEBUG_HOMARD_
518 write (ulsort,texte(langue,3)) 'UTAHMA', nompro
522 if ( dimcst.eq.0 ) then
527 if ( (nbtetr+nbhexa+nbpent+nbpyra).gt.0 ) then
529 elseif ( (nbtria+nbquad).gt.0 ) then
536 call utahma ( nohman, typnom, iaux,
537 > sdim, mdim, degre, mailet, maconf,
538 > homolo, hierar, rafdef,
539 > nbmane, typcca, typsfr, maextr,
541 > nhnoeu, nhmapo, nharet,
543 > nhtetr, nhhexa, nhpyra, nhpent,
545 > nhvois, nhsupe, nhsups,
546 > ulsort, langue, codret )
550 c 4.3. ==> renumerotation
552 if ( codret.eq.0 ) then
555 call gmecat ( norenu, 19, iaux, codre1 )
556 call gmaloj ( norenu//'.Nombres', ' ', iaux, adnbrn, codre2 )
558 codre0 = min ( codre1, codre2 )
559 codret = max ( abs(codre0), codret,
564 c 4.4. ==> les caracteristiques du maillage de calcul
566 if ( codret.eq.0 ) then
568 imem(adnbrn+9) = nbelem
569 imem(adnbrn+10) = nbmaae
570 imem(adnbrn+11) = nbmafe
571 imem(adnbrn+12) = nbmane
572 imem(adnbrn+13) = nbmapo
573 imem(adnbrn+14) = nbsegm
574 imem(adnbrn+15) = nbtetr
575 imem(adnbrn+16) = nbtria
576 imem(adnbrn+17) = nbquad
577 imem(adnbrn+18) = numael
578 imem(adnbrn+19) = numano
579 imem(adnbrn+22) = nbhexa
580 imem(adnbrn+23) = nbpyra
581 imem(adnbrn+24) = nbpent
583 c 4.5. ==> nombre total de mailles-points, de tetraedres, d'hexaedres,
584 c de pentaedres, de pyramides
596 nbpyto = nbpyra - nbelig
600 c 4.6. ==> initialisation des nombres reels de familles
615 c 5. traitement des noeuds
617 #ifdef _DEBUG_HOMARD_
618 write (ulsort,90002) '5. traitement des noeuds ; codret', codret
623 if ( codret.eq.0 ) then
630 c 5.2. ==> allocation des tableaux
632 if ( codret.eq.0 ) then
634 call gmecat ( nhnoeu, 1, nbnoto, codre1 )
635 call gmecat ( nhnoeu, 2, 0, codre2 )
637 call gmecat ( nhnoeu, 3, lgnoig, codre3 )
638 call gmecat ( nhnoeu, 4, 0, codre4 )
639 call gmaloj ( nhnoeu//'.InfoGene', ' ', lgnoig, adnoig, codre5 )
640 call gmaloj ( nhnoeu//'.HistEtat', ' ', nbnoto, phetno, codre6 )
642 call gmaloj ( nhnoeu//'.Coor', ' ', iaux, pcoono, codre7 )
643 call gmaloj ( nhnoeu//'.AretSupp', ' ', nbnoto, pareno, codre8 )
645 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
646 > codre6, codre7, codre8 )
647 codret = max ( abs(codre0), codret,
648 > codre1, codre2, codre3, codre4, codre5,
649 > codre6, codre7, codre8 )
651 call gmalot ( ntrav1, 'entier ', nbnoto, ptrav1, codre1 )
652 call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre2 )
654 codre0 = min ( codre1, codre2 )
655 codret = max ( abs(codre0), codret,
660 if ( codret.eq.0 ) then
662 #ifdef _DEBUG_HOMARD_
663 write (ulsort,texte(langue,3)) 'UTRE01_no', nompro
667 call utre01 ( iaux, kaux, norenu, rsnoac, rsnoto,
668 > adnohn, adnocn, adnoic,
669 > ulsort, langue, codret)
673 c 5.3. ==> les informations generales
675 if ( codret.eq.0 ) then
677 smem(adnoig+1) = 'x '
678 smem(adnoig+2) = 'y '
679 smem(adnoig+3) = 'z '
682 c 5.5. ==> traitement des noeuds
683 #ifdef _DEBUG_HOMARD_
684 write (ulsort,90002) '5.5. traitement noeuds ; codret', codret
687 if ( codret.eq.0 ) then
689 #ifdef _DEBUG_HOMARD_
690 write (ulsort,texte(langue,3)) 'VCMNOE', nompro
692 call vcmnoe ( eleinc, imem(pfamen), imem(pnoeel), imem(ptypel),
693 > dimcst, rmem(pcoonc),
694 > imem(adnohn), imem(adnocn),
695 > rmem(pcoono), imem(phetno), imem(pcexno),
696 > imem(ptrav1), imem(ptrav2),
697 > ulsort, langue, codret )
700 cgn call gmprsx ( nompro , norenu//'.NoHOMARD' )
701 cgn call gmprsx ( nompro , norenu//'.NoCalcul' )
703 if ( codret.eq.0 ) then
705 call gmlboj ( ntrav1 , codret )
707 imem(adnbrn) = nbnois
708 imem(adnbrn+1) = nbnoei
709 imem(adnbrn+2) = nbnomp
710 imem(adnbrn+3) = nbnop1
711 imem(adnbrn+4) = nbnop2
712 imem(adnbrn+5) = nbnoim
716 if ( codret.eq.0 ) then
718 call gmecat ( nhnoeu, 2, dimcst, codre1 )
719 call gmcpoj ( ncnoeu//'.CoorCons', nhnoeu//'.CoorCons', codre2 )
721 codre0 = min ( codre1, codre2 )
722 codret = max ( abs(codre0), codret,
728 c 6. determination des elements 0d, 1d, 2d ou 3d voisins des sommets
730 #ifdef _DEBUG_HOMARD_
731 write (ulsort,90002) '6. traitement mailles ; codret', codret
734 c 6.1. ==> comptage du nombre d'elements pour chaque sommet
735 c et determination des pointeurs par sommets sur "voisom",
736 c ranges dans la structure "povoso"
738 if ( codret.eq.0 ) then
740 call gmalot ( ntrav1, 'PtTabEnt', 0, iaux, codret )
744 if ( codret.eq.0 ) then
747 call gmaloj ( ntrav1//'.Pointeur', ' ', iaux, ppovos, codret )
751 if ( codret.eq.0 ) then
753 #ifdef _DEBUG_HOMARD_
754 write (ulsort,texte(langue,3)) 'VCVOS1', nompro
756 call vcvos1 ( imem(pnoeel), imem(ptypel), imem(ppovos),
757 > nvosom, nbelem, nbmane, nbnoto )
758 imem(adnbrn+21) = nvosom
762 c 6.2. ==> reperage des voisins : la structure voisom contient la
763 c liste des elements 1d, 2d ou 3d voisins de chaque sommet
764 c (allocation du tableau des voisins a une taille egale
765 c au nombre cumule de voisins des sommets)
767 if ( codret.eq.0 ) then
769 call gmaloj ( ntrav1//'.Table', ' ', nvosom, pvoiso, codret )
773 if ( codret.eq.0 ) then
775 #ifdef _DEBUG_HOMARD_
776 write (ulsort,texte(langue,3)) 'VCVOS2', nompro
778 call vcvos2 ( imem(pnoeel), imem(ptypel), imem(ppovos),
779 > imem(pvoiso), nvosom, nbelem, nbmane, nbnoto )
782 cgn call gmprsx ( nompro, ntrav1 )
783 cgn call gmprsx ( nompro, ntrav1//'.Pointeur' )
784 cgn call gmprsx ( nompro, ntrav1//'.Table' )
787 c 7. prise en compte des mailles-points
790 #ifdef _DEBUG_HOMARD_
791 write (ulsort,90002) '7. traitement mailles-points ; codret',
795 c 7.1. ==> memorisation du nombre de mailles-points
797 if ( codret.eq.0 ) then
799 call gmecat ( nhmapo, 1, nbmpto, codret )
803 c 7.2. ==> allocation des tableaux
806 if ( nbmpto.ne.0 ) then
812 if ( codret.eq.0 ) then
817 #ifdef _DEBUG_HOMARD_
818 write (ulsort,texte(langue,3)) 'UTAL02_mp', nompro
820 call utal02 ( iaux, jaux,
821 > nhmapo, nbmpto, kaux,
822 > phetmp, pnoemp, paux, paux,
826 > ulsort, langue, codret )
828 iaux = nbmpto * nctfmp
829 call gmaloj ( nccoex//'.Point', ' ', iaux , pcexmp, codre0 )
831 codret = max ( abs(codre0), codret )
835 if ( codret.eq.0 ) then
837 #ifdef _DEBUG_HOMARD_
838 write (ulsort,texte(langue,3)) 'UTRE01_mp', nompro
842 call utre01 ( iaux, kaux, norenu, rsmpac, rsmpto,
843 > admphn, admpcn, admpic,
844 > ulsort, langue, codret)
848 c 7.3. ==> remplissage des tableaux
849 c e : ntrav1 : voisom, voisinage des sommets
850 c e : ntrav2 : povoso, pointeur sur ntrav1=voisom
852 if ( nbmpto.ne.0 ) then
854 if ( codret.eq.0 ) then
856 #ifdef _DEBUG_HOMARD_
857 write (ulsort,texte(langue,3)) 'VCMMPO', nompro
860 > ( imem(pnoemp), imem(phetmp), imem(pcexmp),
861 > imem(adnocn), imem(admphn), imem(admpcn),
862 > imem(pfamee), imem(ptypel),
863 > imem(ppovos), imem(pvoiso),
864 > ulsort, langue, codret )
871 c 8. etablissement d'une table de connectivite par arete
874 #ifdef _DEBUG_HOMARD_
875 write (ulsort,90002) '8. connectivite par arete ; codret',codret
878 c 8.1. ==> allocation des tableaux
879 c la structure ntrav3 contiendra la table de connectivite par
880 c arete pour les elements 2d ou 3d. on la dimensionne au plus
881 c large en tenant compte du nombre maximum d'arete par element
882 c 2d ou 3d du maillage
883 c ici, seuls sont concernes les triangles, les quadrangles,
884 c les tetraedres, les pentaedres et les hexaedres
885 c c'est le tableau areele
886 c la structure ntrav4 contiendra le numero de la premiere arete
887 c partant d'un sommet donne ; c'est le tableau preare.
888 c pour dimensionner les tableaux lies aux aretes, on donne
889 c une estimation du nombre total par le maximum possible
891 if ( codret.eq.0 ) then
894 call gmalot ( ntrav3, 'entier ', iaux , ptrav3, codre1 )
895 call gmalot ( ntrav4, 'entier ', nbnoto, ptrav4, codre2 )
897 codre0 = min ( codre1, codre2 )
898 codret = max ( abs(codre0), codret,
903 c 8.2. ==> estimation du nombre d'aretes
905 if ( codret.eq.0 ) then
907 nbar00 = nbsegm + 3*nbtria + 4*nbquad
908 > + 6*nbtetr + 8*nbpyra + 12*nbhexa + 9*nbpent
910 #ifdef _DEBUG_HOMARD_
911 write (ulsort,90002) 'nbar00 initial', nbar00
914 #ifdef _DEBUG_HOMARD_
915 write (ulsort,texte(langue,3)) 'VCMAR0', nompro
917 call vcmar0 ( imem(adnohn), imem(adnocn),
918 > imem(pnoeel), imem(ptypel),
919 > imem(ppovos), imem(pvoiso),
921 > ulsort, langue, codret )
923 nbar00 = nbar00 - nbardb/2
925 if ( nbsegm.ne.0 ) then
933 #ifdef _DEBUG_HOMARD_
934 write (ulsort,90002) 'nbar00, rbar00, rsarac',
935 > nbar00, rbar00, rsarac
942 c 8.3. ==> allocations
944 if ( codret.eq.0 ) then
948 if ( degre.eq.2 ) then
951 if ( nbelig.ne.0 ) then
955 #ifdef _DEBUG_HOMARD_
956 write (ulsort,texte(langue,3)) 'UTAL02_ar', nompro
958 call utal02 ( iaux, jaux,
959 > nharet, nbar00, kaux,
960 > phetar, psomar, pfilar, pmerar,
962 > paux, pnp2ar, adars2,
964 > ulsort, langue, codret )
968 if ( codret.eq.0 ) then
970 iaux = nbar00 * nctfar
971 call gmaloj ( nccoex//'.Arete', ' ', iaux , pcexar, codre1 )
972 call gmalot ( ntrav5, 'entier ', rbar00, ptrav5, codre2 )
974 codre0 = min ( codre1, codre2 )
975 codret = max ( abs(codre0), codret,
980 if ( codret.eq.0 ) then
982 #ifdef _DEBUG_HOMARD_
983 write (ulsort,texte(langue,3)) 'UTRE01_ar', nompro
987 call utre01 ( iaux, kaux, norenu, rsarac, rbar00,
988 > adarhn, adarcn, adaric,
989 > ulsort, langue, codret)
993 c 8.4. ==> etablissement de la table et initialisation des tableaux
998 if ( codret.eq.0 ) then
1000 #ifdef _DEBUG_HOMARD_
1001 write (ulsort,90002) 'nbar00, rbar00', nbar00, rbar00
1004 #ifdef _DEBUG_HOMARD_
1005 write (ulsort,texte(langue,3)) 'VCMARE', nompro
1008 > ( imem(ptrav3), imem(psomar), imem(pnp2ar),
1009 > imem(phetar), imem(pfilar), imem(pmerar),
1010 > imem(pcexar), imem(pareno), imem(adars2),
1011 > imem(adnohn), imem(adnocn), imem(adarhn),
1012 > imem(adarcn), imem(pfamee), imem(pnoeel),
1013 > imem(ptypel), imem(ppovos), imem(pvoiso),
1015 > arsmed, deamed, imem(ptrav5),
1017 > ulsort, langue, codret )
1019 #ifdef _DEBUG_HOMARD_
1020 write (ulsort,90002) '--> nbarto', nbarto
1025 c 8.5. ==> si l'estimation est trop courte, on augmente
1027 if ( codret.eq.0 ) then
1029 if ( nbarto.lt.0 ) then
1031 nbarne = int(1.3d0*dble(nbar00))
1032 rbarne = int(1.3d0*dble(rbar00))
1042 #ifdef _DEBUG_HOMARD_
1043 write (ulsort,90002) 'nbarne, rbarne', nbarne, rbarne
1048 c 8.6. ==> connaissant le vrai nombre d'aretes, on ajuste les tableaux
1049 c somare, nareho, nareca, hetare, filare, merare
1050 c a leurs vraies tailles
1051 c de plus, on desalloue les tableaux ne servant plus a rien
1053 #ifdef _DEBUG_HOMARD_
1054 write (ulsort,90002) '8.6 apres vcmare ; codret', codret
1057 if ( rsarto.ne.0 ) then
1059 if ( codret.eq.0 ) then
1061 #ifdef _DEBUG_HOMARD_
1062 write (ulsort,texte(langue,3)) 'UTRE02_ar', nompro
1066 call utre02 ( iaux, jaux, norenu,
1067 > kaux, rbar00, kaux, rbarne,
1069 > ulsort, langue, codret)
1075 if ( codret.eq.0 ) then
1079 if ( degre.eq.2 ) then
1082 if ( nbelig.ne.0 ) then
1086 #ifdef _DEBUG_HOMARD_
1087 write (ulsort,texte(langue,3)) 'UTAD06_ar', nompro
1089 call utad06 ( iaux, jaux, kaux, nharet,
1090 > nbar00, nbarne, 0, 0,
1091 > phetar, psomar, pfilar, pmerar,
1093 > paux, pnp2ar, adars2,
1094 > paux, paux, paux, paux,
1095 > ulsort, langue, codret )
1099 if ( codret.eq.0 ) then
1101 call gmmod ( nccoex//'.Arete',
1102 > pcexar, nbar00, nbarne, nctfar, nctfar, codre1 )
1103 call gmmod ( ntrav5,
1104 > ptrav5, rbar00, rbarne, 1, 1, codre2 )
1106 codre0 = min ( codre1, codre2 )
1107 codret = max ( abs(codre0), codret,
1112 c 8.7. ==> si l'estimation est trop courte, on recommence
1114 if ( codret.eq.0 ) then
1116 if ( cpt.gt.0 ) then
1118 write (ulsort,texte(langue,4))
1119 write (ulsort,texte(langue,5)) cpt
1130 if ( codret.eq.0 ) then
1132 call gmsgoj ( ntrav1 , codre1 )
1133 call gmlboj ( ntrav2 , codre2 )
1134 call gmlboj ( ntrav4 , codre3 )
1135 call gmlboj ( ntrav5 , codre4 )
1137 codre0 = min ( codre1, codre2, codre3, codre4 )
1138 codret = max ( abs(codre0), codret,
1139 > codre1, codre2, codre3, codre4 )
1144 c 9. etablissement d'une table de connectivite par face
1147 #ifdef _DEBUG_HOMARD_
1148 write (ulsort,90002) '9. connectivite par face ; codret', codret
1151 c 9.1. ==> determination des elements 2d ou 3d voisins des aretes
1153 c 9.1.1. ==> comptage du nombre d'elements pour chaque arete
1155 if ( codret.eq.0 ) then
1158 call gmalot ( ntrav2, 'entier ', iaux , ptrav2, codret )
1162 if ( codret.eq.0 ) then
1164 #ifdef _DEBUG_HOMARD_
1165 write (ulsort,texte(langue,3)) 'VCVAR1', nompro
1167 call vcvar1 ( imem(ptrav3), imem(ptypel), imem(ptrav2) )
1168 imem(adnbrn+20) = nvoare
1172 c 9.1.2. ==> reperage des voisins
1173 c allocation du tableau des voisins a une taille
1174 c egale au nombre cumule de voisins des aretes
1176 c la structure ntrav1 contient la liste des elements 2d ou 3d
1177 c voisins de chaque arete ; c'est le tableau vofaar
1178 c la structure ntrav2 contient les pointeurs sur vofaar ; c'est
1181 if ( codret.eq.0 ) then
1182 call gmalot ( ntrav1, 'entier ', nvoare, ptrav1, codret )
1185 if ( codret.eq.0 ) then
1187 #ifdef _DEBUG_HOMARD_
1188 write (ulsort,texte(langue,3)) 'VCVAR2', nompro
1190 call vcvar2 ( imem(ptrav3), imem(ptypel), imem(ptrav1),
1195 c 9.2. ==> allocation des tableaux
1196 c la structure ntrite contiendra la table de connectivite par
1197 c face. on la dimmensionne au plus large en tenant compte du
1198 c nombre maximum de face par element 3d du maillage ; c'est le
1200 c la structure ntrav4 contiendra le numero de la premiere face
1201 c partant d'une arete donnee ; c'est le tableau prefac.
1202 c pour dimensionner les tableaux lies aux faces, on donne
1203 c une estimation du nombre total par le maximum possible.
1205 c 9.2.1. ==> on verifie qu'il y a assez de place avant de se lancer
1207 if ( codret.eq.0 ) then
1209 nbtr00 = nbtria + 4*nbtetr + 4*nbpyra + 2*nbpent
1210 if ( nbtria.ne.0 ) then
1218 nbqu00 = nbquad + 6*nbhexa + nbpyra + 3*nbpent
1219 if ( nbquad.ne.0 ) then
1228 if ( nbteto.ne.0 ) then
1235 if ( nbheto.ne.0 ) then
1242 if ( nbpyto.ne.0 ) then
1249 if ( nbpeto.ne.0 ) then
1257 c 9.2.2. ==> allocation
1259 if ( codret.eq.0 ) then
1261 c 9.2.2.1. ==> pour les triangles, dans deux cas :
1262 c . il y en a (quelle bonne idee)
1263 c . il n'y en a pas, mais les quadrangles decoupes par
1264 c conformite pourraient en produire ; on cree le tableau
1265 c de sauvegarde des codes externes
1266 #ifdef _DEBUG_HOMARD_
1267 write (ulsort,90002) '9.2.2.1. triangles ; codret', codret
1268 write (ulsort,90002) 'nbtr00, nbqu00', nbtr00, nbqu00
1271 if ( nbtr00.ne.0 ) then
1273 if ( mod(mailet,3).eq.0 ) then
1274 if ( mod(mailet,2).ne.0 ) then
1281 if ( mod(mailet,2).eq.0 ) then
1285 #ifdef _DEBUG_HOMARD_
1286 write (ulsort,texte(langue,3)) 'UTAL02_tr', nompro
1288 call utal02 ( iaux, jaux,
1289 > nhtria, nbtr00, kaux,
1290 > phettr, paretr, pfiltr, ppertr,
1292 > pnivtr, paux, paux,
1293 > adnmtr, paux, paux,
1294 > ulsort, langue, codret )
1298 if ( nbtr00.ne.0 .or. nbqu00.ne.0 ) then
1300 iaux = nbtr00 * nctftr
1301 call gmaloj ( nccoex//'.Trian', ' ', iaux , pcextr, codre0 )
1303 codret = max ( abs(codre0), codret )
1307 c 9.2.2.2. ==> pour les quadrangles, dans un cas :
1308 c . il y en a (quelle bonne idee)
1310 #ifdef _DEBUG_HOMARD_
1311 write (ulsort,90002) '9.2.2.2. quadrangles ; codret', codret
1312 write (ulsort,90002) 'nbqu00', nbqu00
1315 if ( nbqu00.ne.0 ) then
1319 if ( mod(mailet,3).eq.0 ) then
1323 #ifdef _DEBUG_HOMARD_
1324 write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro
1326 call utal02 ( iaux, jaux,
1327 > nhquad, nbqu00, kaux,
1328 > phetqu, parequ, pfilqu, pperqu,
1330 > pnivqu, paux, paux,
1331 > adnmqu, paux, paux,
1332 > ulsort, langue, codret )
1334 iaux = nbqu00 * nctfqu
1335 call gmaloj ( nccoex//'.Quadr', ' ', iaux , pcexqu, codre0 )
1337 codret = max ( abs(codre0), codret )
1341 c 9.2.2.3. ==> pour les tetraedres, dans un cas :
1342 c . il y en a (quelle bonne idee)
1343 c . il n'y en a pas, mais les hexaedres decoupes par
1344 c conformite pourraient en produire ; on cree le tableau
1345 c de sauvegarde des codes externes
1347 #ifdef _DEBUG_HOMARD_
1348 write (ulsort,90002) '9.2.2.3. tetraedres ; codret', codret
1349 write (ulsort,90002) 'nbteto', nbteto
1352 if ( nbteto.ne.0 ) then
1357 #ifdef _DEBUG_HOMARD_
1358 write (ulsort,texte(langue,3)) 'UTAL02_te', nompro
1360 call utal02 ( iaux, jaux,
1361 > nhtetr, nbteto, kaux,
1362 > phette, ptrite, pfilte, pperte,
1364 > paux , pcotrt, paux,
1366 > ulsort, langue, codret )
1370 if ( nbteto.ne.0 .or. ( nbheto.ne.0 .and. tyconf.eq.-1 ) ) then
1372 iaux = nbteto * nctfte
1373 call gmaloj ( nccoex//'.Tetra', ' ', iaux , pcexte, codre0 )
1375 codret = max ( abs(codre0), codret )
1379 c 9.2.2.4. ==> pour les hexaedres, dans un cas :
1380 c . il y en a (quelle bonne idee)
1382 #ifdef _DEBUG_HOMARD_
1383 write (ulsort,90002) '9.2.2.4. hexaedres ; codret', codret
1384 write (ulsort,90002) 'nbheto', nbheto
1386 if ( nbheto.ne.0 ) then
1390 if ( mod(mailet,5).eq.0 ) then
1394 #ifdef _DEBUG_HOMARD_
1395 write (ulsort,texte(langue,3)) 'UTAL02_he', nompro
1397 call utal02 ( iaux, jaux,
1398 > nhhexa, nbheto, kaux,
1399 > phethe, pquahe, pfilhe, pperhe,
1401 > paux , pcoquh, paux,
1402 > adnmhe, paux, paux,
1403 > ulsort, langue, codret )
1405 iaux = nbheto * nctfhe
1406 call gmaloj ( nccoex//'.Hexae', ' ', iaux , pcexhe, codre0 )
1408 codret = max ( abs(codre0), codret )
1412 c 9.2.2.5. ==> pour les pyramides, dans un cas :
1413 c . il y en a (quelle bonne idee)
1414 c . il n'y en a pas, mais les hexaedres decoupes par
1415 c conformite pourraient en produire ; on cree le tableau
1416 c de sauvegarde des codes externes
1418 #ifdef _DEBUG_HOMARD_
1419 write (ulsort,90002) '9.2.2.5. pyramides ; codret', codret
1420 write (ulsort,90002) 'nbpyto', nbpyto
1421 write (ulsort,90002) 'nbheto', nbheto
1422 write (ulsort,90002) 'tyconf', tyconf
1424 if ( nbpyto.ne.0 ) then
1429 #ifdef _DEBUG_HOMARD_
1430 write (ulsort,texte(langue,3)) 'UTAL02_py', nompro
1432 call utal02 ( iaux, jaux,
1433 > nhpyra, nbpyto, kaux,
1434 > phetpy, pfacpy, pfilpy, pperpy,
1436 > paux , pcofay, paux,
1438 > ulsort, langue, codret )
1442 if ( nbpyto.ne.0 .or. ( nbheto.ne.0 .and. tyconf.eq.-1 ) ) then
1444 iaux = nbpyto * nctfpy
1445 call gmaloj ( nccoex//'.Pyram', ' ', iaux , pcexpy, codre0 )
1447 codret = max ( abs(codre0), codret )
1451 c 9.2.2.6. ==> pour les pentaedres, 1 seul cas : il y en a
1453 #ifdef _DEBUG_HOMARD_
1454 write (ulsort,90002) '9.2.2.6. pentaedres ; codret', codret
1455 write (ulsort,90002) 'nbpeto', nbpeto
1457 if ( nbpeto.ne.0 ) then
1462 #ifdef _DEBUG_HOMARD_
1463 write (ulsort,texte(langue,3)) 'UTAL02_pe', nompro
1465 call utal02 ( iaux, jaux,
1466 > nhpent, nbpeto, kaux,
1467 > phetpe, pfacpe, pfilpe, pperpe,
1469 > paux , pcofap, paux,
1471 > ulsort, langue, codret )
1473 iaux = nbpeto * nctfpe
1474 call gmaloj ( nccoex//'.Penta', ' ', iaux , pcexpe, codre0 )
1476 codret = max ( abs(codre0), codret )
1480 c 9.2.2.7. ==> la renumerotation des faces 2D
1482 #ifdef _DEBUG_HOMARD_
1483 write (ulsort,90002) '9.2.2.7. ren. faces 2D ; codret', codret
1486 if ( codret.eq.0 ) then
1488 #ifdef _DEBUG_HOMARD_
1489 write (ulsort,texte(langue,3)) 'UTRE01_tr', nompro
1493 call utre01 ( iaux, jaux, norenu, rstrac, rbtr00,
1494 > adtrhn, adtrcn, adtric,
1495 > ulsort, langue, codret)
1499 if ( codret.eq.0 ) then
1501 #ifdef _DEBUG_HOMARD_
1502 write (ulsort,texte(langue,3)) 'UTRE01_qu', nompro
1505 if ( nbqu00.eq.0 ) then
1511 call utre01 ( iaux, jaux, norenu, kaux, rbqu00,
1512 > adquhn, adqucn, adquic,
1513 > ulsort, langue, codret)
1517 c 9.2.2.8. ==> la renumerotation des tetraedres
1518 c remarque : on alloue meme en l'absence de tetraedres
1519 c car on utilise les attributs par la suite !
1521 #ifdef _DEBUG_HOMARD_
1522 write (ulsort,90002) '9.2.2.8. ren. tetraedres ; codret', codret
1525 if ( codret.eq.0 ) then
1527 #ifdef _DEBUG_HOMARD_
1528 write (ulsort,texte(langue,3)) 'UTRE01_te', nompro
1532 call utre01 ( iaux, jaux, norenu, rsteac, rsteto,
1533 > adtehn, adtecn, adteic,
1534 > ulsort, langue, codret)
1538 c 9.2.2.9. ==> la renumerotation des pyramides
1539 c remarque : on alloue meme en l'absence de pyramides
1540 c car on utilise les attributs par la suite !
1542 #ifdef _DEBUG_HOMARD_
1543 write (ulsort,90002) '9.2.2.9. ren. pyramides ; codret', codret
1546 if ( codret.eq.0 ) then
1548 #ifdef _DEBUG_HOMARD_
1549 write (ulsort,texte(langue,3)) 'UTRE01_py', nompro
1553 call utre01 ( iaux, jaux, norenu, rspyac, rspyto,
1554 > adpyhn, adpycn, adpyic,
1555 > ulsort, langue, codret)
1559 c 9.2.2.10. ==> la renumerotation des hexaedres
1560 c remarque : on alloue meme en l'absence de hexaedres
1561 c car on utilise les attributs par la suite !
1563 #ifdef _DEBUG_HOMARD_
1564 write (ulsort,90002) '9.2.2.10. ren. hexaedres ; codret', codret
1567 if ( codret.eq.0 ) then
1569 #ifdef _DEBUG_HOMARD_
1570 write (ulsort,texte(langue,3)) 'UTRE01_he', nompro
1574 call utre01 ( iaux, jaux, norenu, rsheac, rsheto,
1575 > adhehn, adhecn, adheic,
1576 > ulsort, langue, codret)
1580 c 9.2.2.11. ==> la renumerotation des pentaedres
1581 c remarque : on alloue meme en l'absence de pentaedres
1582 c car on utilise les attributs par la suite !
1584 #ifdef _DEBUG_HOMARD_
1585 write (ulsort,90002) '9.2.2.11. ren. pentaedres ; codret', codret
1588 if ( codret.eq.0 ) then
1590 #ifdef _DEBUG_HOMARD_
1591 write (ulsort,texte(langue,3)) 'UTRE01_pe', nompro
1595 call utre01 ( iaux, jaux, norenu, rspeac, rspeto,
1596 > adpehn, adpecn, adpeic,
1597 > ulsort, langue, codret)
1601 c 9.2.2.12. ==> des tableaux de travail
1604 call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre1 )
1605 iaux = 2*max(rbtr00,rbqu00)
1606 call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre2 )
1608 codre0 = min ( codre1, codre2 )
1609 codret = max ( abs(codre0), codret,
1614 c 9.3. ==> etablissement de la table et initialisation des faces
1616 c rappel pour vcmfac :
1617 c e : ntrav1 : vofaar, voisinage des aretes
1618 c e : ntrav2 : povoar, pointeur sur ntrav1=vofaar
1619 c e : ntrav3 : areele, table de connectivite par arete
1620 c a : ntrav4 : prefac, premiere face s'appuyant sur une arete
1621 c a : ntrav5 : dejavu, controle des doublons
1623 if ( codret.eq.0 ) then
1625 #ifdef _DEBUG_HOMARD_
1626 write (ulsort,texte(langue,3)) 'VCMFAC', nompro
1629 > ( imem(paretr), imem(phettr),
1630 > imem(pfiltr), imem(ppertr), imem(pnivtr),
1632 > imem(pcextr), imem(adtrhn), imem(adtrcn),
1633 > imem(parequ), imem(phetqu),
1634 > imem(pfilqu), imem(pperqu), imem(pnivqu),
1636 > imem(pcexqu), imem(adquhn), imem(adqucn),
1637 > imem(ptrite), imem(phette),
1638 > imem(pfilte), imem(pperte),
1639 > imem(pcexte), imem(adtehn), imem(adtecn),
1640 > imem(pquahe), imem(phethe),
1641 > imem(pfilhe), imem(pperhe), imem(adnmhe),
1642 > imem(pcexhe), imem(adhehn), imem(adhecn),
1643 > imem(pfacpe), imem(phetpe),
1644 > imem(pfilpe), imem(pperpe),
1645 > imem(pcexpe), imem(adpehn), imem(adpecn),
1646 > imem(pfacpy), imem(phetpy),
1647 > imem(pfilpy), imem(pperpy),
1648 > imem(pcexpy), imem(adpyhn), imem(adpycn),
1649 > imem(ptrav3), imem(pnoeel), imem(ptypel), imem(pfamee),
1650 > imem(ptrav1), imem(ptrav2), imem(ptrav4), imem(ptrav5),
1651 > imem(psomar), imem(adnohn), imem(adnocn),
1652 > ulsort, langue, codret )
1656 c 9.4. ==> connaissant le vrai nombre de faces, on ajuste les tableaux
1657 c a leurs vraies tailles
1658 c de plus, on desalloue les tableaux ne servant plus a rien
1660 #ifdef _DEBUG_HOMARD_
1661 write (ulsort,90002) '9.4. apres vcmfac ; codret', codret
1664 c 9.4.1. ==> triangles
1666 #ifdef _DEBUG_HOMARD_
1667 write (ulsort,90002) '9.4.1. triangles ; codret', codret
1668 write (ulsort,90002) 'nbtr00, nbtrto', nbtr00, nbtrto
1669 write (ulsort,90002) 'rbtr00, rstrto', rbtr00, rstrto
1672 if ( nbtr00.ne.0 ) then
1674 if ( codret.eq.0 ) then
1678 if ( mod(mailet,2).eq.0 ) then
1682 #ifdef _DEBUG_HOMARD_
1683 write (ulsort,texte(langue,3)) 'UTAD06_tr', nompro
1685 call utad06 ( iaux, jaux, kaux, nhtria,
1686 > nbtr00, nbtrto, 0, 0,
1687 > phettr, paretr, pfiltr, ppertr,
1689 > pnivtr, paux, paux,
1690 > adnmtr, paux, paux, paux,
1691 > ulsort, langue, codret )
1695 if ( codret.eq.0 ) then
1697 call gmmod ( nccoex//'.Trian',
1698 > pcextr, nbtr00, nbtrto, nctftr, nctftr, codre0 )
1700 codret = max ( abs(codre0), codret )
1706 if ( rbtr00.ne.0 ) then
1708 if ( codret.eq.0 ) then
1710 #ifdef _DEBUG_HOMARD_
1711 write (ulsort,texte(langue,3)) 'UTRE02_tr', nompro
1715 call utre02 ( iaux, jaux, norenu,
1716 > kaux, rbtr00, kaux, rstrto,
1718 > ulsort, langue, codret)
1724 c 9.4.2. ==> quadrangles
1726 #ifdef _DEBUG_HOMARD_
1727 write (ulsort,90002) '9.4.2. quadrangles ; codret', codret
1728 write (ulsort,90002) 'nbqu00, nbquto', nbqu00, nbquto
1729 write (ulsort,90002) 'rbqu00, rsquto', rbqu00, rsquto
1732 if ( nbqu00.ne.0 ) then
1734 if ( codret.eq.0 ) then
1738 if ( mod(mailet,3).eq.0 ) then
1742 #ifdef _DEBUG_HOMARD_
1743 write (ulsort,texte(langue,3)) 'UTAD06_qu', nompro
1745 call utad06 ( iaux, jaux, kaux, nhquad,
1746 > nbqu00, nbquto, 0, 0,
1747 > phetqu, parequ, pfilqu, pperqu,
1749 > pnivqu, paux, paux,
1750 > adnmqu, paux, paux, paux,
1751 > ulsort, langue, codret )
1755 if ( codret.eq.0 ) then
1757 call gmmod ( nccoex//'.Quadr',
1758 > pcexqu, nbqu00, nbquto, nctfqu, nctfqu, codre0 )
1760 codret = max ( abs(codre0), codret )
1766 if ( rbqu00.ne.0 ) then
1768 if ( codret.eq.0 ) then
1770 #ifdef _DEBUG_HOMARD_
1771 write (ulsort,texte(langue,3)) 'UTRE02_qu', nompro
1775 call utre02 ( iaux, jaux, norenu,
1776 > kaux, rbqu00, kaux, rsquto,
1778 > ulsort, langue, codret)
1784 #ifdef _DEBUG_HOMARD_
1785 call gmprsx (nompro, norenu//'.QuCalcul')
1786 call gmprsx (nompro, norenu//'.QuHOMARD')
1787 call gmprsx (nompro, nhquad//'.ConnDesc' )
1788 call gmprsx (nompro, nhquad//'.HistEtat')
1789 call gmprsx (nompro, nhquad//'.Fille' )
1790 call gmprsx (nompro, nhquad//'.Mere')
1791 call gmprsx (nompro, nhquad//'.Niveau' )
1792 call gmprsx (nompro, nccoex//'.Quadr')
1796 c 10. orientation des aretes et des faces du calcul et code des faces
1799 #ifdef _DEBUG_HOMARD_
1800 write (ulsort,90002) '10. orientation ; codret', codret
1803 if ( codret.eq.0 ) then
1805 #ifdef _DEBUG_HOMARD_
1806 write (ulsort,texte(langue,3)) 'VCORIE', nompro
1809 > ( eleinc, imem(pnoeel), imem(ptrav3), imem(ptypel),
1810 > imem(psomar), imem(paretr), imem(parequ),
1811 > imem(adnohn), imem(adarhn), imem(adtrhn), imem(adquhn),
1813 > imem(ptrite), imem(pcotrt), imem(adtehn),
1814 > imem(pquahe), imem(pcoquh), imem(adhehn),
1815 > imem(pfacpe), imem(pcofap), imem(adpehn),
1816 > imem(pfacpy), imem(pcofay), imem(adpyhn),
1817 > ulsort, langue, codret )
1823 #ifdef _DEBUG_HOMARD_
1824 write (ulsort,90002) '10.2. menage ; codret', codret
1827 if ( codret.eq.0 ) then
1829 call gmlboj ( ntrav1 , codre1 )
1830 call gmlboj ( ntrav2 , codre2 )
1831 call gmlboj ( ntrav3 , codre3 )
1832 call gmlboj ( ntrav4 , codre4 )
1833 call gmlboj ( ntrav5 , codre5 )
1835 codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
1836 codret = max ( abs(codre0), codret,
1837 > codre1, codre2, codre3, codre4, codre5 )
1842 c 11. reperage des eventuelles non conformites
1845 #ifdef _DEBUG_HOMARD_
1846 write (ulsort,90002) '11. non conformites ; codret', codret
1847 write (ulsort,90002) 'tyconf', tyconf
1853 if ( tyconf.gt.0 .or. tyconf.eq.-2 ) then
1855 if ( codret.eq.0 ) then
1857 #ifdef _DEBUG_HOMARD_
1858 cgn call gmprsx (nompro, nccoex//'.Arete' )
1859 call gmprsx (nompro, nharet//'.ConnDesc' )
1860 call gmprsx (nompro, nhtria//'.ConnDesc' )
1861 call gmprsx (nompro, nhquad//'.ConnDesc' )
1864 #ifdef _DEBUG_HOMARD_
1865 write (ulsort,texte(langue,3)) 'VCMNCO', nompro
1868 call vcmnco ( nohman,
1869 > nhnoeu, nharet, nhtria, nhquad, nhvois,
1871 > rmem(pcoono), imem(phetno), imem(pareno),
1872 > imem(pcexno), imem(adnohn), imem(adnocn),
1873 > imem(psomar), imem(phetar), imem(pnp2ar),
1874 > imem(pmerar), imem(pfilar), imem(adars2),
1875 > imem(pcexar), imem(adarhn), imem(adarcn),
1876 > imem(phettr), imem(paretr),
1877 > imem(pfiltr), imem(ppertr),
1878 > imem(phetqu), imem(parequ),
1879 > imem(pfilqu), imem(pperqu),
1880 > imem(pcexqu), imem(adquhn), imem(adqucn),
1881 > imem(pquahe), imem(pcoquh),
1882 > ulsort, langue, codret )
1884 #ifdef _DEBUG_HOMARD_
1885 cgn call gmprsx (nompro, nccoex//'.Arete' )
1886 cgn call gmprsx (nompro, nhnoeu//'.AretSupp')
1887 cgn call gmprsx (nompro, nharet//'.ConnDesc' )
1888 cgn call gmprsx (nompro, nharet//'.HistEtat' )
1889 cgn call gmprsx (nompro, nharet//'.Fille' )
1890 cgn call gmprsx (nompro, nharet//'.Mere' )
1891 cgn call gmprsx (nompro, nhtria//'.ConnDesc' )
1892 cgn call gmprsx (nompro, nhquad//'.ConnDesc' )
1900 c 12. determination des voisinages
1903 #ifdef _DEBUG_HOMARD_
1904 write (ulsort,90002) '12. voisinages ; codret', codret
1907 if ( codret.eq.0 ) then
1909 if ( homolo.ne.0 ) then
1918 #ifdef _DEBUG_HOMARD_
1919 cgn call gmprsx ('Volumes dans '//nompro,nohman//'.Volume')
1920 if ( nbtrto.gt.0 ) then
1921 call gmprsx ('nhtria dans '//nompro, nhtria)
1922 call gmprot ('Triangle ConnDesc', nhtria//'.ConnDesc',
1923 > 1, min(10,nbtrto) )
1924 call gmprsx ('InfoSupp', nhtria//'.InfoSupp')
1926 if ( nbquto.gt.0 ) then
1927 call gmprsx ('nhquad dans '//nompro, nhquad)
1928 call gmprot ('Quadrangle ConnDesc', nhquad//'.ConnDesc',
1929 > 1, min(10,nbquto) )
1930 call gmprsx ('InfoSupp', nhquad//'.InfoSupp')
1932 if ( nbteto.gt.0 ) then
1933 call gmprsx ('nhtetr dans '//nompro, nhtetr)
1935 if ( nbheto.gt.0 ) then
1936 call gmprsx ('nhhexa dans '//nompro, nhhexa)
1938 if ( nbpeto.gt.0 ) then
1939 call gmprsx ('nhpent dans '//nompro, nhpent)
1941 if ( nbpyto.gt.0 ) then
1942 call gmprsx ('nhpyra dans '//nompro, nhpyra)
1943 call gmprsx ('ConnDesc', nhpyra//'.ConnDesc')
1944 call gmprsx ('InfoSupp', nhpyra//'.InfoSupp')
1946 cgn call gmprsx ('nhpyra dans '//nompro,nhpyra)
1948 #ifdef _DEBUG_HOMARD_
1949 write (ulsort,texte(langue,3)) 'UTVOIS', nompro
1951 call utvois ( nohman, nhvois,
1952 > voarno, vofaar, vovoar, vovofa,
1954 > nbfaar, pposif, pfacar,
1955 > ulsort, langue, codret )
1960 c 13. mise a jour des numerotations
1963 #ifdef _DEBUG_HOMARD_
1964 write (ulsort,90002) '13. numerotations ; codret', codret
1967 if ( codret.eq.0 ) then
1969 c 13.1. ==> Decalage des numerotations (cf. eslmm2)
1971 #ifdef _DEBUG_HOMARD_
1972 write(ulsort,90002) 'nbmapo', nbmapo
1973 write(ulsort,90002) 'nbsegm', nbsegm
1974 write(ulsort,90002) 'nbtria', nbtria
1975 write(ulsort,90002) 'nbtetr', nbtetr
1976 write(ulsort,90002) 'nbquad', nbquad
1977 write(ulsort,90002) 'nbhexa', nbhexa
1978 write(ulsort,90002) 'nbpent', nbpent
1979 write(ulsort,90002) 'nbpyra', nbpyra
1984 decanu(1) = nbtetr + nbtria
1985 decanu(0) = nbtetr + nbtria + nbsegm
1986 decanu(4) = nbtetr + nbtria + nbsegm + nbmapo
1987 decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad
1988 decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
1989 decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
1992 #ifdef _DEBUG_HOMARD_
1993 write(ulsort,90002) 'decanu', decanu
1995 #ifdef _DEBUG_HOMARD_
1996 cgn call gmprot (nompro, ncnoeu//'.NumeExte' , 1, 20 )
1997 cgn call gmprot (nompro, ncnoeu//'.NumeExte' , nbnoto-20, nbnoto )
1998 cgn call gmprot (nompro, nccono//'.NumeExte' , 1, 20 )
1999 cgn call gmprot (nompro, nccono//'.NumeExte' , nbelem-20, nbelem )
2000 cgn call gmprsx (nompro, nccono//'.NumeExte' )
2003 c 13.2. ==> Traitement
2005 #ifdef _DEBUG_HOMARD_
2006 write (ulsort,texte(langue,3)) 'VCMREN', nompro
2008 call vcmren ( imem(adnohn), imem(adnocn), imem(adnoic),
2009 > imem(admphn), imem(admpcn), imem(admpic),
2010 > imem(adarhn), imem(adarcn), imem(adaric),
2011 > imem(adtrhn), imem(adtrcn), imem(adtric),
2012 > imem(adquhn), imem(adqucn), imem(adquic),
2013 > imem(adtehn), imem(adtecn), imem(adteic),
2014 > imem(adpyhn), imem(adpycn), imem(adpyic),
2015 > imem(adhehn), imem(adhecn), imem(adheic),
2016 > imem(adpehn), imem(adpecn), imem(adpeic),
2017 > imem(pnunoe), imem(pnuele), decanu,
2018 > ulsort, langue, codret )
2019 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.InfoSupE.Tab4')
2020 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.TrHOMARD')
2021 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.TrCalcul')
2022 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.InfoSupE.Tab5')
2023 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.QuHOMARD')
2024 cgn call gmprsx (nompro//'-apres vcmren', norenu//'.QuCalcul')
2026 #ifdef _DEBUG_HOMARD_
2027 call gmprot (nompro, norenu//'.NoHOMARD' , 1, 20 )
2028 call gmprot (nompro, norenu//'.NoHOMARD' , rsnoac-20, rsnoac )
2029 call gmprot (nompro, norenu//'.MPHOMARD' , 1, 20 )
2030 call gmprot (nompro, norenu//'.MPHOMARD' , rsmpac-20, rsmpac )
2031 call gmprot (nompro, norenu//'.ArHOMARD' , 1 , 20 )
2032 call gmprot (nompro, norenu//'.ArHOMARD' , rsarac-20, rsarac )
2033 call gmprot (nompro, norenu//'.TrHOMARD' , 1, 20 )
2034 call gmprot (nompro, norenu//'.TrHOMARD' , rstrac-20, rstrac )
2035 call gmprot (nompro, norenu//'.QuHOMARD' , 1, 20 )
2036 call gmprot (nompro, norenu//'.QuHOMARD' , rsquac-20, rsquac )
2037 call gmprot (nompro, norenu//'.TeHOMARD' , 1, 20 )
2038 call gmprot (nompro, norenu//'.TeHOMARD' , rsteac-20, rsteac )
2039 call gmprot (nompro, norenu//'.HeHOMARD' , 1, 20 )
2040 call gmprot (nompro, norenu//'.HeHOMARD' , rsheac-20, rsheac )
2041 call gmprot (nompro, nccono//'.NumeExte' , 1, 20 )
2042 call gmprot (nompro, nccono//'.NumeExte' , nbelem-20, nbelem )
2047 if ( codret.eq.0 ) then
2049 if ( rsteac.eq.0 .and. rsheac.eq.0 .and. rspyac.eq.0 ) then
2050 rseutc = rstrac + rsquac
2051 rsevca = nbtria + nbquad
2052 rsevto = rstrto + rsquto
2054 rseutc = rsteac + rsheac + rspyac
2055 rsevca = nbtetr + nbhexa + nbpyra
2056 rsevto = rsteto + rsheto + rspyto
2059 imem(adnbrn+6) = rseutc
2060 imem(adnbrn+7) = rsevca
2061 imem(adnbrn+8) = rsevto
2066 c 14. sauvegarde des informations generales, au sens
2067 c du module de calcul associe
2068 c attention : il faut faire des copies et non pas des attachements
2069 c car la structure generale de l'objet "maillage de
2070 c calcul" est detruite apres la phase de conversion.
2073 #ifdef _DEBUG_HOMARD_
2074 write (ulsort,90002) '14. sauvegarde ; codret', codret
2075 if ( codret.eq.0 ) then
2076 write (ulsort,*) 'Avant copie de ncinfo'
2077 call gmprsx (nompro,ncinfo)
2078 call gmprsx (nompro,ncinfo//'.Pointeur')
2079 call gmprsx (nompro,ncinfo//'.Taille')
2080 call gmprsx (nompro,ncinfo//'.Table')
2085 c 14.1. ==> a-t-on defini des informations generales en externe ?
2086 c 14.1.1. ==> branche principale
2088 if ( codret.eq.0 ) then
2090 call gmobal ( ncinfo, codret )
2092 if ( codret.eq.0 ) then
2094 elseif ( codret.eq.1 ) then
2103 c 14.1.2. ==> verification de l'existence des differentes branches
2105 do 141 , iaux = 1 , 3
2107 if ( codret.eq.0 ) then
2112 if ( iaux.eq.1 ) then
2113 saux09 = '.Pointeur'
2114 elseif ( iaux.eq.1 ) then
2119 call gmobal ( ncinfo//saux09, codret )
2120 if ( codret.eq.0 ) then
2122 elseif ( codret.eq.2 ) then
2134 c 14.2. ==> copie des differentes branches et des attributs
2135 #ifdef _DEBUG_HOMARD_
2136 write (ulsort,90002) '14.2. Copie ; codret', codret
2139 if ( codret.eq.0 ) then
2143 call gmliat ( ncinfo, 1, iaux , codre1 )
2144 call gmliat ( ncinfo, 2, jaux, codre2 )
2146 codre0 = min ( codre1, codre2 )
2147 codret = max ( abs(codre0), codret,
2150 if ( codret.eq.0 ) then
2152 call gmecat ( nhsupe, 7, iaux, codre1 )
2153 call gmecat ( nhsupe, 8, iaux, codre2 )
2154 call gmecat ( nhsups, 3, jaux, codre3 )
2156 codre0 = min ( codre1, codre2, codre3 )
2157 codret = max ( abs(codre0), codret,
2158 > codre1, codre2, codre3 )
2162 if ( codret.eq.0 ) then
2164 call gmcpoj ( ncinfo//'.Pointeur', nhsupe//'.Tab7', codre1 )
2165 call gmcpoj ( ncinfo//'.Taille', nhsupe//'.Tab8', codre2 )
2166 call gmcpoj ( ncinfo//'.Table', nhsups//'.Tab3', codre3 )
2168 codre0 = min ( codre1, codre2, codre3 )
2169 codret = max ( abs(codre0), codret,
2170 > codre1, codre2, codre3 )
2174 if ( codret.eq.0 ) then
2176 call gmadoj ( ncinfo//'.Table', pinftb, jaux, codre1 )
2177 call gmliat ( ncinfo, 1, iaux, codre2 )
2180 codre0 = min ( codre1, codre2 )
2181 codret = max ( abs(codre0), codret,
2186 if ( codret.eq.0 ) then
2188 do 142 , iaux = 1, nbpqt
2190 jaux = pinftb + 10*(iaux-1)
2191 cgn write (ulsort,90064) jaux, '%'//smem(jaux)//'%'
2193 if ( ( smem(jaux).ne.'NomCo ' ) .and.
2194 > ( smem(jaux).ne.'UniteCo ' ) .and.
2195 > ( smem(jaux).ne.'NOMAMD ' ) .and.
2196 > ( smem(jaux).ne.'SATURNE ' ) ) then
2198 kaux = min(80,len(titre))
2199 cgn write (ulsort,90002) 'longueur', kaux
2200 call uts8ch ( smem(jaux), kaux, titre,
2201 > ulsort, langue, codret )
2202 cgn write (ulsort,*) 'recuperation de titre =', titre
2215 c 15. transfert des elements ignores
2218 #ifdef _DEBUG_HOMARD_
2219 write (ulsort,90002) '15. elements ignores ; codret', codret
2220 write (ulsort,90002) 'nbelig', nbelig
2224 if ( nbelig.ne.0 ) then
2226 if ( codret.eq.0 ) then
2228 call gmecat ( nhelig, 1, nbelig, codre0 )
2230 codret = max ( abs(codre0), codret )
2234 if ( codret.eq.0 ) then
2236 if ( degre.eq.1 ) then
2241 call gmaloj ( nhelig//'.ConnNoeu', ' ', iaux , hnoeel, codre1 )
2242 call gmaloj ( nhelig//'.FamilMED', ' ', nbelig, hfmdel, codre2 )
2244 codre0 = min ( codre1, codre2 )
2245 codret = max ( abs(codre0), codret,
2250 if ( codret.eq.0 ) then
2252 #ifdef _DEBUG_HOMARD_
2253 write (ulsort,texte(langue,3)) 'VCMAIG', nompro
2256 > ( imem(hfmdel), imem(hnoeel),
2257 > imem(ptypel), imem(pfamee), imem(pnoeel),
2259 > ulsort, langue, codret )
2262 cgn call gmprsx (nompro, nhelig )
2263 cgn call gmprsx (nompro, nhelig//'.ConnNoeu' )
2264 cgn call gmprsx (nompro, nhelig//'.FamilMED' )
2272 #ifdef _DEBUG_HOMARD_
2273 write (ulsort,90002) '16. fin ; codret', codret
2276 if ( codret.ne.0 ) then
2280 write (ulsort,texte(langue,1)) 'Sortie', nompro
2281 write (ulsort,texte(langue,2)) codret
2285 #ifdef _DEBUG_HOMARD_
2286 write (ulsort,texte(langue,1)) 'Sortie', nompro