1 subroutine deisv6 ( laface, typfac, lamail, typenh,
5 > hethex, filhex, perhex, fhpyte,
12 > ulsort, langue, codret )
13 c ______________________________________________________________________
17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
20 c aupres des huissiers de justice Simart et Lavoir a Clamart
21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
22 c aupres des huissiers de justice
23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
25 c HOMARD est une marque deposee d'Electricite de France
31 c ______________________________________________________________________
33 c traitement des DEcisions - Initialisations - par Saut - Volumes - 6
35 c Recherche des voisins d'une maille decrite par ses faces
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . laface . e . 1 . la face en cours d'examen .
41 c . typfac . e . 1 . type de la face .
42 c . . . . 2 : triangles .
43 c . . . . 4 : quadrangles .
44 c . lamail . e . 1 . la maille en cours d'examen .
45 c . typenh . e . 1 . type de la maille .
46 c . . . . 3 : tetraedres .
47 c . . . . 5 : pyramides .
48 c . . . . 6 : hexaedres .
49 c . . . . 7 : pentaedres .
50 c . hettri . e . nbtrto . historique de l'etat des triangles .
51 c . pertri . e . nbtrto . pere des triangles .
52 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
53 c . perqua . e . nbquto . pere des quadrangles .
54 c . pertet . e . nbteto . pere des tetraedres .
55 c . . . . si pertet(i) > 0 : numero du tetraedre .
56 c . . . . si pertet(i) < 0 : -numero dans pthepe .
57 c . hethex . e . nbheto . historique de l'etat des hexaedres .
58 c . filhex . e . nbheto . premier fils des hexaedres .
59 c . perhex . e . nbheto . pere des hexaedres .
60 c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide .
61 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
62 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
63 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
64 c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle .
65 c . . . . voltri(i,k) definit le i-eme voisin de k .
66 c . . . . 0 : pas de voisin .
67 c . . . . j>0 : tetraedre j .
68 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
69 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
70 c . . . . du triangle k tel que voltri(1/2,k) = -j .
71 c . . . . pypetr(2,j) = numero du pentaedre voisin .
72 c . . . . du triangle k tel que voltri(1/2,k) = -j .
73 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
74 c . . . . volqua(i,k) definit le i-eme voisin de k .
75 c . . . . 0 : pas de voisin .
76 c . . . . j>0 : hexaedre j .
77 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
78 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
79 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
80 c . . . . pypequ(2,j) = numero du pentaedre voisin .
81 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
82 c . nbvote . es . 1 . nombre de voisins de type tetraedre .
83 c . voiste . es . nbvote . les voisins de type tetraedre .
84 c . nbvohe . es . 1 . nombre de voisins de type hexaedre .
85 c . voishe . es . nbvohe . les voisins de type hexaedre .
86 c . nbvopy . es . 1 . nombre de voisins de type pyramide .
87 c . voispy . es . nbvopy . les voisins de type pyramide .
88 c . nbvope . es . 1 . nombre de voisins de type pentaedre .
89 c . voispe . es . nbvope . les voisins de type pentaedre .
90 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
91 c . langue . e . 1 . langue des messages .
92 c . . . . 1 : francais, 2 : anglais .
93 c . codret . es . 1 . code de retour des modules .
94 c . . . . 0 : pas de probleme .
95 c . . . . 2 : probleme dans le traitement .
96 c ______________________________________________________________________
99 c 0. declarations et dimensionnement
102 c 0.1. ==> generalites
108 parameter ( nompro = 'DEISV6' )
125 integer laface, typfac
126 integer lamail, typenh
127 integer hettri(nbtrto), pertri(nbtrto)
128 integer hetqua(nbquto), perqua(nbquto)
129 integer pertet(nbteto)
130 integer hethex(nbheto), filhex(nbheto), perhex(nbheto)
131 integer fhpyte(2,nbheco)
132 integer voltri(2,nbtrto), pypetr(2,*)
133 integer volqua(2,nbquto), pypequ(2,*)
135 integer nbvote, voiste(*)
136 integer nbvohe, voishe(*)
137 integer nbvopy, voispy(*)
138 integer nbvope, voispe(*)
140 integer ulsort, langue, codret
142 c 0.4. ==> variables locales
144 integer iaux, jaux, kaux, laux
145 integer etat, bindec, lamere, lepere, levois
146 integer nbfipy, filspy
147 integer nbfite, filste
148 integer nbfihe, filshe
151 parameter (nbmess = 10 )
152 character*80 texte(nblang,nbmess)
153 c ______________________________________________________________________
159 c 1.1. ==> Les messages
164 #ifdef _DEBUG_HOMARD_
165 write (ulsort,texte(langue,1)) 'Entree', nompro
169 texte(1,4) = '(''. Voisins de la maille'',i10,'' ('',a,'')'')'
172 > '(''. Neighbourgs of the mesh #'',i10,'' ('',a,'')'')'
176 #ifdef _DEBUG_HOMARD_
177 write (ulsort,texte(langue,4)) lamail, mess14(langue,1,typenh)
181 c 2. On parcourt tous les voisins de la face
183 #ifdef _DEBUG_HOMARD_
184 write (ulsort,*) '2. parcours voisins face ; codret = ', codret
187 c 2.1. ==> L'etat de la face
189 if ( typfac.eq.2 ) then
190 etat = mod(hettri(laface),10)
192 etat = mod(hetqua(laface),100)
194 cgn write (ulsort,90002) '.. etat', etat
196 c 2.2. ==> traitement pour une face non coupee
198 if ( etat.eq.0 ) then
200 do 221 , iaux = 1 , 2
201 cgn write (ulsort,90002) '.... voisin de rang', iaux
203 c 2.2.1. ==> Cas de la face triangulaire
205 if ( typfac.eq.2 ) then
207 jaux = voltri(iaux,laface)
209 c 2.2.1.1. ==> Il existe un voisin tetraedre
210 if ( jaux.gt.0 ) then
212 voiste(nbvote) = jaux
213 c 2.2.1.2. ==> Il existe un voisin pyramide ou pentaedre
214 elseif ( jaux.lt.0 ) then
216 if ( pypetr(1,jaux).ne.0 ) then
218 voispy(nbvopy) = pypetr(1,jaux)
220 if ( pypetr(2,jaux).ne.0 ) then
222 voispe(nbvope) = pypetr(2,jaux)
224 c 2.2.1.3. ==> Il n'existe pas de voisin
226 lamere = pertri(laface)
227 if ( lamere.gt.0 ) then
228 if ( voltri(2,lamere).ne.0 ) then
229 do 2211 , kaux = 1 , 2
230 levois = voltri(kaux,lamere)
231 if ( levois.ne.pertet(lamail) ) then
233 write(ulsort,*) 'A PROGRAMMER quand on aura'
234 write(ulsort,*) 'la conformite des pentaedres'
240 elseif ( lamere.lt.0 ) then
241 if ( volqua(2,-lamere).ne.0 ) then
242 do 2212 , kaux = 1 , 2
243 levois = volqua(kaux,-lamere)
244 if ( levois.ne.pertet(lamail) ) then
246 write(ulsort,*) 'A PROGRAMMER quand on aura'
247 write(ulsort,*) 'la conformite des pentaedres'
256 c 2.2.2. ==> Cas de la face quadrangulaire
260 jaux = volqua(iaux,laface)
261 cgn write (ulsort,90002) '.... jaux', jaux
262 c 2.2.2.1. ==> Il existe un voisin hexaedre
263 if ( jaux.gt.0 ) then
265 voishe(nbvohe) = jaux
266 c 2.2.2.2. ==> Il existe un voisin pyramide ou pentaedre
267 elseif ( jaux.lt.0 ) then
269 if ( pypequ(1,jaux).ne.0 ) then
271 voispy(nbvopy) = pypequ(1,jaux)
273 if ( pypequ(2,jaux).ne.0 ) then
275 voispe(nbvope) = pypequ(2,jaux)
277 c 2.2.2.3. ==> Il n'existe pas de voisin
278 c Soit c'est un bord et il n'y a rien a faire.
279 c Soit c'est que la maille du niveau precedent a ete
280 c coupee par conformite et les fils sont decrites par
281 c aretes : le voisinage n'est pas reconstitue. Dans ce
282 c cas, on stocke tous les fils.
283 c Remarque : la face mere ne peut avoir 2 voisins que
284 c dans le cas d'hexaedres voisins. A completer quand
285 c on aura programme le raffinement conforme complet
288 lamere = perqua(laface)
289 cgn write (ulsort,90002) 'lamere', lamere
290 if ( lamere.gt.0 ) then
291 if ( volqua(2,lamere).ne.0 ) then
292 do 2221 , kaux = 1 , 2
293 if ( volqua(kaux,lamere).ne.perhex(lamail) ) then
295 lepere = volqua(kaux,lamere)
296 etat = mod(hethex(lepere),1000)
297 bindec = chbiet(etat)
298 nbfihe = chnhe(bindec)
299 nbfipy = chnpy(bindec)
300 nbfite = chnte(bindec)
301 filshe = filhex(lepere)
302 if ( nbfihe.gt.0 ) then
303 do 22211 , laux = 0 , nbfihe-1
305 voishe(nbvohe) = filshe + iaux
308 if ( nbfipy.gt.0 ) then
309 filspy = fhpyte(1,-filshe)
310 do 22212 , laux = 0 , nbfipy-1
312 voispy(nbvopy) = filspy + iaux
315 if ( nbfite.gt.0 ) then
316 filste = fhpyte(2,-filshe)
317 do 22213 , laux = 0 , nbfite-1
319 voiste(nbvote) = filste + iaux
339 if ( codret.ne.0 ) then
343 write (ulsort,texte(langue,1)) 'Sortie', nompro
344 write (ulsort,texte(langue,2)) codret
348 #ifdef _DEBUG_HOMARD_
349 write (ulsort,texte(langue,1)) 'Sortie', nompro