1 subroutine decora ( nomail,
2 > lgopti, taopti, lgopts, taopts,
5 > ulsort, langue, codret )
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 traitement des DEcisions - COntraintes de RAffinement
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . nomail . e . ch8 . nom de l'objet contenant le maillage .
33 c . lgopti . e . 1 . longueur du tableau des options .
34 c . taopti . e . lgopti . tableau des options .
35 c . lgopts . e . 1 . longueur du tableau des options caracteres .
36 c . taopts . e . lgopts . tableau des options caracteres .
37 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
38 c . taetco . e . lgetco . tableau de l'etat courant .
39 c . afaire . s . 1 . que faire a la sortie .
40 c . . . . 0 : aucune action .
41 c . . . . 1 : refaire une iteration de l'algorithme .
42 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
43 c . langue . e . 1 . langue des messages .
44 c . . . . 1 : francais, 2 : anglais .
45 c . codret . es . 1 . code de retour des modules .
46 c . . . . 0 : pas de probleme .
47 c . . . . sinon : probleme .
48 c ______________________________________________________________________
51 c 0. declarations et dimensionnement
54 c 0.1. ==> generalites
60 parameter ( nompro = 'DECORA' )
83 integer taopti(lgopti)
86 character*8 taopts(lgopts)
89 integer taetco(lgetco)
92 integer ulsort, langue, codret
94 c 0.4. ==> variables locales
96 integer nretap, nrsset
99 integer psomar, phetar, pfilar, pmerar, pposif, pfacar
100 integer phettr, paretr, pnivtr, advotr
101 integer phetqu, parequ, pnivqu, advoqu
102 integer phette, ptrite
103 integer phethe, pquahe, pcoquh
105 integer pdecar, pdecfa
107 integer adtra3, adtra4, adtra5, adtra6
109 integer codre0, codre1, codre2, codre3, codre4
112 character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5, ntrav6
114 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
115 character*8 nhtetr, nhhexa, nhpyra, nhpent
117 character*8 nhvois, nhsupe, nhsups
120 parameter ( nbmess = 10 )
121 character*80 texte(nblang,nbmess)
123 c 0.5. ==> initialisations
124 c ______________________________________________________________________
132 #ifdef _DEBUG_HOMARD_
133 write (ulsort,texte(langue,1)) 'Entree', nompro
137 c 1.3. ==> les messages
139 texte(1,4) = '(/,a6,'' CONTRAINTES POUR LE RAFFINEMENT'')'
140 texte(1,5) = '(38(''=''),/)'
141 texte(1,6) = '(5x,''Toutes les contraintes sont respectees.'')'
142 texte(1,7) = '(''Option choisie :'',i4)'
143 texte(1,9) = '(''Cette option est impossible en dimension'',i2,/)'
144 texte(1,10) = '(''Decision en retour de '',a6,'' ='',i2,/)'
146 texte(2,4) = '(/,a6,'' REFINEMENT CONDITIONS'')'
147 texte(2,5) = '(28(''=''),/)'
148 texte(2,6) = '(5x,''No more unfilled conditions.'')'
149 texte(2,7) = '(''Selected option :'',i4)'
151 > '(''This option is not available with dimension'',i4,/)'
152 texte(2,10) = '(''Decision code from '',a6,'' ='',i4,/)'
154 c 1.4. ==> le numero de sous-etape
157 nrsset = taetco(2) + 1
160 call utcvne ( nretap, nrsset, saux, iaux, codret )
164 write (ulsort,texte(langue,4)) saux
165 write (ulsort,texte(langue,5))
169 #ifdef _DEBUG_HOMARD_
170 write (ulsort,texte(langue,7)) taopti(36)
174 c 2. recuperation des pointeurs, initialisations
177 c 2.1. ==> structure generale
179 if ( codret.eq.0 ) then
181 #ifdef _DEBUG_HOMARD_
182 write (ulsort,texte(langue,3)) 'UTNOMH', nompro
184 call utnomh ( nomail,
186 > degre, maconf, homolo, hierar,
187 > rafdef, nbmane, typcca, typsfr, maextr,
190 > nhnoeu, nhmapo, nharet,
192 > nhtetr, nhhexa, nhpyra, nhpent,
194 > nhvois, nhsupe, nhsups,
195 > ulsort, langue, codret)
200 #ifdef _DEBUG_HOMARD_
201 write (ulsort,90002) '2.2. tableaux ; codret', codret
203 #ifdef _DEBUG_HOMARD_
204 write (ulsort,90002) 'taopti(36)', taopti(36)
207 if ( codret.eq.0 ) then
209 if ( mod(taopti(36),2).eq.0 ) then
211 elseif ( mod(taopti(36),3).eq.0 ) then
213 elseif ( mod(taopti(36),5).eq.0 ) then
218 if ( homolo.ge.2 ) then
221 #ifdef _DEBUG_HOMARD_
222 write (ulsort,90002) 'iaux, codret', iaux, codret
225 #ifdef _DEBUG_HOMARD_
226 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
228 call utad02 ( iaux, nharet,
229 > phetar, psomar, pfilar, pmerar,
232 > jaux, adhoar, jaux,
233 > ulsort, langue, codret )
235 if ( nbtrto.ne.0 ) then
237 if ( mod(taopti(36),2).eq.0 ) then
242 #ifdef _DEBUG_HOMARD_
243 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
245 call utad02 ( iaux, nhtria,
246 > phettr, paretr, jaux , jaux ,
248 > pnivtr, jaux, jaux,
250 > ulsort, langue, codret )
254 if ( nbquto.ne.0 ) then
256 if ( mod(taopti(36),2).eq.0 ) then
261 #ifdef _DEBUG_HOMARD_
262 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
264 call utad02 ( iaux, nhquad,
265 > phetqu, parequ, jaux , jaux ,
267 > pnivqu, jaux, jaux,
269 > ulsort, langue, codret )
273 if ( nbteto.ne.0 ) then
275 if ( mod(taopti(36),5).eq.0 ) then
277 #ifdef _DEBUG_HOMARD_
278 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
280 call utad02 ( iaux, nhtetr,
281 > phette, ptrite, jaux , jaux ,
285 > ulsort, langue, codret )
290 if ( nbheto.ne.0 ) then
292 if ( mod(taopti(36),5).eq.0 ) then
294 #ifdef _DEBUG_HOMARD_
295 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
297 call utad02 ( iaux, nhhexa,
298 > phethe, pquahe, jaux , jaux ,
300 > jaux, pcoquh, jaux,
302 > ulsort, langue, codret )
307 c 2.3. ==> voisinages
309 #ifdef _DEBUG_HOMARD_
310 write (ulsort,90002) '2.3. voisinages ; codret', codret
313 if ( codret.eq.0 ) then
316 if ( mod(taopti(36),2).eq.0 .or.
317 > mod(taopti(36),5).eq.0 ) then
318 if ( nbteto.ne.0 ) then
321 if ( nbheto.ne.0 ) then
325 #ifdef _DEBUG_HOMARD_
326 write (ulsort,texte(langue,3)) 'UTAD04', nompro
328 call utad04 ( iaux, nhvois,
329 > jaux, jaux, pposif, pfacar,
331 > jaux, jaux, jaux, jaux,
336 > ulsort, langue, codret )
342 #ifdef _DEBUG_HOMARD_
343 write (ulsort,90002) '2.4. decisions ; codret', codret
347 call gmadoj ( ntrav1, pdecar, iaux, codre1 )
349 call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
351 codre0 = min ( codre1, codre2 )
352 codret = max ( abs(codre0), codret,
355 c 2.5. ==> auxiliaires
357 #ifdef _DEBUG_HOMARD_
358 write (ulsort,90002) '2.5. auxiliaires ; codret', codret
361 iaux = 2 * ( nbtrto + nbquto )
362 call gmalot ( ntrav3, 'entier', iaux, adtra3, codre1 )
364 call gmalot ( ntrav4, 'entier', iaux, adtra4, codre2 )
366 call gmalot ( ntrav5, 'entier', iaux, adtra5, codre3 )
367 iaux = nbtrto + nbquto
368 call gmalot ( ntrav6, 'entier', iaux, adtra6, codre4 )
370 codre0 = min ( codre1, codre2, codre3, codre4 )
371 codret = max ( abs(codre0), codret,
372 > codre1, codre2, codre3, codre4 )
377 c 3. Application des contraintes
379 #ifdef _DEBUG_HOMARD_
380 write (ulsort,90002) '3. Application contraintes ; codret', codret
383 if ( codret.eq.0 ) then
387 c 3.1. ==> Decalage de deux elements avant un changement de niveau
388 c operationnel en 2D uniquement aujourd'hui
390 if ( mod(taopti(36),2).eq.0 ) then
392 if ( sdim.ne.2 ) then
394 write (ulsort,texte(langue,7)) taopti(36)
395 write (ulsort,texte(langue,9)) sdim
400 #ifdef _DEBUG_HOMARD_
401 write (ulsort,texte(langue,3)) 'DECR02', nompro
403 call decr02 ( imem(pdecfa), imem(pdecar),
405 > imem(pfilar), imem(pmerar), imem(phetar),
406 > imem(pposif), imem(pfacar),
407 > imem(phettr), imem(paretr), imem(pnivtr),
409 > imem(phetqu), imem(parequ), imem(pnivqu),
410 > imem(adtra3), imem(adtra4),
411 > imem(adtra5), imem(adtra6),
413 > ulsort, langue, codret )
415 #ifdef _DEBUG_HOMARD_
416 write (ulsort,texte(langue,10)) 'DECR02', afaire
422 c 3.2. ==> Bande de raffinement interdite
423 c operationnel en 2D uniquement aujourd'hui
425 if ( mod(taopti(36),3).eq.0 ) then
427 if ( sdim.ne.2 ) then
429 write (ulsort,texte(langue,7)) taopti(36)
430 write (ulsort,texte(langue,9)) sdim
435 #ifdef _DEBUG_HOMARD_
436 write (ulsort,texte(langue,3)) 'DECR03', nompro
438 call decr03 ( imem(pdecfa), imem(pdecar),
439 > imem(phetar), imem(pposif), imem(pfacar),
440 > imem(phettr), imem(paretr),
441 > imem(phetqu), imem(parequ),
444 > ulsort, langue, codret )
446 #ifdef _DEBUG_HOMARD_
447 write (ulsort,texte(langue,10)) 'DECR03', afaire
453 c 3.3. ==> Pas d'elements decoupes seul :
454 c . Pas de segments sans la ou les faces auxquelles
456 c . Pas de face sans le ou les volumes auxquels il appartient
458 if ( mod(taopti(36),5).eq.0 ) then
460 #ifdef _DEBUG_HOMARD_
461 write (ulsort,texte(langue,3)) 'DECR05', nompro
463 call decr05 ( taopti(31), homolo,
464 > imem(pdecfa), imem(pdecar),
465 > imem(phetar), imem(pfilar),
466 > imem(pposif), imem(pfacar),
467 > imem(phettr), imem(paretr), imem(advotr),
468 > imem(phetqu), imem(parequ), imem(advoqu),
470 > imem(pquahe), imem(pcoquh),
473 > ulsort, langue, codret )
475 #ifdef _DEBUG_HOMARD_
476 write (ulsort,texte(langue,10)) 'DECR05', afaire
487 if ( codret.eq.0 ) then
489 call gmlboj ( ntrav3, codre1 )
490 call gmlboj ( ntrav4, codre2 )
491 call gmlboj ( ntrav5, codre3 )
492 call gmlboj ( ntrav6, codre4 )
494 codre0 = min ( codre1, codre2, codre3, codre4 )
495 codret = max ( abs(codre0), codret,
496 > codre1, codre2, codre3, codre4 )
504 if ( codret.eq.0 ) then
505 if ( afaire.eq.0 ) then
506 write (ulsort,texte(langue,6))
510 if ( codret.ne.0 ) then
514 write (ulsort,texte(langue,1)) 'Sortie', nompro
515 write (ulsort,texte(langue,2)) codret
519 #ifdef _DEBUG_HOMARD_
520 write (ulsort,texte(langue,1)) 'Sortie', nompro