1 subroutine desmaj ( nhnoeu, nharet, nhtria, nhquad,
2 > nhtetr, nhhexa, nhpyra, nhpent,
4 > ulsort, langue, codret)
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c traitement des DEcisions - Suppression - Mise A Jour
27 c ______________________________________________________________________
29 c but : mises a jour des communs apres suppression des entites de mise
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds .
36 c . nharet . e . char8 . nom de l'objet decrivant les aretes .
37 c . nhtria . e . char8 . nom de l'objet decrivant les triangles .
38 c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles .
39 c . nhtetr . e . char8 . nom de l'objet decrivant les hexaedres .
40 c . nhhexa . e . char8 . nom de l'objet decrivant les tetraedres .
41 c . nhpyra . e . char8 . nom de l'objet decrivant les pyramides .
42 c . nhpent . e . char8 . nom de l'objet decrivant les pentaedres .
43 c . afaire . s . logic . vrai, si la numerotation des noeuds doit .
44 c . . . . etre revue .
45 c . . . . faux, si un raccourcissement suffit .
46 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
47 c . langue . e . 1 . langue des messages .
48 c . . . . 1 : francais, 2 : anglais .
49 c . codret . es . 1 . code de retour des modules .
50 c . . . . 0 : pas de probleme .
51 c . . . . 1 : probleme .
52 c ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'DESMAJ' )
85 character*8 nhnoeu, nharet, nhtria, nhquad
86 character*8 nhtetr, nhhexa, nhpyra, nhpent
90 integer ulsort, langue, codret
92 c 0.4. ==> variables locales
95 integer codre1, codre2, codre3, codre4, codre5
96 integer codre6, codre7, codre8
100 parameter ( nbmess = 10 )
101 character*80 texte(nblang,nbmess)
103 c 0.5. ==> initialisations
104 c ______________________________________________________________________
112 #ifdef _DEBUG_HOMARD_
113 write (ulsort,texte(langue,1)) 'Entree', nompro
117 texte(1,4) = '(5x,''Nombre de '',a,'' : '',i10)'
118 texte(1,5) = '(5x,''Nombre de '',a,'' actifs : '',i10)'
120 texte(2,4) = '(5x,''Number of '',a,'' : '',i10)'
121 texte(2,5) = '(5x,''Number of active '',a,'' : '',i10)'
126 c 2. mise a jour des nombres d'entites du maillage
129 c - lorsqu'on supprime des entites provisoires, leur mere reapparait.
130 c - les nombres de paires d'homologues ne seront mis a jour qu'apres
131 c raffinement du maillage. il faut veiller a ne pas utiliser les
132 c tables ho1noe ... avant cela.
134 c 2.1. commun "nombno" --> noeuds
135 c remarque : voir utplco pour la coherence des chiffres
136 c Les noeuds a supprimer sont ceux qui sont :
137 c - au centre des quadrangles coupes selon 2 aretes adjacentes.
138 c - au centre des hexaedres coupes selon 2 ou 3 aretes.
139 c - au centre des pentaedres coupes selon 2 aretes de triangles
140 c ou 1 face triangulaire.
142 c Par construction, ces noeuds sont numerotes en dernier. Il suffit
143 c donc de raccourcir les tableaux des noeuds du nombre de
144 c quadrangles, d'hexaedres ou de pentaedres concernes.
145 c . En degre 2, les aretes de mise en conformite disparaissant, les
146 c noeuds P2 qu'elles portent doivent disparaitre. Par creation, ils
147 c sont numerotes en dernier.
148 c De plus, si on a supprime un noeud central, ce noeud a ete cree
149 c avant les nouveaux noeuds P2, Il faut donc remanier la
150 c numerotation des noeuds.
152 c nbnois = non modifie
153 c nbnoei = non modifie
154 c nbpnho = mis a jour dans cmhomo/uthonh - non utilise avant
155 c nbnoma = non modifie
156 c nbnop1 = non modifie
158 #ifdef _DEBUG_HOMARD_
159 write (ulsort,90002) 'mailet', mailet
160 write (ulsort,90002) 'nbnoin', nbnoin
162 write (ulsort,90002) 'nbart2', nbart2
163 write (ulsort,90002) 'nbarq2', nbarq2
164 write (ulsort,90002) 'nbarq3', nbarq3
165 write (ulsort,90002) 'nbarq5', nbarq5
166 write (ulsort,90002) 'nbarin', nbarin
168 write (ulsort,90002) 'nbtrt2', nbtrt2
169 write (ulsort,90002) 'nbtrq3', nbtrq3
171 write (ulsort,90002) 'nbquq2', nbquq2
172 write (ulsort,90002) 'nbquq5', nbquq5
174 write (ulsort,90002) 'nbteh2', nbteh2
175 write (ulsort,90002) 'nbteh3', nbteh3
176 write (ulsort,90002) 'nbtedh', nbtedh
177 write (ulsort,90002) 'nbtep3', nbtep3
178 write (ulsort,90002) 'nbtep5', nbtep5
179 write (ulsort,90002) 'nbtedp', nbtedp
180 write (ulsort,90002) 'debut de '//nompro//' nbnoto', nbnoto
181 write (ulsort,90002) 'debut de '//nompro//' nbnop2', nbnop2
182 write (ulsort,90002) 'debut de '//nompro//' nbnoim', nbnoim
187 #ifdef _DEBUG_HOMARD_
188 write (ulsort,90002) 'nombre de noeuds P1 a supprimer', iaux
190 nbnoto = nbnoto - iaux
191 if ( degre.eq.2 ) then
193 > + nbarq2 + nbarq3 + nbarq5
195 #ifdef _DEBUG_HOMARD_
196 write (ulsort,90002) 'nombre de noeuds P2 a supprimer', iaux
198 nbnoto = nbnoto - iaux
199 nbnop2 = nbnop2 - iaux
200 if ( nbquq5.ne.0 .or. nbnoin.ne.0 ) then
205 if ( mod(mailet,2).eq.0 ) then
207 nbnoto = nbnoto - nbtrt2
208 nbnoim = nbnoim - nbtrt2
212 if ( mod(mailet,3).eq.0 ) then
214 nbnoto = nbnoto - nbtrq3
215 nbnoim = nbnoim - nbtrq3
219 if ( mod(mailet,5).eq.0 ) then
227 cgn write (ulsort,90002) '==> nouveau nbnoto', nbnoto
228 cgn write (ulsort,90002) '==> nouveau nbnop2', nbnop2
229 cgn write (ulsort,90002) '==> nouveau nbnoim', nbnoim
230 cgn write (ulsort,99001) '==> afaire', afaire
232 c 2.2. commun "nombar" --> aretes
234 cgn write(*,*) nbart2, nbarq3, nbarin
236 > + nbarq2 + nbarq3 + nbarq5 + nbarin
237 cgn write (ulsort,90002) 'nombre d''aretes a supprimer', iaux
238 nbarac = nbarac - iaux
239 c nbarde = non modifie
245 c nbarma = non modifie
246 c nbarpe = non modifie
248 c nbfaar = modifie plus tard par utfaa1
249 c nbpaho = mis a jour dans cmhomo/uthonh - non utilise avant
251 c 2.3. commun "nombqu" --> quadrangles
252 c remarque : a faire avant les triangles, sinon les nombres
254 c . un triplet de triangles issus d'un decoupage en 3 d'un
255 c quadrangle reactive 1 quadrangle et 0 triangle : nombre de
256 c triangles actifs = -3, nombre de quadrangles actifs = +1
257 c . un doublet de quadrangles issus d'un decoupage en 2 d'un
258 c quadrangle reactive 1 quadrangle et en detruit 2 = -1
259 c . un triplet de quadrangles issus d'un decoupage en 3 d'un
260 c quadrangle reactive 1 quadrangle et en detruit 3 = -2/3
262 iaux = nbtrq3/3 - nbquq2 - 2*nbquq5/3
263 cgn write (ulsort,90002) 'bilan sur les quadrangles', iaux
264 nbquac = nbquac + iaux
265 c nbqude = non modifie
268 c nbquma = non modifie
269 c nbqupe = non modifie
271 c nbpqho = mis a jour dans cmhomo/uthonh - non utilise avant
273 c 2.4. commun "nombtr" --> triangles
274 c . une paire de triangles issus d'un decoupage en 2 d'un triangle
275 c reactive 1 triangle : nombre de triangles actifs = -2 +1
276 c . un triplet de triangles issus d'un decoupage en 3 d'un
277 c quadrangle reactive 1 quadrangle et 0 triangle : nombre de
278 c triangles actifs = -3, nombre de quadrangles actifs = +1
279 c . un ensemble de triangles issus d'un decoupage interne a un
280 c volume ne reactive aucun triangle : nombre de triangles
283 iaux = nbtrt2/2 + nbtrq3 + nbtrhc + nbtrpc + nbtrtc
284 cgn write (ulsort,90002) 'nombre de triangles a supprimer', iaux
285 nbtrac = nbtrac - iaux
286 c nbtrde = non modifie
292 c nbtrma = non modifie
293 c nbtrpe = non modifie
295 c nbptho = mis a jour dans cmhomo/uthonh - non utilise avant
297 c 2.5. commun "nombhe" --> hexaedres
298 c . chaque suppression de conformite des hexaedres supprime tous
299 c les hexaedres concernes et reactive les peres
301 iaux = nbhedh - nbheco
303 nbheac = nbheac - iaux
306 c nbhede = non modifie
307 c nbhema = non modifie
308 c nbhepe = non modifie
313 c 2.6. commun "nombte" --> tetraedres
314 c . une paire de tetraedres issus d'un decoupage en 2 d'un tetraedre
315 c reactive 1 tetraedre : nombre de tetraedres actifs = -2 +1
316 c . un quadruplet de tetraedres issus d'un decoupage en 4 d'un
317 c tetraedre reactive 1 tetraedre : nombre de tetraedres
319 c . chaque suppression de conformite des hexaedres supprime tous
320 c les tetraedres concernes
321 c . chaque suppression de conformite des pentaedres supprime tous
322 c les tetraedres concernes
324 iaux = nbtea2/2 + 3*(nbtea4 + nbtef4)/4
325 > + nbteh1 + nbteh2 + nbteh3 + nbteh4
326 > + nbtep0 + nbtep1 + nbtep2 + nbtep3 + nbtep4 + nbtep5
328 cgn write (ulsort,90002) 'nombre de tetraedres a supprimer', iaux
329 nbteac = nbteac - iaux
345 c nbtede = non modifie
346 c nbtema = non modifie
347 c nbtepe = non modifie
352 c 2.7. commun "nombpy" --> pyramides
353 c . chaque suppression de conformite des hexaedres supprime toutes
354 c les pyramides concernees
355 c . chaque suppression de conformite des pentaedres supprime toutes
356 c les pyramides concernees
357 c Autrement dit, nbpyto = nbpyac = 0 en sortie
359 iaux = nbpyh1 + nbpyh2 + nbpyh3 + nbpyh4
360 > + nbpyp0 + nbpyp1 + nbpyp2 + nbpyp3 + nbpyp4 + nbpyp5
362 cgn write (ulsort,90002) 'nombre de pyramides a supprimer', iaux
363 nbpyac = nbpyac - iaux
376 c nbpyma = non modifie
377 c nbpype = non modifie
382 c 2.8. commun "nombpe" --> pentaedres
384 iaux = nbpedp - nbpeco
386 nbpeac = nbpeac - iaux
389 c nbpede = non modifie
390 c nbpema = non modifie
391 c nbpepe = non modifie
400 write(ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto
401 write(ulsort,texte(langue,5)) mess14(langue,3,1), nbarac
402 if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then
403 write(ulsort,texte(langue,5)) mess14(langue,3,2), nbtrac
405 if ( nbquto.ne.0 ) then
406 write(ulsort,texte(langue,5)) mess14(langue,3,4), nbquac
408 if ( nbteto.ne.0 ) then
409 write(ulsort,texte(langue,5)) mess14(langue,3,3), nbteac
411 if ( nbheto.ne.0 ) then
412 write(ulsort,texte(langue,5)) mess14(langue,3,6), nbheac
414 if ( nbpeto.ne.0 ) then
415 write(ulsort,texte(langue,5)) mess14(langue,3,7), nbpeac
417 if ( nbpyto.ne.0 ) then
418 write(ulsort,texte(langue,5)) mess14(langue,3,5), nbpyac
423 c 4. stockage dans l'objet maillage
425 #ifdef _DEBUG_HOMARD_
426 write (ulsort,*) '5. stockage ; codret =', codret
429 if ( codret.eq.0 ) then
431 call gmecat ( nhnoeu, 1, nbnoto, codre1 )
432 call gmecat ( nharet, 1, nbarto, codre2 )
433 call gmecat ( nhtria, 1, nbtrto, codre3 )
434 call gmecat ( nhquad, 1, nbquto, codre4 )
435 call gmecat ( nhtetr, 1, nbteto, codre5 )
436 call gmecat ( nhhexa, 1, nbheto, codre6 )
437 call gmecat ( nhpyra, 1, nbpyto, codre7 )
438 call gmecat ( nhpent, 1, nbpeto, codre8 )
440 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
441 > codre6, codre7, codre8 )
442 codret = max ( abs(codre0), codret,
443 > codre1, codre2, codre3, codre4, codre5,
444 > codre6, codre7, codre8 )
446 call gmecat ( nhtetr, 2, nbteca, codre1 )
447 call gmecat ( nhhexa, 2, nbheca, codre2 )
448 call gmecat ( nhpyra, 2, nbpyca, codre3 )
449 call gmecat ( nhpent, 2, nbpeca, codre4 )
451 codre0 = min ( codre1, codre2, codre3, codre4 )
452 codret = max ( abs(codre0), codret,
453 > codre1, codre2, codre3, codre4 )
462 if ( codret.ne.0 ) then
465 write (ulsort,texte(langue,1)) 'Sortie', nompro
466 write (ulsort,texte(langue,2)) codret
469 #ifdef _DEBUG_HOMARD_
470 write (ulsort,texte(langue,1)) 'Sortie', nompro