1 subroutine vcmnco ( nohman,
2 > nhnoeu, nharet, nhtria, nhquad, nhvois,
4 > coonoe, hetnoe, arenoe,
5 > coexno, nnosho, nnosca,
6 > somare, hetare, np2are,
7 > merare, filare, insoar,
8 > coexar, narsho, narsca,
9 > hettri, aretri, filtri, pertri,
10 > hetqua, arequa, filqua, perqua,
11 > coexqu, nqusho, nqusca,
13 > ulsort, langue, codret )
14 c ______________________________________________________________________
18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
21 c aupres des huissiers de justice Simart et Lavoir a Clamart
22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
23 c aupres des huissiers de justice
24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
26 c HOMARD est une marque deposee d'Electricite de France
32 c ______________________________________________________________________
34 c aVant adaptation - Conversion de Maillage - Non COnformite
36 c ATTENTION : cela suppose que le rapport de non conformite est 1/2
37 c ______________________________________________________________________
39 c . nom . e/s . taille . description .
40 c .____________________________________________________________________.
41 c . nohman . e . char*8 . nom de l'objet maillage homard iteration n .
42 c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds .
43 c . nharet . e . char8 . nom de l'objet decrivant les aretes .
44 c . nhtria . e . char8 . nom de l'objet decrivant les triangles .
45 c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles .
46 c . nhvois . e . char8 . nom de la branche Voisins .
47 c . noempo . es . nbmpto . numeros des noeuds associes aux mailles .
48 c . coonoe . e . nbnoto . coordonnees des noeuds .
50 c . hetnoe . es . nbnoto . historique de l'etat des noeuds .
51 c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour.
52 c . . . . un noeud milieu .
53 c . coexno . es . nbnoto*. codes de conditions aux limites portants .
54 c . . . nctfno . sur les noeuds .
55 c . nnosho . es . rsnoac . numero des noeuds dans HOMARD .
56 c . nnosca . es . rsnoto . numero des noeuds dans le calcul .
57 c . somare . es .2*nbarto. numeros des extremites d'arete .
58 c . hetare . es . nbarto . historique de l'etat des aretes .
59 c . np2are . es . nbarto . noeud milieux des aretes .
60 c . merare . es . nbarto . mere des aretes .
61 c . filare . es . nbarto . premiere fille des aretes .
62 c . insoar . es . nbarto . information sur les sommets des aretes .
63 c . coexar . es . nbarto*. codes de conditions aux limites portants .
64 c . . . nctfar . sur les aretes .
65 c . narsho . es . rsarac . numero des aretes dans HOMARD .
66 c . narsca . es . rsarto . numero des aretes du calcul .
67 c . hettri . e . nbtrto . historique de l'etat des triangles .
68 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
69 c . filtri . e . nbtrto . premier fils des triangles .
70 c . pertri . e . nbtrto . pere des triangles .
71 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
72 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
73 c . filqua . e . nbquto . premier fils des quadrangles .
74 c . perqua . e . nbquto . pere des quadrangles .
75 c . coexqu . es . nbquto*. codes de conditions aux limites portants .
76 c . . . nctfqu . sur les quadrangles .
77 c . nqusho . es . rsquac . numero des quadrangles dans HOMARD .
78 c . nqusca . es . rsquto . numero des quadrangles du calcul .
79 c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres .
80 c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres .
81 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
82 c . langue . e . 1 . langue des messages .
83 c . . . . 1 : francais, 2 : anglais .
84 c . codret . es . 1 . code de retour des modules .
85 c . . . . 0 : pas de probleme .
86 c . . . . 3 : probleme .
87 c ______________________________________________________________________
90 c 0. declarations et dimensionnement
93 c 0.1. ==> generalites
99 parameter ( nompro = 'VCMNCO' )
123 character*8 nohman, nhvois
124 character*8 nhnoeu, nharet, nhtria, nhquad
126 integer noempo(nbmpto)
127 integer hetnoe(nbnoto), arenoe(nbnoto)
128 integer coexno(nbnoto,nctfno)
129 integer nnosho(rsnoac), nnosca(rsnoto)
130 integer somare(2,nbarto), hetare(nbarto), np2are(nbarto)
131 integer filare(nbarto), merare(nbarto), insoar(nbarto)
132 integer coexar(nbarto,nctfar)
133 integer narsho(rsarac), narsca(rsarto)
134 integer hettri(nbtrto), aretri(nbtrto,3)
135 integer filtri(nbtrto), pertri(nbtrto)
136 integer hetqua(nbquto), arequa(nbquto,4)
137 integer filqua(nbquto), perqua(nbquto)
138 integer coexqu(nbquto,nctfqu)
139 integer nqusho(rsquac), nqusca(rsquto)
140 integer quahex(nbhecf,6), coquhe(nbhecf,6)
142 double precision coonoe(nbnoto,sdim)
144 integer ulsort, langue, codret
146 c 0.4. ==> variables locales
151 integer codre1, codre2, codre3, codre4
153 integer ppovos, pvoiso
154 integer pposif, pfacar
155 integer voarno, vofaar, vovoar, vovofa
156 integer nbanci, nbnoct, nbnocq
159 integer conoct, conocq
161 integer adnoer, adarra, adarrb
162 integer adtrra, adtrrb
163 integer adqura, adqurb
164 integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5
165 integer ptrav6, ptrav7, ptrav8
167 character*8 nharrc, nhtrrc, nhqurc
168 character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5
169 character*8 ntrav6, ntrav7, ntrav8
172 parameter ( nbmess = 10 )
173 character*80 texte(nblang,nbmess)
175 c 0.5. ==> initialisations
176 c ______________________________________________________________________
186 #ifdef _DEBUG_HOMARD_
187 write (ulsort,texte(langue,1)) 'Entree', nompro
192 > '(''Nombre de paires de '',a,'' non-conformes :'',i10))'
195 > '(''Number of pairs of non-conformal '',a,'' :'',i10))'
202 c 2.1. ==> Les structures des voisins
204 if ( codret.eq.0 ) then
210 #ifdef _DEBUG_HOMARD_
211 write (ulsort,texte(langue,3)) 'UTVOIS', nompro
213 call utvois ( nohman, nhvois,
214 > voarno, vofaar, vovoar, vovofa,
216 > nbfaar, pposif, pfacar,
217 > ulsort, langue, codret )
222 c 3. Decompte et reperage des non-conformites
224 c 3.1. ==> Tableau de travail
226 if ( codret.eq.0 ) then
228 call gmalot ( ntrav1, 'entier ', nbarto, ptrav1, codre0 )
229 codret = max ( abs(codre0), codret )
233 c 3.2. ==> Decompte et reperage des aretes en vis-a-vis
235 if ( codret.eq.0 ) then
237 #ifdef _DEBUG_HOMARD_
238 write (ulsort,texte(langue,3)) 'UTNC01', nompro
241 call utnc01 ( nbanci, nbgemx,
245 > imem(ppovos), imem(pvoiso),
247 > ulsort, langue, codret )
249 #ifdef _DEBUG_HOMARD_
250 write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci
255 #ifdef _DEBUG_HOMARD_
256 call gmprot (nompro,ntrav1,1,nbarto)
259 c 3.3. ==> Enregistrement
261 if ( codret.eq.0 ) then
263 if ( nbanci.gt.0 ) then
266 call gmecat ( nohman, 4, maconf, codret )
273 c 4. Gestion des tableaux
276 c 4.1. ==> Tableaux de travail
278 if ( nbanci.gt.0 ) then
280 if ( codret.eq.0 ) then
282 call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre1 )
283 iaux = max( nbarto+1,nbnoto+1)
284 call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre2 )
285 iaux = max(3*nbanci,nbnoto,2*nbarto,nbarto*nctfar)
286 call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre3 )
288 call gmalot ( ntrav6, 'reel ', iaux, ptrav6, codre4 )
290 codre0 = min ( codre1, codre2, codre3, codre4 )
291 codret = max ( abs(codre0), codret,
292 > codre1, codre2, codre3, codre4 )
296 c 4.2. ==> Allocation de la memorisation des noeuds de non-conformite
298 if ( codret.eq.0 ) then
300 call gmecat ( nhnoeu, 4, nbanci, codre1 )
301 call gmaloj ( nhnoeu//'.Recollem', ' ', nbanci, adnoer, codre2 )
303 codre0 = min ( codre1, codre2 )
304 codret = max ( abs(codre0), codret,
309 c 4.3. ==> Memorisation des non-conformites en aretes
311 if ( codret.eq.0 ) then
314 #ifdef _DEBUG_HOMARD_
315 write (ulsort,texte(langue,3)) 'VCMNC4_ar', nompro
317 call vcmnc4 ( iaux, nharet,
319 > ulsort, langue, codret )
323 if ( codret.eq.0 ) then
325 call gmecat ( nharrc, 1, nbanci, codre1 )
327 call gmecat ( nharrc, 2, iaux, codre2 )
329 call gmaloj ( nharrc//'.ListeA', ' ', iaux, adarra, codre3 )
330 call gmaloj ( nharrc//'.ListeB', ' ', iaux, adarrb, codre4 )
332 codre0 = min ( codre1, codre2, codre3, codre4 )
333 codret = max ( abs(codre0), codret,
334 > codre1, codre2, codre3, codre4 )
338 c 4.4. ==> Memorisation des non-conformites en triangles
340 if ( codret.eq.0 ) then
342 if ( nbtrto.ne.0 ) then
345 #ifdef _DEBUG_HOMARD_
346 write (ulsort,texte(langue,3)) 'VCMNC4_tr', nompro
348 call vcmnc4 ( iaux, nhtria,
350 > ulsort, langue, codret )
356 c 4.5. ==> Memorisation des non-conformites en quadrangles
358 if ( codret.eq.0 ) then
360 if ( nbquto.ne.0 ) then
363 #ifdef _DEBUG_HOMARD_
364 write (ulsort,texte(langue,3)) 'VCMNC4_qu', nompro
366 call vcmnc4 ( iaux, nhquad,
368 > ulsort, langue, codret )
377 c 5. Renumerotation des aretes
380 if ( codret.eq.0 ) then
382 if ( nbanci.gt.0 ) then
384 #ifdef _DEBUG_HOMARD_
385 write (ulsort,texte(langue,3)) 'VCMNC1', nompro
387 call vcmnc1 ( nbanci, nbgemx,
388 > imem(adarra), imem(adarrb),
391 > somare, hetare, np2are,
392 > merare, filare, insoar,
393 > coexar, narsho, narsca,
397 > imem(ptrav1), imem(ptrav4), imem(ptrav5),
398 > ulsort, langue, codret )
400 #ifdef _DEBUG_HOMARD_
401 call gmprsx (nompro, nharrc//'.ListeA' )
402 call gmprsx (nompro, nharrc//'.ListeB' )
403 cgn call gmprot (nompro,ntrav4,1,nbarto+1)
404 cgn call gmprot (nompro,ntrav5,1,3*nbanci)
413 c 6. Renumerotation des noeuds
416 if ( codret.eq.0 ) then
418 if ( nbanci.gt.0 ) then
420 #ifdef _DEBUG_HOMARD_
421 write (ulsort,texte(langue,3)) 'VCMNC2', nompro
423 call vcmnc2 ( nbanci, nbgemx,
424 > imem(adarra), imem(adarrb), imem(adnoer),
426 > coonoe, hetnoe, arenoe,
427 > coexno, nnosho, nnosca,
429 > somare, hetare, np2are,
430 > merare, filare, insoar,
431 > coexar, narsho, narsca,
435 > imem(ptrav1), imem(ptrav2),
436 > imem(ptrav4), imem(ptrav5),
438 > ulsort, langue, codret )
440 #ifdef _DEBUG_HOMARD_
441 call gmprot (nompro,ntrav4,1,nbnoto+1)
449 c 7. On repere chaque face du macro maillage qui est bordee par une
450 c arete de non conformite initiale. On declare que cette face a une
451 c mere, dont le numero est un numero fictif, ne correspondant a
452 c aucune face possible.
455 if ( codret.eq.0 ) then
457 if ( nbanci.gt.0 ) then
460 cgn write(ulsort,*) iaux,arequa(iaux,1),arequa(iaux,2),
461 cgn > arequa(iaux,3),arequa(iaux,4)
464 if ( codret.eq.0 ) then
466 #ifdef _DEBUG_HOMARD_
467 write (ulsort,texte(langue,3)) 'UTNC09', nompro
471 call utnc09 ( nbanci, imem(adarrb), iaux,
474 > imem(pposif), imem(pfacar),
475 > ulsort, langue, codret )
479 if ( codret.eq.0 ) then
481 if ( nbtrto.gt.0 ) then
483 call gmecat ( nhtrrc, 3, numead, codre0 )
484 codret = max ( abs(codre0), codret )
488 if ( nbquto.gt.0 ) then
490 call gmecat ( nhqurc, 3, numead, codre0 )
491 codret = max ( abs(codre0), codret )
503 c 8. Gestion des non-conformites sur les volumes
506 if ( codret.eq.0 ) then
508 if ( nbanci.gt.0 .and.
509 > ( nbheto.gt.0 .or. nbteto.gt.0 ) ) then
511 c 8.1. ==> Reperage des faces dont des aretes sont non-conformes :
512 c . les 4 aretes pour des quadrangles
513 c . les 3 aretes pour les triangles
514 c Les nombres nbnoct et nbnocq ne sont que des maxima : une
515 c face peut tres bien avoir ses aretes coupees sans etre
516 c decoupee elle-meme.
518 if ( codret.eq.0 ) then
520 #ifdef _DEBUG_HOMARD_
521 write (ulsort,texte(langue,3)) 'UTNC11', nompro
524 call utnc11 ( nbanci, imem(adarra),
527 > filare, imem(pposif), imem(pfacar),
529 > ulsort, langue, codret )
533 c 8.2. ==> Les tableaux
534 c 8.2.1. ==> Allocation de la memorisation des faces en vis-a-vis
535 c On est dans un rapport de 4 pour 1 toujours.
537 if ( codret.eq.0 ) then
539 if ( nbquto.ne.0 ) then
541 call gmecat ( nhqurc, 1, nbnocq, codre1 )
543 call gmecat ( nhqurc, 2, iaux, codre2 )
545 call gmaloj ( nhqurc//'.ListeA', ' ', nbquri, adqura, codre3 )
546 call gmaloj ( nhqurc//'.ListeB', ' ', nbquri, adqurb, codre4 )
548 codre0 = min ( codre1, codre2, codre3, codre4 )
549 codret = max ( abs(codre0), codret,
550 > codre1, codre2, codre3, codre4 )
554 if ( nbtrto.ne.0 ) then
556 call gmecat ( nhtrrc, 1, nbnoct, codre1 )
558 call gmecat ( nhtrrc, 2, iaux, codre2 )
560 call gmaloj ( nhtrrc//'.ListeA', ' ', nbtrri, adtrra, codre3 )
561 call gmaloj ( nhtrrc//'.ListeB', ' ', nbtrri, adtrrb, codre4 )
563 codre0 = min ( codre1, codre2, codre3, codre4 )
564 codret = max ( abs(codre0), codret,
565 > codre1, codre2, codre3, codre4 )
571 c 8.2.2. ==> Tableaux de travail
573 if ( codret.eq.0 ) then
575 iaux = nbquto + nbtrto + 1
576 call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre1 )
577 iaux = max( nbtrto+1,nbquto+1)
578 call gmalot ( ntrav7, 'entier ', iaux, ptrav7, codre2 )
580 > max(5*nbnocq,5*nbnoct,4*nbquto,nbquto*nctfqu,rsquac,rsquto,
582 call gmalot ( ntrav8, 'entier ', iaux, ptrav8, codre3 )
584 codre0 = min ( codre1, codre2, codre3 )
585 codret = max ( abs(codre0), codret,
586 > codre1, codre2, codre3 )
590 c 8.3. ==> Repérage des faces en vis-a-vis
592 if ( codret.eq.0 ) then
594 #ifdef _DEBUG_HOMARD_
595 write (ulsort,texte(langue,3)) 'UTNC12', nompro
598 call utnc12 ( hettri, aretri, filtri, pertri,
599 > hetqua, arequa, filqua, perqua,
600 > filare, imem(pposif), imem(pfacar),
601 > nbnocq, imem(adqura), imem(adqurb), conocq,
602 > nbnoct, imem(adtrra), imem(adtrrb), conoct,
603 > ulsort, langue, codret )
605 #ifdef _DEBUG_HOMARD_
606 call gmprsx (nompro, nhqurc )
607 call gmprot (nompro, nhqurc//'.ListeA', 1, 10 )
608 call gmprot (nompro, nhqurc//'.ListeA', 4*conocq, nbquri )
609 call gmprot (nompro, nhqurc//'.ListeB', 1, 10 )
610 call gmprot (nompro, nhqurc//'.ListeB', 4*conocq, nbquri )
615 c 8.4 ==> Redimensionnement des tableaux
616 #ifdef _DEBUG_HOMARD_
617 write (ulsort,*) 'debut de 8.4 avec codret = ', codret
620 if ( codret.eq.0 ) then
622 if ( nbquto.ne.0 ) then
627 call gmmod ( nhqurc//'.ListeA',
628 > adqura, nbquri, iaux, un, un, codre1 )
629 call gmmod ( nhqurc//'.ListeB',
630 > adqurb, nbquri, iaux, un, un, codre2 )
633 call gmecat ( nhqurc, 1, nbnocq, codre3 )
635 codre0 = min ( codre1, codre2, codre3 )
636 codret = max ( abs(codre0), codret,
637 > codre1, codre2, codre3 )
641 if ( nbtrto.ne.0 ) then
645 call gmmod ( nhtrrc//'.ListeA',
646 > adtrra, nbtrri, iaux, un, un, codre1 )
647 call gmmod ( nhtrrc//'.ListeB',
648 > adtrrb, nbtrri, iaux, un, un, codre2 )
651 call gmecat ( nhtrrc, 1, nbnoct, codre3 )
653 codre0 = min ( codre1, codre2, codre3 )
654 codret = max ( abs(codre0), codret,
655 > codre1, codre2, codre3 )
659 #ifdef _DEBUG_HOMARD_
660 call gmprsx (nompro, nhqurc )
661 call gmprsx (nompro, nhqurc//'.ListeA' )
662 call gmprsx (nompro, nhqurc//'.ListeB' )
667 c 8.5 ==> Renumérotation
669 if ( codret.eq.0 ) then
671 #ifdef _DEBUG_HOMARD_
672 write (ulsort,texte(langue,3)) 'VCMNC3', nompro
674 call vcmnc3 ( nbanci,
675 > nbnocq, imem(adqura), imem(adqurb),
676 > nbnoct, imem(adtrra), imem(adtrrb),
678 > coonoe, hetnoe, arenoe,
679 > coexno, nnosho, nnosca,
682 > hettri, aretri, filtri,
683 > hetqua, arequa, filqua, perqua,
684 > coexqu, nqusho, nqusca,
688 > imem(ptrav7), imem(ptrav8), rmem(ptrav6),
689 > ulsort, langue, codret )
700 #ifdef _DEBUG_HOMARD_
701 write (ulsort,*) 'debut de 9 avec codret = ', codret
704 if ( codret.eq.0 ) then
706 call gmlboj ( ntrav1, codre0 )
707 codret = max ( abs(codre0), codret )
711 if ( codret.eq.0 ) then
713 if ( nbanci.gt.0 ) then
715 if ( codret.eq.0 ) then
717 call gmlboj ( ntrav2, codre1 )
718 call gmlboj ( ntrav4, codre2 )
719 call gmlboj ( ntrav5, codre3 )
720 call gmlboj ( ntrav6, codre4 )
722 codre0 = min ( codre1, codre2, codre3, codre4 )
723 codret = max ( abs(codre0), codret,
724 > codre1, codre2, codre3, codre4 )
728 if ( nbheto.gt.0 .or. nbteto.gt.0 ) then
730 if ( codret.eq.0 ) then
732 call gmlboj ( ntrav7 , codre1 )
733 call gmlboj ( ntrav8 , codre2 )
735 codre0 = min ( codre1, codre2 )
736 codret = max ( abs(codre0), codret,
751 if ( codret.ne.0 ) then
755 write (ulsort,texte(langue,1)) 'Sortie', nompro
756 write (ulsort,texte(langue,2)) codret
760 #ifdef _DEBUG_HOMARD_
761 write (ulsort,texte(langue,1)) 'Sortie', nompro