1 subroutine deisv1 ( ncmpin, usacmp, nbvoto, typenh,
3 > hettri, filtri, pertri,
4 > hetqua, filqua, perqua,
8 > ulsort, langue, codret )
9 c ______________________________________________________________________
13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
16 c aupres des huissiers de justice Simart et Lavoir a Clamart
17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
18 c aupres des huissiers de justice
19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
21 c HOMARD est une marque deposee d'Electricite de France
27 c ______________________________________________________________________
29 c traitement des DEcisions - Initialisations - par Saut - Volumes - 1
32 c On traite ici uniquement les sauts entre volumes pour les cas ou
33 c il n'y a que des tetraedres ou que des hexaedres concernes par
34 c un indicateur d'erreur.
35 c Quand l'indicateur est reparti sur des entites de nature
36 c differente, on gerera le saut dans deisv2.
37 c ______________________________________________________________________
39 c . nom . e/s . taille . description .
40 c .____________________________________________________________________.
41 c . ncmpin . e . 1 . nombre de composantes de l'indicateur .
42 c . usacmp . e . 1 . usage des composantes de l'indicateur .
43 c . . . . 0 : norme L2 .
44 c . . . . 1 : norme infinie -max des valeurs absolues.
45 c . . . . 2 : valeur relative si une seule composante.
46 c . nbvoto . e . 1 . nombre de volumes total .
47 c . typenh . e . 1 . 3 : tetraedres .
48 c . . . . 6 : hexaedres .
49 c . vosupp . e . nbvoto . support pour les volumes .
50 c . voindi . s . nbvoto . valeurs reelles pour les volumes .
51 c . hettri . e . nbtrto . historique de l'etat des triangles .
52 c . filtri . e . nbtrto . premier fils des triangles .
53 c . pertri . e . nbtrto . pere des triangles .
54 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
55 c . filqua . e . nbquto . fils des quadrangles .
56 c . perqua . e . nbquto . pere des quadrangles .
57 c . hetvol . e . nbvoto . historique de l'etat des volumes .
58 c . facvol . e .nbvoto*n. numeros des n faces des volumes .
59 c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle .
60 c . . . . voltri(i,k) definit le i-eme voisin de k .
61 c . . . . 0 : pas de voisin .
62 c . . . . j>0 : tetraedre j .
63 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
64 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
65 c . . . . volqua(i,k) definit le i-eme voisin de k .
66 c . . . . 0 : pas de voisin .
67 c . . . . j>0 : hexaedre j .
68 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
69 c . tabent . aux . * . tableau auxiliaire entier .
70 c . voinin . aux . * . sauvegarde des valeurs des indicateurs .
71 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
72 c . langue . e . 1 . langue des messages .
73 c . . . . 1 : francais, 2 : anglais .
74 c . codret . es . 1 . code de retour des modules .
75 c . . . . 0 : pas de probleme .
76 c . . . . 1 : mauvais typenh .
77 c ______________________________________________________________________
80 c 0. declarations et dimensionnement
83 c 0.1. ==> generalites
89 parameter ( nompro = 'DEISV1' )
106 integer nbvoto, typenh
108 integer vosupp(nbvoto)
109 integer hettri(nbtrto), filtri(nbtrto), pertri(nbtrto)
110 integer hetqua(nbquto), filqua(nbquto), perqua(nbquto)
111 integer voltri(2,nbtrto)
112 integer volqua(2,nbquto)
113 integer hetvol(nbvoto), facvol(nbvoto,*)
116 integer ulsort, langue, codret
118 double precision voindi(nbvoto,ncmpin)
119 double precision voinin(nbvoto,ncmpin)
121 c 0.4. ==> variables locales
123 integer iaux, jaux, kaux
124 integer lgpile, nupile
126 integer lafavo, laface, tyface, typfac
133 double precision daux1, daux2
135 parameter( lgdaux = 100 )
136 double precision daux(lgdaux), vect(lgdaux)
141 parameter (nbmess = 11 )
142 character*80 texte(nblang,nbmess)
143 c ______________________________________________________________________
151 #ifdef _DEBUG_HOMARD_
152 write (ulsort,texte(langue,1)) 'Entree', nompro
156 texte(1,4) = '(''. Saut a la traversee des '',a)'
158 > '(''On veut'',i6,'' composantes, mais taille de daux ='',i6)'
159 texte(1,6) = ' (''Type d''''entite incorrect :'',i10)'
160 texte(1,9) = '(''. Norme L2 des composantes.'')'
161 texte(1,10) = '(''. Norme infinie des composantes.'')'
162 texte(1,11) = '(''. Valeur relative de la composante.'')'
164 texte(2,4) = '(''. Jump through the '',a)'
166 > '(i6,''components are requested, but size of daux equals'',i6)'
167 texte(2,6) = ' (''Uncorrect type of entity: :'',i10)'
168 texte(2,9) = '(''. L2 norm of components.'')'
169 texte(2,10) = '(''. Infinite norm of components.'')'
170 texte(2,11) = '(''. Relative value for the component.'')'
178 if ( ncmpin.gt.lgdaux ) then
179 write (ulsort,texte(langue,5)) ncmpin, lgdaux
183 #ifdef _DEBUG_HOMARD_
184 write (ulsort,texte(langue,9+usacmp))
187 c 1.3. ==> Les types de faces : triangle (2) ou quadrangle (4)
189 if ( codret.eq.0 ) then
191 if ( typenh.eq.3 ) then
194 elseif ( typenh.eq.6 ) then
199 write (ulsort,texte(langue,6)) typenh
202 #ifdef _DEBUG_HOMARD_
203 write (ulsort,texte(langue,4)) mess14(langue,3,typfac)
209 c 2. On parcourt tous les volumes.
210 c On calcule l'ecart entre la valeur de l'indicateur sur le volume
211 c courant et sur les voisins.
212 c On garde le max au sens de la norme voulue
213 c levolu = numero local dans la categorie
215 #ifdef _DEBUG_HOMARD_
216 write (ulsort,90002) '2. parcours des volumes ; codret', codret
219 do 2 , levolu = 1 , nbvoto
221 if ( codret.eq.0 ) then
223 if ( vosupp(levolu).ne.0 ) then
225 c 2.1. ==> Exploration de toutes les faces du volume
229 do 21 , iaux = 1 , nbfavo
231 c 2.1.1. ==> pour chaque face du volume, on stocke les numeros
232 c des faces voisines, en descendant les parentes.
233 c Au final, on stocke la premiere face mere active
235 lafavo = facvol(levolu,iaux)
237 cgn if ( glop.eq.1) then
238 cgn write(ulsort,90002) '. face de rang',iaux
241 #ifdef _DEBUG_HOMARD_
242 write (ulsort,texte(langue,3)) 'DEISV3', nompro
244 call deisv3 ( lafavo, tyface,
248 > ulsort, langue, codret )
250 c 2.1.2. ==> pour chaque face de la pile : si elle est active, on
251 c cherche le max de l'ecart entre la valeur de l'indicateur
252 c sur le volume voisin et celle sur le volume courant
253 c on sait que les faces sont toutes de meme type
255 do 212 , nupile = 1 , lgpile
257 laface = tabent(1,nupile)
259 c 2.1.2.1. ==> reperage selon la face
261 if ( typfac.eq.2 ) then
262 etat = mod(hettri(laface),10)
264 etat = mod(hetqua(laface),100)
267 c 2.1.2.2. ==> traitement
269 if ( etat.eq.0 ) then
270 cgn if ( glop.eq.1) then
271 cgn write(ulsort,90002)'.. Voisinage par le '//
272 cgn > mess14(langue,1,typfac),laface
274 do 2122 , jaux = 1 , 2
278 if ( typfac.eq.2 ) then
279 kaux = voltri(jaux,laface)
281 kaux = volqua(jaux,laface)
284 if ( kaux.gt.0 ) then
286 if ( vosupp(kaux).ne.0 ) then
288 if ( kaux.ne.levolu ) then
290 do 21221 , nrcomp = 1 , ncmpin
291 daux(nrcomp) = voinin(kaux,nrcomp)
292 > - voinin(levolu,nrcomp)
294 cgn if ( glop.eq.1) then
295 cgn write(ulsort,90054)'...... ==> ecart avec ', kaux,' : ',
296 cgn > (daux(nrcomp),nrcomp=1,ncmpin)
303 elseif ( kaux.lt.0 ) then
304 cgn if ( glop.eq.1) then
305 cgn write(ulsort,*)'.... Autre type de volume voisin.'
310 c calcul de la norme de l'ecart
311 c si on a passe le max, on stocke
315 if ( usacmp.eq.0 ) then
317 do 21222 , nrcomp = 2 , ncmpin
318 daux2 = daux2 + daux(nrcomp)**2
320 elseif ( usacmp.eq.1 ) then
322 do 21223 , nrcomp = 2 , ncmpin
323 daux2 = max(daux2,abs(daux(nrcomp)))
328 if ( daux2.gt.daux1 ) then
330 do 21224 , nrcomp = 1 , ncmpin
331 vect(nrcomp) = daux(nrcomp)
343 c 2.3. ==> on remonte la parente pour pieger les non-conformites
349 cgn if ( glop.eq.1) then
350 cgn write(ulsort,90002)'.... Parente du '//
351 cgn > mess14(langue,1,typfac),laface
353 if ( typfac.eq.2 ) then
354 merefa = pertri(laface)
356 merefa = perqua(laface)
359 if ( merefa.gt.0 ) then
360 cgn if ( glop.eq.1) then
361 cgn write(ulsort,90006)'.... le '//
362 cgn > mess14(langue,1,typfac), laface,' a une mere : ',merefa
365 if ( typfac.eq.2 ) then
366 kaux = voltri(2,merefa)
368 kaux = volqua(2,merefa)
372 if ( kaux.eq.0 ) then
375 elseif ( kaux.gt.0 ) then
376 do 232 , jaux = 1 , 2
377 if ( typfac.eq.2 ) then
378 kaux = voltri(jaux,merefa)
380 kaux = volqua(jaux,merefa)
382 if ( kaux.gt.0 ) then
383 if ( mod(hetvol(kaux),100).eq.0 ) then
385 do 2311 , nrcomp = 1 , ncmpin
386 daux(nrcomp) = voinin(kaux,nrcomp)
387 > - voinin(levolu,nrcomp)
389 cgn if ( glop.eq.1) then
390 cgn write(ulsort,90054)'...... ==> ecart avec ', kaux,' : ',
391 cgn > (daux(nrcomp),nrcomp=1,ncmpin)
394 elseif ( kaux.lt.0 ) then
398 elseif ( kaux.lt.0 ) then
402 if ( usacmp.eq.0 ) then
404 do 23111 , nrcomp = 2 , ncmpin
405 daux2 = daux2 + daux(nrcomp)**2
407 elseif ( usacmp.eq.1 ) then
409 do 23112 , nrcomp = 2 , ncmpin
410 daux2 = max(daux2,abs(daux(nrcomp)))
415 if ( daux2.gt.daux1 ) then
417 do 2312 , nrcomp = 1 , ncmpin
418 vect(nrcomp) = daux(nrcomp)
429 cgn if ( glop.eq.1 ) then
430 cgn write(ulsort,90054) 'Final '//
431 cgn > mess14(langue,1,typenh), levolu, ' : ',
432 cgn > (vect(nrcomp),nrcomp=1,ncmpin)
435 do 241 , nrcomp = 1 , ncmpin
436 voindi(levolu,nrcomp) = vect(nrcomp)
449 if ( codret.ne.0 ) then
453 write (ulsort,texte(langue,1)) 'Sortie', nompro
454 write (ulsort,texte(langue,2)) codret
455 if ( codret.ne.1 ) then
456 write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
461 #ifdef _DEBUG_HOMARD_
462 write (ulsort,texte(langue,1)) 'Sortie', nompro