1 subroutine utepyr ( nbpyto, nbyfal, nbyaal, nbtral,
3 > facpyr, cofapy, arepyr,
4 > nmprog, avappr, ulbila,
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 UTilitaire - Examen des PYRamides
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . nbpyto . e . 1 . nombre de pyramides a examiner .
33 c . nbyfal . e . 1 . nbre de pyras par faces pour les allocs .
34 c . nbyaal . e . 1 . nbre de pyras par aretes pour les allocs .
35 c . nbtral . e . 1 . nombre de triangles pour les allocations .
36 c . somare . e . 2*nbar . numeros des extremites d'arete .
37 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
38 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
39 c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides .
40 c . arepyr . e .nbyaal*8. numeros des 8 aretes des pyramides .
41 c . nmprog . e . char* . nom du programme a pister .
42 c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" .
43 c . . . . 2 : impression apres l'appel a "nmprog" .
44 c . ulbila . e . 1 . unite logitee d'ecriture du bilan .
45 c . ulsort . e . 1 . numero d'unite logitee de la liste standard.
46 c . langue . e . 1 . langue des messages .
47 c . . . . 1 : francais, 2 : anglais .
48 c . codret . es . 1 . code de retour des modules .
49 c . . . . 0 : pas de probleme .
50 c . . . . >0 : probleme dans le controle .
51 c ______________________________________________________________________
54 c 0. declarations et dimensionnement
57 c 0.1. ==> generalites
63 parameter ( nompro = 'UTEPYR' )
75 integer nbpyto, nbyfal, nbyaal, nbtral
77 integer aretri(nbtral,4)
78 integer facpyr(nbyfal,5), cofapy(nbyfal,5), arepyr(nbyaal,8)
85 integer ulsort, langue, codret
87 c 0.4. ==> variables locales
92 integer lapyra, lapyr0
93 integer f1, f2, f3, f4
94 integer listar(8), listso(5)
97 parameter ( nbmess = 20 )
98 character*80 texte(nblang,nbmess)
100 c 0.5. ==> initialisations
101 c ______________________________________________________________________
111 #ifdef _DEBUG_HOMARD_
112 write (ulsort,texte(langue,1)) 'Entree', nompro
116 texte(1,6) = '(5x,''Controle des '',i10,'' pyramides.'')'
118 > '(''La pyramide '',i10,'' a des '',a,'' identiques :'',12i10)'
120 > '(''Les aretes de la pyramide '',i10,'' ne se suivent pas.'')'
122 > '(5x,''Pas de probleme dans la definition des pyramides'',/)'
123 texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
124 texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
125 texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
126 texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
128 texte(2,6) = '(5x,''Control of '',i10,'' pyramids.'')'
130 > '(''Pyramid # '',i10,'' has got similar '',a,'':'',12i10)'
132 > '(''Edges of pyramid '',i10,'' are not following.'')'
133 texte(2,16) = '(5x,''No problem with pyramid definition'',/)'
134 texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
135 texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
136 texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
137 texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
139 #ifdef _DEBUG_HOMARD_
140 if ( avappr.ge.0 .and. avappr.le.2 ) then
141 write (ulsort,texte(langue,18+avappr)) nmprog
143 write (ulsort,texte(langue,17)) nmprog, avappr
146 write (ulsort,texte(langue,6)) nbpyto
147 cgn write (ulsort,*) nbyfal, nbyaal
149 c 1.3. ==> constantes
157 nbpyal = nbyfal + nbyaal
159 do 20 , lapyr0 = 1 , nbpyto
165 c 2.1. ==> les faces doivent etre differentes ...
167 if ( lapyra.le.nbyfal ) then
169 f1 = facpyr(lapyra,1)
170 f2 = facpyr(lapyra,2)
171 f3 = facpyr(lapyra,3)
172 f4 = facpyr(lapyra,4)
181 write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,2),
183 write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,2),
189 c 2.2. ==> les aretes doivent etre differentes ...
191 if ( codre0.eq.0 ) then
193 call utaspy ( lapyra,
194 > nbtral, nbyfal, nbyaal,
196 > facpyr, cofapy, arepyr,
201 if ( codre0.eq.0 ) then
203 do 221 , iaux = 1 , 7
204 do 222 , jaux = iaux+1 , 8
205 if ( listar(iaux).eq.listar(jaux) ) then
211 if ( codre0.ne.0 ) then
212 write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,1),
213 > (listar(iaux),iaux=1,8)
214 write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,1),
215 > (listar(iaux),iaux=1,8)
220 c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ...
222 if ( codre0.eq.0 ) then
227 #ifdef _DEBUG_HOMARD_
228 write (ulsort,texte(langue,3)) 'UTVAR0', nompro
230 call utvar0 ( iaux, lapyra, jaux, listar, somare,
231 > ulbila, ulsort, langue, codre0 )
235 c 2.4. ==> les sommets doivent etre differents ...
237 if ( codre0.eq.0 ) then
240 do 241 , jaux = iaux+1 , 5
241 if ( listso(iaux).eq.listso(jaux) ) then
247 if ( codre0.ne.0 ) then
248 write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,-1),
249 > (listso(iaux),iaux=1,5)
250 write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,-1),
251 > (listso(iaux),iaux=1,5)
256 c 2.5. ==> cumul des erreurs
258 codret = codret + codre0
262 c 2.6. ==> tout va bien
264 if ( codret.eq.0 ) then
265 write (ulsort,texte(langue,16))
266 write (ulbila,texte(langue,16))
273 if ( codret.ne.0 ) then
277 write (ulsort,texte(langue,1)) 'Sortie', nompro
278 write (ulsort,texte(langue,2)) codret
282 #ifdef _DEBUG_HOMARD_
283 write (ulsort,texte(langue,1)) 'Sortie', nompro