1 subroutine pcmar0 ( nonexm,
2 > hetare, filare, merare,
3 > famare, posifa, facare,
4 > aretri, hettri, nivtri,
5 > famtri, pertri, filtri,
6 > arequa, hetqua, nivqua,
7 > famqua, perqua, filqua,
13 > nbanci, nbenrc, numead,
14 > arreca, trreca, qureca,
15 > nparrc, nptrrc, npqurc,
16 > npterc, npherc, npperc, nppyrc,
17 > arerec, trirec, quarec,
18 > tetrec, hexrec, penrec, pyrrec,
19 > ulsort, langue, codret )
20 c ______________________________________________________________________
24 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
26 c Version originale enregistree le 18 juin 1996 sous le numero 96036
27 c aupres des huissiers de justice Simart et Lavoir a Clamart
28 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
29 c aupres des huissiers de justice
30 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
32 c HOMARD est une marque deposee d'Electricite de France
38 c ______________________________________________________________________
40 c aPres adaptation - Conversion de MAillage - Recollements - phase 0
42 c Reperage des faces de raccordement non conforme
43 c ______________________________________________________________________
45 c . nom . e/s . taille . description .
46 c .____________________________________________________________________.
47 c . nonexm . e . 1 . non exportation de mailles .
48 c . . . . 1 : on exporte toutes les mailles .
49 c . . . . 2x : les segments ne sont pas exportes .
50 c . hetare . e . nbarto . historique de l'etat des aretes .
51 c . filare . e . nbarto . fille ainee de chaque arete .
52 c . merare . e . nbarto . mere de chaque arete .
53 c . famare . es . nbarto . famille des aretes .
54 c . posifa . e .0:nbarto. pointeur sur tableau facare .
55 c . facare . e . nbfaar . liste des faces contenant une arete .
56 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
57 c . hettri . e . nbtrto . historique de l'etat des triangles .
58 c . nivtri . e . nbtrto . niveau des triangles .
59 c . famtri . es . nbtrto . famille des triangles .
60 c . pertri . e . nbtrto . pere des triangles .
61 c . filtri . e . nbtrto . fils des triangles .
62 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
63 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
64 c . nivqua . e . nbquto . niveau des quadrangles .
65 c . famqua . es . nbquto . famille des quadrangles .
66 c . perqua . e . nbquto . pere des quadrangles .
67 c . filqua . e . nbquto . fils des quadrangles .
68 c . hettet . e . nbteto . historique de l'etat des tetraedres .
69 c . hethex . e . nbheto . historique de l'etat des hexaedres .
70 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
71 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
72 c . . . . voltri(i,k) definit le i-eme voisin de k .
73 c . . . . 0 : pas de voisin .
74 c . . . . j>0 : tetraedre j .
75 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
76 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
77 c . . . . du triangle k tel que voltri(1/2,k) = -j .
78 c . . . . pypetr(2,j) = numero du pentaedre voisin .
79 c . . . . du triangle k tel que voltri(1/2,k) = -j .
80 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
81 c . . . . volqua(i,k) definit le i-eme voisin de k .
82 c . . . . 0 : pas de voisin .
83 c . . . . j>0 : hexaedre j .
84 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
85 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
86 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
87 c . . . . pypequ(2,j) = numero du pentaedre voisin .
88 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
89 c . nbanci . e . 1 . nombre de non conformites initiales .
90 c . nbenrc . e . 1 . nombre d'entites par recollement unitaire .
91 c . numead . e . 1 . numero de la mere adoptive .
92 c . arreca . e .2*nbanci. liste des aretes recouvrant une autre .
93 c . nparrc . s . 1 . nombre de paires d'aretes a recoller .
94 c . nptrrc . s . 1 . nombre de paires de triangles a recoller .
95 c . npqurc . s . 1 . nombre de paires de quadrangles a recoller .
96 c . npterc . s . 1 . nombre de paires de tetraedres recolles .
97 c . npherc . s . 1 . nombre de paires d'hexaedres recolles .
98 c . npperc . s . 1 . nombre de paires de pentaedres recolles .
99 c . nppyrc . s . 1 . nombre de paires de pyramides recollees .
100 c . arerec . s . 2*x . paires des aretes a recoller .
101 c . trirec . s . 2*x . paires des triangles a recoller .
102 c . quarec . s . 2*x . paires des quadrangles a recoller .
103 c . tetrec . s . 3*x . paires des tetra. voisins faces a recoller .
104 c . hexrec . s . 3*x . paires des hexa. voisins faces a recoller .
105 c . penrec . s . 3*x . paires des penta. voisins faces a recoller .
106 c . pyrrec . s . 3*x . paires des pyram. voisines faces a recoller.
107 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
108 c . langue . e . 1 . langue des messages .
109 c . . . . 1 : francais, 2 : anglais .
110 c . codret . es . 1 . code de retour des modules .
111 c . . . . 0 : pas de probleme .
112 c . . . . 1 : probleme .
113 c ______________________________________________________________________
116 c 0. declarations et dimensionnement
119 c 0.1. ==> generalites
125 parameter ( nompro = 'PCMAR0' )
146 integer hetare(nbarto), filare(nbarto), merare(nbarto)
147 integer famare(nbarto)
148 integer posifa(0:nbarto), facare(nbfaar)
149 integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto)
150 integer famtri(nbtrto), pertri(nbtrto), filtri(nbtrto)
151 integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto)
152 integer famqua(nbquto), perqua(nbquto),filqua(nbquto)
153 integer hettet(nbteto)
154 integer hethex(nbheto)
155 integer hetpyr(nbpyto)
156 integer voltri(2,nbtrto), pypetr(2,*)
157 integer volqua(2,nbquto), pypequ(2,*)
158 integer nbanci, nbenrc, numead
159 integer arreca(nbenrc*nbanci)
160 integer nparrc, nptrrc, npqurc
161 integer npterc, npherc, npperc, nppyrc
162 integer trreca(nbtrri)
163 integer qureca(nbquri)
164 integer arerec(2,*), trirec(2,*), quarec(2,*)
165 integer tetrec(3,*), hexrec(3,*), penrec(3,*), pyrrec(3,*)
167 integer ulsort, langue, codret
169 c 0.4. ==> variables locales
174 parameter ( nbmess = 30 )
175 character*80 texte(nblang,nbmess)
177 c 0.5. ==> initialisations
178 c ______________________________________________________________________
186 #ifdef _DEBUG_HOMARD_
187 write (ulsort,texte(langue,1)) 'Entree', nompro
191 texte(1,4) = '(''On ne devrait pas passer dans '',a)'
192 texte(1,5) = '(''Examen du '',a,''numero '',i10)'
194 > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)'
196 > '(''.. Modification de la famille du '',a,''numero '',i10)'
198 > '(''.. Modification de l''''etat du '',a,''numero '',i10)'
199 texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)'
200 texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))'
201 texte(1,12) = '(''. de fils :'',2i10))'
202 texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)'
204 texte(2,4) = '(a,'' should not be called.'')'
205 texte(2,5) = '(''Examination of '',a,'',# '',i10)'
206 texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)'
208 > '(''.. Modification of the family of '',a,'',# '',i10)'
210 > '(''.. Modification of the state of '',a,'',# '',i10)'
211 texte(2,10) = '(5x,''==> old :'',i5,'', new :'',i5)'
212 texte(2,11) = '(''Number of non-conformal situations :'',i10))'
213 texte(2,12) = '(''. with sons :'',2i10))'
214 texte(2,13) = '(''. State for '',a,''# '',i10,'' :'',i10)'
232 if ( mod(nonexm,2).ne.0 ) then
234 if ( codret.eq.0 ) then
236 #ifdef _DEBUG_HOMARD_
237 write (ulsort,texte(langue,3)) 'PCMAR2', nompro
239 call pcmar2 ( hetare, filare, merare,
240 > famare, posifa, facare,
241 > aretri, hettri, nivtri,
243 > arequa, hetqua, nivqua,
247 > ulsort, langue, codret )
256 #ifdef _DEBUG_HOMARD_
257 write (ulsort,90002) '3. Les triangles ; codret', codret
260 if ( nbtrto.ne.0 ) then
262 if ( codret.eq.0 ) then
265 #ifdef _DEBUG_HOMARD_
266 write (ulsort,texte(langue,3)) 'PCMAR3_tr', nompro
268 call pcmar3 ( iaux, numead,
269 > nbtrto, nbteto, nbftri,
271 > famtri, pertri, filtri,
276 > npterc, tetrec, npperc, penrec, nppyrc, pyrrec,
277 > ulsort, langue, codret )
286 #ifdef _DEBUG_HOMARD_
287 write (ulsort,90002) '4. Les quadrangles ; codret', codret
290 if ( nbquto.ne.0 ) then
292 if ( codret.eq.0 ) then
295 #ifdef _DEBUG_HOMARD_
296 write (ulsort,texte(langue,3)) 'PCMAR3_qu', nompro
298 call pcmar3 ( iaux, numead,
299 > nbquto, nbheto, nbfqua,
301 > famqua, perqua, filqua,
306 > npherc, hexrec, npperc, penrec, nppyrc, pyrrec,
307 > ulsort, langue, codret )
316 #ifdef _DEBUG_HOMARD_
318 if ( codret.eq.0 ) then
320 if ( mod(nonexm,2).ne.0 ) then
321 write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc
323 write (ulsort,texte(langue,6)) mess14(langue,3,2), nptrrc
324 write (ulsort,texte(langue,6)) mess14(langue,3,4), npqurc
335 cgn write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux
336 cgn write (ulsort,*) 'etat = ',hettri(iaux),
337 cgn > ', famille = ',famtri(iaux)
339 cgn write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux
340 cgn write (ulsort,*) 'etat = ',hettri(iaux),
341 cgn > ', famille = ',famtri(iaux)
342 #ifdef _DEBUG_HOMARD_
343 write (ulsort,*) '6. la fin ; codret = ', codret
346 if ( codret.ne.0 ) then
350 write (ulsort,texte(langue,1)) 'Sortie', nompro
351 write (ulsort,texte(langue,2)) codret
355 #ifdef _DEBUG_HOMARD_
356 write (ulsort,texte(langue,1)) 'Sortie', nompro