1 subroutine cmdrqu ( arequa, decfac, hetqua, filqua, ninqua,
2 > disnoe, disare, distri, disqua,
4 > np2are, posifa, facare, somare,
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c Creation du Maillage - Deraffinement - Regroupement des QUadrangles
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles .
33 c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) .
35 c . hetqua . e . nouvqu . historique de l'etat des quadrangles .
36 c . filqua . e . nouvqu . premier fils des quadrangles .
37 c . ninqua . e . nbquto . noeud interne au quadrangle .
38 c . disnoe . s . nouvno . indicateurs de disparition des noeuds .
39 c . disare . s . nouvar . indicateurs de disparition des aretes .
40 c . distri . s . nouvtr . indicateurs de disparition des triangles .
41 c . disqua . s . nouvqu . indicateurs de disparition des quadrangles .
42 c . decare . e .0:nbarto. table des decisions sur les aretes .
43 c . filare . e . nouvar . premiere fille des aretes .
44 c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes .
45 c . posifa . e .0:nbarto. pointeur sur tableau facare .
46 c . facare . e . nbfaar . liste des faces contenant une arete .
47 c . somare . e .2*nouvar. numeros des extremites d'arete .
48 c . hetnoe . e/s . nouvno . historique de l'etat des noeuds .
49 c . codret . s . 1 . code de retour, 0 si ok .
50 c ______________________________________________________________________
53 c 0. declarations et dimensionnement
56 c 0.1. ==> generalites
63 parameter ( nompro = 'CMDRQU' )
76 c remarque : "disnoe", "disare", "distri" et "disqua" sont des
77 c tableaux temporaires destines a la suppression ulterieure des
78 c entites. par convention, une valeur 0 indique la conservation et
79 c une valeur 1 la disparition de l'entite concernee par la liste.
81 integer decfac(-nbquto:nbtrto)
82 integer arequa(nouvqu,4), hetqua(nouvqu)
83 integer filqua(nouvqu), ninqua(nbquto)
84 integer disnoe(nouvno), disare(nouvar)
85 integer distri(nouvtr), disqua(nouvqu)
86 integer decare(0:nbarto), filare(nouvar), np2are(nouvar)
87 integer posifa(0:nbarto), facare(nbfaar)
88 integer somare(2,nouvar), hetnoe(nouvno), codret
90 c 0.4. ==> variables locales
92 integer lequad, lefils, fafils, numare
93 integer larete, lenoeu, noemil, noefil
94 integer ideb, ifin, facvoi, nbdisp
98 c 0.5. ==> initialisations
103 c ______________________________________________________________________
105 #ifdef _DEBUG_HOMARD_
106 write (1,*) 'entree de ',nompro
107 do 1105 , lequad = 1 , nouvqu
108 if ( lequad.eq.1094 .or.
109 >(lequad.ge.3341 .and. lequad.le.3344)) then
110 write (1,90001) 'quadrangle', lequad,
111 > arequa(lequad,1), arequa(lequad,2),
112 > arequa(lequad,3), arequa(lequad,4)
113 write (1,90001) 'quadrangle', lequad,
114 > decare(arequa(lequad,1)), decare(arequa(lequad,2)),
115 > decare(arequa(lequad,3)), decare(arequa(lequad,4))
116 write (1,90112) 'decfac', lequad,decfac(-lequad)
122 c 1. traitement des faces
125 if ( mod(mailet,3).eq.0 ) then
131 do 100 , lequad = 1 , nbqupe
133 c 1.1. ==> dans le cas ou le quadrangle est pere d'actif
135 if ( mod( hetqua(lequad) , 100 ).eq.4 ) then
137 c 1.1.1. ==> dans le cas ou le quadrangle est marque "a reactiver"
139 if ( decfac(-lequad).eq.-1 ) then
141 c 1.1.1.1. ==> marquage de ses quatre quadrangles fils "a disparaitre"
143 lefils = filqua(lequad)
145 do 200 , fafils = lefils , lefils + 3
151 c 1.1.1.2. ==> marquage des filles de ses quatre aretes "a disparaitre"
152 c a condition que l'arete reapparaisse.
154 do 220 , numare = 1 , 4
156 larete = arequa(lequad,numare)
158 if ( decare(larete).eq.-1 ) then
160 c on verifie que les faces voisines des aretes filles de
161 c l'arete consideree sont toutes marquees a disparaitre.
162 c pour cela, on comptabilise (en negatif) le nombre de faces
163 c voisines des aretes fille marquees a disparaitre. si le
164 c total est nul, c'est que toutes les faces doivent bien
165 c disparaitre. dans ce cas, et dans ce cas seulement,
166 c on pourra marquer les aretes filles comme etant a
169 c test des faces voisines de la premiere arete fille
171 lefils = filare(larete)
172 ideb = posifa(lefils - 1) + 1
173 ifin = posifa(lefils)
175 nbdisp = ifin - ideb + 1
176 do 210 , facvoi = ideb , ifin
177 if ( facare(facvoi).gt.0 ) then
178 if (distri(facare(facvoi)).eq.1) then
182 if (disqua(-facare(facvoi)).eq.1) then
188 c test des faces voisines de la seconde arete fille
190 lefils = filare(larete) + 1
191 ideb = posifa(lefils - 1) + 1
192 ifin = posifa(lefils)
194 nbdisp = ifin - ideb + 1 + nbdisp
195 do 212 , facvoi = ideb , ifin
196 if ( facare(facvoi).gt.0 ) then
197 if (distri(facare(facvoi)).eq.1) then
201 if (disqua(-facare(facvoi)).eq.1) then
207 c verification du nombre de quadrangles marques a
209 c (il ne doit pas en rester, qui ne soit pas marques a
210 c disparaitre, pour pouvoir eliminer les aretes filles)
212 if ( nbdisp.eq.0 ) then
214 lefils = filare(larete)
216 disare( lefils + 1 ) = 1
219 noefil = somare(1,lefils)
220 if ( ( noefil.eq.somare(1,lefils+1) ).or.
221 > ( noefil.eq.somare(2,lefils+1) ) ) then
224 noefil = somare(2,lefils)
225 if ( ( noefil.eq.somare(1,lefils+1) ).or.
226 > ( noefil.eq.somare(2,lefils+1) ) ) then
229 if ( noemil.eq.0 ) then
233 if ( degre.eq.2 ) then
235 if ( noemil.ne.np2are(larete) ) then
239 disnoe(np2are(lefils)) = 1
240 disnoe(np2are(lefils + 1)) = 1
242 c modification de l'etat du noeud p1 milieu en p2 :
243 c . son etat anterieur, la dizaine, est conserve
244 c . son etat courant passe a 2, P2
245 hetnoe(noemil) = hetnoe(noemil)
246 > - mod(hetnoe(noemil),10)
261 c 1.1.1.3. ==> marquage des quatre aretes internes
262 c les quatre eventuels noeuds p2 sont aussi marques
264 c remarque : ses quatre aretes internes sont les deuxiemes
265 c dans la definition des faces filles
267 lefils = filqua(lequad)
269 do 240 , fafils = lefils , lefils + 3
271 larete = arequa(fafils,2)
272 cgn print 1789,larete, somare(1,larete), somare(2,larete)
273 cgn 1789 format('Arete ',i10,' de',i10,' a',i10)
277 if ( degre.eq.2 ) then
278 lenoeu = np2are(larete)
284 c 1.1.1.4. ==> marquage des eventuels noeuds internes "a disparaitre"
285 c ce sont ceux des fils
286 c remarque : le noeud central est le second de chacune de ces
288 c il ne disparait que si on n'est pas en quad9
292 do 241 , fafils = lefils , lefils + 3
294 lenoeu = ninqua(fafils)
301 disnoe(somare(2,arequa(lefils,2))) = 1