1 subroutine deisa1 ( nbvent, ncmpin, usacmp,
10 > nharet, nhtria, nhquad,
11 > nhtetr, nhhexa, nhpyra, nhpent,
13 > ulsort, langue, codret)
14 c ______________________________________________________________________
18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
21 c aupres des huissiers de justice Simart et Lavoir a Clamart
22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
23 c aupres des huissiers de justice
24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
26 c HOMARD est une marque deposee d'Electricite de France
32 c ______________________________________________________________________
34 c traitement des DEcisions - Initialisations - SAut - etape 1
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type .
41 c . . . . d'element au sens HOMARD avec indicateur .
42 c . ncmpin . e . 1 . nombre de composantes de l'indicateur .
43 c . usacmp . e . 1 . usage des composantes de l'indicateur .
44 c . . . . 0 : norme L2 .
45 c . . . . 1 : norme infinie -max des valeurs absolues.
46 c . . . . 2 : valeur relative si une seule composante.
47 c . nosupp . e . nbnoto . support pour les noeuds .
48 c . noindi . es . nbnoto . valeurs reelles pour les noeuds .
49 c . arsupp . s . nbarto . support pour les aretes .
50 c . arindi . s . nbarto . valeurs reelles pour les aretes .
51 c . trsupp . e . nbtrto . support pour les triangles .
52 c . trindi . s . nbtrto . valeurs pour les triangles .
53 c . qusupp . e . nbquto . support pour les quadrangles .
54 c . quindi . s . nbquto . valeurs pour les quadrangles .
55 c . tesupp . e . nbteto . support pour les tetraedres .
56 c . teindi . s . nbteto . valeurs pour les tetraedres .
57 c . hesupp . e . nbheto . support pour les hexaedres .
58 c . heindi . s . nbheto . valeurs pour les hexaedres .
59 c . pysupp . e . nbpyto . support pour les pyramides .
60 c . pyindi . s . nbpyto . valeurs pour les pyramides .
61 c . pesupp . e . nbpeto . support pour les pentaedres .
62 c . peindi . s . nbpeto . valeurs pour les pentaedres .
63 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
64 c . langue . e . 1 . langue des messages .
65 c . . . . 1 : francais, 2 : anglais .
66 c . codret . es . 1 . code de retour des modules .
67 c . . . . 0 : pas de probleme .
68 c . . . . 3 : probleme dans les fichiers .
69 c ______________________________________________________________________
72 c 0. declarations et dimensionnement
75 c 0.1. ==> generalites
81 parameter ( nompro = 'DEISA1' )
103 integer nbvent(-1:7), ncmpin
105 integer nosupp(nbnoto)
106 integer arsupp(nbarto)
107 integer trsupp(nbtrto)
108 integer qusupp(nbquto)
109 integer tesupp(nbteto)
110 integer hesupp(nbheto)
111 integer pysupp(nbpyto)
112 integer pesupp(nbpeto)
114 integer ulsort, langue, codret
116 double precision noindi(nbnoto,ncmpin)
117 double precision arindi(nbarto,ncmpin)
118 double precision trindi(nbtrto,ncmpin)
119 double precision quindi(nbquto,ncmpin)
120 double precision teindi(nbteto,ncmpin)
121 double precision heindi(nbheto,ncmpin)
122 double precision pyindi(nbpyto,ncmpin)
123 double precision peindi(nbpeto,ncmpin)
125 character*8 nharet, nhtria, nhquad
126 character*8 nhtetr, nhhexa, nhpyra, nhpent
127 character*8 nomail, nhvois
129 c 0.4. ==> variables locales
131 integer iaux, jaux, kaux
132 integer codre1, codre2, codre3, codre4, codre5
136 integer phetar, psomar, pfilar, pmerar
137 integer ppovos, pvoiso
138 integer pposif, pfacar
139 integer phettr, paretr, pfiltr, ppertr
140 integer phetqu, parequ, pfilqu, pperqu
141 integer phette, ptrite, pfilte, pperte, adtes2
142 integer phethe, pquahe, pfilhe, pperhe, adhes2
143 integer phetpy, pfacpy, pperpy, adpys2
144 integer phetpe, pfacpe, pperpe
145 integer adtra1, adtra2
146 integer adtrte, adtrhe, adtrpy, adtrpe
147 integer advotr, adpptr
148 integer advoqu, adppqu
150 character*8 ntrav1, ntrav2
151 character*8 ntrate, ntrahe, ntrapy, ntrape
154 parameter ( nbmess = 10 )
155 character*80 texte(nblang,nbmess)
157 c 0.5. ==> initialisations
158 c ______________________________________________________________________
166 #ifdef _DEBUG_HOMARD_
167 write (ulsort,texte(langue,1)) 'Entree', nompro
177 c 2.1. ==> les tableaux de travail
179 if ( codret.eq.0 ) then
181 iaux = max(4*(nbquto+nbtrto), nbarto)
182 call gmalot ( ntrav1, 'entier ', iaux, adtra1, codre1 )
183 iaux = max(2*(nbquto+nbtrto), nbarto, nbnoto)
185 call gmalot ( ntrav2, 'reel ', iaux, adtra2, codre2 )
186 iaux = nbteto * ncmpin
187 call gmalot ( ntrate, 'reel ', iaux, adtrte, codre3 )
188 iaux = nbheto * ncmpin
189 call gmalot ( ntrahe, 'reel ', iaux, adtrhe, codre4 )
190 iaux = nbpyto * ncmpin
191 call gmalot ( ntrapy, 'reel ', iaux, adtrpy, codre5 )
192 iaux = nbpeto * ncmpin
193 call gmalot ( ntrape, 'reel ', iaux, adtrpe, codre6 )
195 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
197 codret = max ( abs(codre0), codret,
198 > codre1, codre2, codre3, codre4, codre5,
203 c 2.2. ==> les tableaux du maillage
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,90002) '2.2. les tableaux ; codret', codret
208 if ( nbvent(-1).ne.0 .or. nbvent(1).ne.0 .or.
209 > nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then
211 #ifdef _DEBUG_HOMARD_
212 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
215 call utad02 ( iaux, nharet,
216 > phetar, psomar, pfilar, pmerar,
220 > ulsort, langue, codret )
224 if ( nbvent(2).ne.0 .or. nbvent(3).ne.0 .or.
225 > ( nbtrto.gt.0 .and. nbvent(4).ne.0 ) ) then
227 #ifdef _DEBUG_HOMARD_
228 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
231 call utad02 ( iaux, nhtria,
232 > phettr, paretr, pfiltr, ppertr,
236 > ulsort, langue, codret )
240 if ( nbvent(4).ne.0 .or. nbvent(6).ne.0 .or.
241 > ( nbquto.gt.0 .and. nbvent(2).ne.0 ) ) then
243 #ifdef _DEBUG_HOMARD_
244 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
247 call utad02 ( iaux, nhquad,
248 > phetqu, parequ, pfilqu, pperqu,
252 > ulsort, langue, codret )
256 if ( nbvent(3).ne.0 ) then
258 #ifdef _DEBUG_HOMARD_
259 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
262 if ( nbteca.gt.0 ) then
265 call utad02 ( iaux, nhtetr,
266 > phette, ptrite, pfilte, pperte,
268 > jaux, jaux, adtes2,
270 > ulsort, langue, codret )
274 if ( nbvent(5).ne.0 .or.
275 > ( nbpyto.gt.0 .and. nbvent(3).ne.0 ) .or.
276 > ( nbpyto.gt.0 .and. nbvent(6).ne.0 ) ) then
278 #ifdef _DEBUG_HOMARD_
279 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
282 if ( nbpyca.gt.0 ) then
285 call utad02 ( iaux, nhpyra,
286 > phetpy, pfacpy, jaux , pperpy,
288 > jaux, jaux, adpys2,
290 > ulsort, langue, codret )
294 if ( nbvent(6).ne.0 ) then
296 #ifdef _DEBUG_HOMARD_
297 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
300 if ( nbheco.gt.0 ) then
303 call utad02 ( iaux, nhhexa,
304 > phethe, pquahe, pfilhe, pperhe,
306 > jaux, jaux, adhes2,
308 > ulsort, langue, codret )
312 if ( nbvent(7).ne.0 .or.
313 > ( nbpeto.gt.0 .and. nbvent(3).ne.0 ) .or.
314 > ( nbpeto.gt.0 .and. nbvent(6).ne.0 ) ) then
316 #ifdef _DEBUG_HOMARD_
317 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
320 if ( nbpeca.gt.0 ) then
323 call utad02 ( iaux, nhpent,
324 > phetpe, pfacpe, jaux , pperpe,
328 > ulsort, langue, codret )
332 c 2.3. ==> Voisinages
333 #ifdef _DEBUG_HOMARD_
334 write (ulsort,90002) '2.3. ==> Voisinages ; codret', codret
337 if ( nbvent(-1).ne.0 ) then
339 if ( codret.eq.0 ) then
343 #ifdef _DEBUG_HOMARD_
344 write (ulsort,texte(langue,3)) 'UTVOIS', nompro
346 call utvois ( nomail, nhvois,
347 > iaux, jaux, jaux, jaux,
350 > ulsort, langue, codret)
356 if ( codret.eq.0 ) then
358 #ifdef _DEBUG_HOMARD_
359 write (ulsort,texte(langue,3)) 'UTAD04', nompro
362 if ( nbvent(-1).ne.0 ) then
365 if ( nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then
368 if ( nbvent(3).ne.0 ) then
370 if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then
374 if ( nbvent(6).ne.0 ) then
376 if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then
380 call utad04 ( iaux, nhvois,
381 > ppovos, pvoiso, pposif, pfacar,
383 > jaux, jaux, adpptr, adppqu,
388 > ulsort, langue, codret )
395 #ifdef _DEBUG_HOMARD_
396 write (ulsort,90002) '3. operation ; codret', codret
399 if ( codret.eq.0 ) then
401 #ifdef _DEBUG_HOMARD_
402 write (ulsort,texte(langue,3)) 'DEISA2', nompro
404 call deisa2 ( nbvent, ncmpin, usacmp,
409 > tesupp, teindi, rmem(adtrte),
410 > hesupp, heindi, rmem(adtrhe),
411 > pysupp, pyindi, rmem(adtrpy),
412 > pesupp, peindi, rmem(adtrpe),
413 > imem(phetar), imem(psomar),
414 > imem(pfilar), imem(pmerar),
415 > imem(phettr), imem(paretr),
416 > imem(pfiltr), imem(ppertr),
417 > imem(phetqu), imem(parequ),
418 > imem(pfilqu), imem(pperqu),
419 > imem(phette), imem(ptrite),
420 > imem(pperte), imem(adtes2),
421 > imem(phethe), imem(pquahe),
422 > imem(pfilhe), imem(pperhe), imem(adhes2),
425 > imem(pposif), imem(pfacar),
426 > imem(advotr), imem(adpptr),
427 > imem(advoqu), imem(adppqu),
428 > imem(adtra1), rmem(adtra2),
429 > ulsort, langue, codret)
436 #ifdef _DEBUG_HOMARD_
437 write (ulsort,90002) '4. Menage ; codret', codret
440 if ( codret.eq.0 ) then
442 call gmlboj ( ntrav1, codre1 )
443 call gmlboj ( ntrav2, codre2 )
444 call gmlboj ( ntrate, codre3 )
445 call gmlboj ( ntrahe, codre4 )
446 call gmlboj ( ntrapy, codre5 )
447 call gmlboj ( ntrape, codre6 )
449 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
451 codret = max ( abs(codre0), codret,
452 > codre1, codre2, codre3, codre4, codre5,
461 if ( codret.ne.0 ) then
465 write (ulsort,texte(langue,1)) 'Sortie', nompro
466 write (ulsort,texte(langue,2)) codret
470 #ifdef _DEBUG_HOMARD_
471 write (ulsort,texte(langue,1)) 'Sortie', nompro