1 subroutine utepen ( nbpeto, nbpfal, nbpaal, nbqual,
4 > facpen, cofape, arepen,
5 > nmprog, avappr, ulbila,
6 > ulsort, langue, codret )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
27 c UTilitaire - Examen des PENtaedres
29 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . nbpeto . e . 1 . nombre de pentaedres a examiner .
34 c . nbpfal . e . 1 . nombre de pents par faces pour les allocs .
35 c . nbpaal . e . 1 . nbre de pents par aretes pour les allocs .
36 c . nbqual . e . 1 . nombre de quadrangles pour les allocations .
37 c . somare . e . 2*nbar . numeros des extremites d'arete .
38 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
39 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
40 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
41 c . arepen . e .nbpeca*9. code des 9 aretes des pentaedres .
42 c . nmprog . e . char* . nom du programme a pister .
43 c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" .
44 c . . . . 2 : impression apres l'appel a "nmprog" .
45 c . ulbila . e . 1 . unite logitee d'ecriture du bilan .
46 c . ulsort . e . 1 . numero d'unite logitee 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 . . . . >0 : probleme dans le controle .
52 c ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'UTEPEN' )
76 integer nbpeto, nbpfal, nbpaal, nbqual
78 integer arequa(nbqual,4)
79 integer facpen(nbpfal,5), cofape(nbpfal,5), arepen(nbpaal,9)
86 integer ulsort, langue, codret
88 c 0.4. ==> variables locales
92 integer lepent, lepen0
93 integer f1, f2, f3, f4, f5
94 integer listar(9), listso(6)
97 parameter ( nbmess = 20 )
98 character*80 texte(nblang,nbmess)
100 c 0.5. ==> initialisations
101 c ______________________________________________________________________
109 #ifdef _DEBUG_HOMARD_
110 write (ulsort,texte(langue,1)) 'Entree', nompro
114 texte(1,6) = '(5x,''Controle des '',i10,'' pentaedres.'')'
116 > '(''Le pentaedre '',i10,'' a des '',a,'' identiques :'',12i10)'
118 > '(''Les aretes du pentaedre '',i10,'' ne se suivent pas.'')'
120 > '(5x,''Pas de probleme dans la definition des pentaedres'',/)'
121 texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
122 texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
123 texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
124 texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
126 texte(2,6) = '(5x,''Control of '',i10,'' pentahedrons.'')'
128 > '(''Pentahedron # '',i10,'' has got similar '',a,'':'',12i10)'
130 > '(''Edges of pentahedron '',i10,'' are not following.'')'
131 texte(2,16) = '(5x,''No problem with pentahedrons definition'',/)'
132 texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
133 texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
134 texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
135 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)) nbpeto
148 c 1.3. ==> constantes
156 do 20 , lepen0 = 1 , nbpeto
162 c 2.1. ==> les faces doivent etre differentes ...
164 f1 = facpen(lepent,1)
165 f2 = facpen(lepent,2)
166 f3 = facpen(lepent,3)
167 f4 = facpen(lepent,4)
168 f5 = facpen(lepent,5)
172 write (ulsort,texte(langue,7)) lepent, mess14(langue,3,2),
174 write (ulbila,texte(langue,7)) lepent, mess14(langue,3,2),
182 write (ulsort,texte(langue,7)) lepent, mess14(langue,3,4),
184 write (ulbila,texte(langue,7)) lepent, mess14(langue,3,4),
188 c 2.2. ==> les aretes doivent etre differentes ...
190 if ( codre0.eq.0 ) then
192 #ifdef _DEBUG_HOMARD_
193 write (ulsort,texte(langue,3)) 'UTASPE', nompro
195 call utaspe ( lepent,
196 > nbqual, nbpfal, nbpaal,
198 > facpen, cofape, arepen,
202 do 221 , jaux = iaux+1 , 9
203 if ( listar(iaux).eq.listar(jaux) ) then
211 c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ...
213 if ( codre0.eq.0 ) then
218 #ifdef _DEBUG_HOMARD_
219 write (ulsort,texte(langue,3)) 'UTVAR0', nompro
221 call utvar0 ( iaux, lepent, jaux, listar, somare,
222 > ulbila, ulsort, langue, codre0 )
226 c 2.4. ==> les sommets doivent etre differents ...
228 if ( codre0.eq.0 ) then
231 do 241 , jaux = iaux+1 , 6
232 if ( listso(iaux).eq.listso(jaux) ) then
238 if ( codre0.ne.0 ) then
239 write (ulsort,texte(langue,7)) lepent, mess14(langue,3,-1),
240 > (listso(iaux),iaux=1,6)
241 write (ulbila,texte(langue,7)) lepent, mess14(langue,3,-1),
242 > (listso(iaux),iaux=1,6)
247 c 2.5. ==> cumul des erreurs
249 codret = codret + codre0
253 c 2.6. ==> tout va bien
255 if ( codret.eq.0 ) then
256 write (ulsort,texte(langue,16))
257 write (ulbila,texte(langue,16))
264 if ( codret.ne.0 ) then
268 write (ulsort,texte(langue,1)) 'Sortie', nompro
269 write (ulsort,texte(langue,2)) codret
273 #ifdef _DEBUG_HOMARD_
274 write (ulsort,texte(langue,1)) 'Sortie', nompro