1 subroutine decfs2 ( disnoe, ancnoe, nounoe,
2 > hetnoe, famnoe, arenoe,
6 > hetqua, arequa, filqua,
7 > tritet, cotrte, aretet,
8 > hethex, filhex, fhpyte,
9 > facpyr, cofapy, arepyr,
10 > hetpen, filpen, fppyte,
11 > typind, iindno, rindno,
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 - mise en ConFormite - Suppression - 2
35 c Renumerotation des tableaux lies aux noeuds
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . disnoe . aux . nancno . indicateurs de disparition des noeuds .
41 c . ancnoe . s . nbnoto . anciens numeros des noeuds conserves .
42 c . nounoe . s .0:nbnoto. nouveaux numeros des noeuds conserves .
43 c . hetnoe . e/s . nbnoto . historique de l'etat des noeuds .
44 c . np2are . e . nancar . numero des noeuds p2 milieux d'aretes .
45 c . somare . e .2*nancar. numeros des extremites d'arete .
46 c . aretri . e .nanctr*3. numeros des 3 aretes des triangles .
47 c . hetqua . e . nancqu . historique de l'etat des quadrangles .
48 c . arequa . e .nancqu*3. numeros des 4 aretes des quadrangles .
49 c . filqua . e . nancqu . premier fils des quadrangles .
50 c . tritet . e .nancte*4. numeros des triangles des tetraedres .
51 c . cotrte . e .nancte*4. codes des triangles des tetraedres .
52 c . aretet . e .nancta*6. numeros des 6 aretes des tetraedres .
53 c . hethex . e . nanche . historique de l'etat des hexaedres .
54 c . filhex . e . nanche . premier fils des hexaedres .
55 c . fhpyte . e . 2** . fhpyte(1,j) = numero de la 1ere pyramide .
56 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
57 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
58 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
59 c . facpyr . e .nancyf*5. numeros des 5 faces des pyramides .
60 c . cofapy . e .nancyf*5. codes des faces des pyramides .
61 c . arepyr . e .nancya*8. numeros des 8 aretes des pyramides .
62 c . hetpen . e . nancpe . historique de l'etat des pentaedres .
63 c . filpen . e . nancpe . premier fils des pentaedres .
64 c . fppyte . e . 2** . fppyte(1,j) = numero de la 1ere pyramide .
65 c . . . . fille du pentaedre k tel que filpen(k) =-j .
66 c . . . . fppyte(2,j) = numero du 1er tetraedre .
67 c . . . . fils du pentaedre k tel que filpen(k) = -j .
68 c . typind . e . 1 . type de valeurs pour l'indicateur .
69 c . . . . 0 : aucune .
70 c . . . . 2 : entieres .
71 c . . . . 3 : reelles .
72 c . iindno . e . * . indicateur entier sur les noeuds .
73 c . rindno . e . * . indicateur reel sur les noeuds .
74 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
75 c . langue . e . 1 . langue des messages .
76 c . . . . 1 : francais, 2 : anglais .
77 c . codret . es . 1 . code de retour des modules .
78 c . . . . 0 : pas de probleme .
79 c . . . . 5 : mauvais type de code de calcul associe .
80 c ______________________________________________________________________
83 c 0. declarations et dimensionnement
86 c 0.1. ==> generalites
92 parameter ( nompro = 'DECFS2' )
109 integer disnoe(nancno)
110 integer ancnoe(nbnoto), nounoe(0:nancno)
111 integer hetnoe(nancno), famnoe(nancno)
112 integer arenoe(nancno), noehom(nancno)
113 integer np2are(nancar), somare(2,nancar)
114 integer aretri(nanctr,3)
115 integer hetqua(nancqu), arequa(nancqu,4), filqua(nancqu)
116 integer tritet(nanctf,4), cotrte(nanctf,4), aretet(nancta,6)
117 integer hethex(nanche), filhex(nanche)
119 integer facpyr(nancyf,5), cofapy(nancyf,5), arepyr(nancya,8)
120 integer hetpen(nancpe), filpen(nancpe)
122 integer typind, iindno(*)
124 double precision coonoe(nancno,sdim)
125 double precision rindno(*)
127 integer ulsort, langue, codret
129 c 0.4. ==> variables locales
132 integer letetr, lapyra, lequad, larete, lenoeu
133 integer listar(8), listso(5)
134 integer nbnore, nbp2re, nbimre
140 parameter ( nbmess = 10 )
141 character*80 texte(nblang,nbmess)
143 c 0.5. ==> initialisations
144 c ______________________________________________________________________
152 #ifdef _DEBUG_HOMARD_
153 write (ulsort,texte(langue,1)) 'Entree', nompro
157 texte(1,4) = '(''Binaire du decoupage de conformite :'',i5)'
159 texte(2,4) = '(''Cut for conformity; binary code:'',i5)'
166 c 2. Reperage des noeuds a faire disparaitre
168 #ifdef _DEBUG_HOMARD_
169 write (ulsort,*) '2. Reperage ; codret = ', codret
171 cgn write (ulsort,90002) nompro//'nancno', nancno
173 c 2.1. ==> A priori, tout reste
175 if ( codret.eq.0 ) then
177 do 21 , iaux = 1 , nancno
184 c 2.2. ==> Les noeuds P2 sur les aretes de conformite
186 if ( codret.eq.0 ) then
188 do 22 , iaux = nbarpe+1 , nancar
189 #ifdef _DEBUG_HOMARD_
190 write (ulsort,90015) 'noeud sur l''arete', iaux, ':', np2are(iaux)
192 disnoe(np2are(iaux)) = 1
197 c 2.3. ==> Les noeuds centraux des quadrangles coupes en 3 quadrangles
198 c . Le noeud central est le second sommet de la derniere arete
199 c du fils aine (voir cmcdq5 pour les conventions)
201 if ( codret.eq.0 ) then
203 do 23 , iaux = 1 , nancqu
205 etat = mod(hetqua(iaux),100)
207 if ( ( etat.ge.41 .and. etat.le.44 ) ) then
209 #ifdef _DEBUG_HOMARD_
210 write (ulsort,90002) mess14(langue,2,4), iaux
211 write (ulsort,texte(langue,4)) etat
213 lequad = filqua(iaux)
214 #ifdef _DEBUG_HOMARD_
215 write (ulsort,90002) mess14(langue,2,4), lequad
218 lenoeu = somare(2,arequa(lequad,4))
219 #ifdef _DEBUG_HOMARD_
220 write (ulsort,90002) mess14(langue,2,-1), lenoeu
230 c 2.4. ==> Les noeuds centraux des hexaedres coupes
231 c Selon l'etat, il y a ou non un sommet interne
232 c . le noeud central est le sommet S1 de chacun des tetraedres
233 c . le noeud central est le sommet S5 de chacune des pyramides
235 if ( codret.eq.0 ) then
237 do 24 , iaux = 1 , nanche
239 etat = mod(hethex(iaux),1000)
241 if ( etat.gt.10 ) then
243 bindec = chbiet(etat)
244 if ( chnp1(bindec).gt.0 ) then
246 #ifdef _DEBUG_HOMARD_
247 write (ulsort,90002) mess14(langue,2,6), iaux
248 write (ulsort,texte(langue,4)) bindec
252 c 2.4.1. ==> Au moins un tetraedre fils
254 if ( chnte(bindec).gt.0 ) then
256 letetr = fhpyte(2,-jaux)
257 #ifdef _DEBUG_HOMARD_
258 write (ulsort,90002) mess14(langue,2,3), letetr
261 call utaste ( letetr,
262 > nanctr, nanctf, nancta,
264 > tritet, cotrte, aretet,
268 #ifdef _DEBUG_HOMARD_
269 write (ulsort,90002) mess14(langue,2,-1), lenoeu
273 c 2.4.2. ==> Au moins une pyramide fille
275 elseif ( chnpy(bindec).gt.0 ) then
277 lapyra = fhpyte(1,-jaux)
278 #ifdef _DEBUG_HOMARD_
279 write (ulsort,90002) mess14(langue,2,6), lapyra
282 call utaspy ( lapyra,
283 > nanctr, nancyf, nancya,
285 > facpyr, cofapy, arepyr,
289 #ifdef _DEBUG_HOMARD_
290 write (ulsort,90002) mess14(langue,2,-1), lenoeu
304 c 2.5. ==> Les noeuds centraux des pentaedres coupes selon
306 c . Decoupage selon 2 aretes de triangle : le noeud central est
307 c le sommet S1 de chacun des 10 tetraedres
308 c . Decoupage selon 1 face de triangle : le noeud central est
309 c le sommet S1 du 10eme tetraedre
311 if ( codret.eq.0 ) then
313 do 25 , iaux = 1 , nancpe
315 etat = mod(hetpen(iaux),100)
317 if ( ( etat.ge.31 .and. etat.le.36 ) .or.
318 > ( etat.ge.51 .and. etat.le.52 ) ) then
320 #ifdef _DEBUG_HOMARD_
321 write (ulsort,90002) mess14(langue,2,7), iaux
322 write (ulsort,texte(langue,4)) etat
325 letetr = fppyte(2,-jaux) + 9
326 #ifdef _DEBUG_HOMARD_
327 write (ulsort,90002) mess14(langue,2,3), letetr
330 call utaste ( letetr,
331 > nanctr, nanctf, nancta,
333 > tritet, cotrte, aretet,
337 #ifdef _DEBUG_HOMARD_
338 write (ulsort,90002) mess14(langue,2,-1), lenoeu
349 c 3. Suppression des noeuds
351 #ifdef _DEBUG_HOMARD_
352 write (ulsort,*) '3. Suppression des noeuds ; codret = ', codret
355 if ( codret.eq.0 ) then
357 #ifdef _DEBUG_HOMARD_
358 write (ulsort,texte(langue,3)) 'UTSUNO', nompro
360 call utsuno ( nancno, nbnoto, disnoe,
361 > hetnoe, ancnoe, nounoe,
362 > nbnore, nbp2re, nbimre )
367 c 4. Compactage de la numerotation
368 c Remarque : c'est un melange de utcnno et utcnar
369 c sachant qu'ici les aretes ne changent pas de numero
371 #ifdef _DEBUG_HOMARD_
372 write (ulsort,*) '4. Compactage ; codret = ', codret
375 if ( codret.eq.0 ) then
377 c 4.1. ==> Les tableaux du maillage
379 do 41 , lenoeu = 1 , nbnore
381 if ( ancnoe(lenoeu).ne.lenoeu ) then
382 do 410, iaux = 1 , sdim
383 coonoe(lenoeu,iaux) = coonoe(ancnoe(lenoeu),iaux)
385 hetnoe(lenoeu) = hetnoe(ancnoe(lenoeu))
386 famnoe(lenoeu) = famnoe(ancnoe(lenoeu))
387 arenoe(lenoeu) = arenoe(ancnoe(lenoeu))
392 c 4.2. ==> Les eventuels noeuds homologues
394 if ( homolo.ge.1 ) then
396 do 42 , lenoeu = 1 , nbnore
397 if ( noehom(ancnoe(lenoeu)).ge.0 ) then
398 noehom(lenoeu) = nounoe(noehom(ancnoe(lenoeu)))
400 noehom(lenoeu) = - nounoe(abs(noehom(ancnoe(lenoeu))))
406 c 4.3. ==> La description des aretes
408 do 43 , larete = 1 , nancar
410 somare(1,larete) = nounoe(somare(1,larete))
411 somare(2,larete) = nounoe(somare(2,larete))
412 np2are(larete) = nounoe(np2are(larete))
416 c 4.4. ==> Les eventuels indicateurs d'erreur
418 if ( typind.eq.2 ) then
420 do 441 , lenoeu = 1 , nbnore
421 if ( ancnoe(lenoeu).ne.lenoeu ) then
422 iindno(lenoeu) = iindno(ancnoe(lenoeu))
426 elseif ( typind.eq.3 ) then
428 do 442 , lenoeu = 1 , nbnore
429 if ( ancnoe(lenoeu).ne.lenoeu ) then
430 rindno(lenoeu) = rindno(ancnoe(lenoeu))
442 if ( codret.ne.0 ) then
446 write (ulsort,texte(langue,1)) 'Sortie', nompro
447 write (ulsort,texte(langue,2)) codret
451 #ifdef _DEBUG_HOMARD_
452 write (ulsort,texte(langue,1)) 'Sortie', nompro