1 subroutine utcoma ( nomail, optimp,
2 > ulsort, langue, codret )
3 c ______________________________________________________________________
7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
10 c aupres des huissiers de justice Simart et Lavoir a Clamart
11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
12 c aupres des huissiers de justice
13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
15 c HOMARD est une marque deposee d'Electricite de France
21 c ______________________________________________________________________
23 c UTilitaire - verification de la COnformite du MAillage
25 c ______________________________________________________________________
27 c . nom . e/s . taille . description .
28 c .____________________________________________________________________.
29 c . nomail . e . ch8 . nom de l'objet contenant le maillage .
30 c . optimp . e . 1 . option d'impression des non-conformites : .
31 c . . . . 0 : pas d'impression .
32 c . . . . non nul : impression .
33 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
34 c . langue . e . 1 . langue des messages .
35 c . . . . 1 : francais, 2 : anglais .
36 c . codret . es . 1 . code de retour des modules .
37 c . . . . 0 : pas de probleme .
38 c . . . . 2 : probleme dans la recherche de tableaux .
39 c . . . . 11 : pb. de conformite sur les triangles .
40 c . . . . 21 : pb. de conformite sur les tetras .
41 c ______________________________________________________________________
44 c 0. declarations et dimensionnement
47 c 0.1. ==> generalites
53 parameter ( nompro = 'UTCOMA' )
72 integer ulsort, langue, codret
74 c 0.4. ==> variables locales
77 integer nbarto, nbtrto, nbquto
78 integer nbteto, nbheto, nbpyto, nbpeto
79 integer nbteca, nbheca, nbpyca, nbpeca
80 integer nbtecf, nbhecf, nbpycf, nbpecf
82 integer psomar, phetar
83 integer paretr, phettr
84 integer parequ, phetqu
85 integer ptrite, phette, pcotrt, parete
86 integer pquahe, phethe, pcoquh, parehe
87 integer pfacpy, phetpy, pcofay, parepy
88 integer pfacpe, phetpe, pcofap, parepe
90 integer codre1, codre2, codre3, codre4, codre5
91 integer codre6, codre7
95 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
96 character*8 nhtetr, nhhexa, nhpyra, nhpent
98 character*8 nhvois, nhsupe, nhsups
101 parameter ( nbmess = 10 )
102 character*80 texte(nblang,nbmess)
104 c 0.5. ==> initialisations
105 c ______________________________________________________________________
111 c 1.1. ==> les messages
115 #ifdef _DEBUG_HOMARD_
116 write (ulsort,texte(langue,1)) 'Entree', nompro
120 texte(1,4) = '(''Impossible de recuperer les tableaux.'')'
121 texte(1,5) = '(''Probleme de conformite sur les '',a,''.'')'
122 texte(1,6) = '(''Le maillage est de type non-conforme.'')'
124 texte(2,4) = '(''Arrays cannot be found.'')'
125 texte(2,5) = '(a,'' with hanging nodes.'')'
126 texte(2,6) = '(''Mesh is hanging-node type.'')'
131 c 2. recuperation des pointeurs, initialisations
134 c 2.1. ==> structure generale
136 if ( codret.eq.0 ) then
138 call utnomh ( nomail,
140 > degre, maconf, homolo, hierar,
141 > rafdef, nbmane, typcca, typsfr, maextr,
144 > nhnoeu, nhmapo, nharet,
146 > nhtetr, nhhexa, nhpyra, nhpent,
148 > nhvois, nhsupe, nhsups,
149 > ulsort, langue, codret)
151 cgn write (ulsort,90003) 'structures',
152 cgn > nhnoeu, nhmapo, nharet, nhtria, nhquad,
153 cgn > nhtetr, nhhexa, nhpyra, nhpent
154 cgn call gmprsx(nompro,nhquad)
155 cgn call gmprsx(nompro,nhpyra)
156 cgn call gmprsx(nompro,nhpyra//'.InfoSupp')
159 c 2.2. ==> le maillage est declare non conforme
161 if ( codret.eq.0 ) then
163 if ( ( maconf.gt.0 ) .or. ( maconf.eq.-2 ) ) then
165 write (ulsort,texte(langue,6))
175 if ( maconf.le.2 ) then
177 c 3.1. ==> Recherche des tableaux
179 if ( codret.eq.0 ) then
181 call gmliat ( nharet, 1, nbarto, codre1 )
182 call gmliat ( nhtria, 1, nbtrto, codre2 )
183 call gmliat ( nhquad, 1, nbquto, codre3 )
184 call gmliat ( nhtetr, 1, nbteto, codre4 )
185 call gmliat ( nhhexa, 1, nbheto, codre5 )
186 call gmliat ( nhpyra, 1, nbpyto, codre6 )
187 call gmliat ( nhpent, 1, nbpeto, codre7 )
189 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
191 codret = max ( abs(codre0), codret,
192 > codre1, codre2, codre3, codre4, codre5 ,
197 if ( codret.eq.0 ) then
199 call gmliat ( nhtetr, 2, nbteca, codre1 )
200 call gmliat ( nhhexa, 2, nbheca, codre2 )
201 call gmliat ( nhpyra, 2, nbpyca, codre3 )
202 call gmliat ( nhpent, 2, nbpeca, codre4 )
204 codre0 = min ( codre1, codre2, codre3, codre4 )
205 codret = max ( abs(codre0), codret,
206 > codre1, codre2, codre3, codre4 )
207 #ifdef _DEBUG_HOMARD_
208 write (ulsort,90002) 'nbteca, nbheca, nbpyca, nbpeca',
209 > nbteca, nbheca, nbpyca, nbpeca
214 if ( codret.eq.0 ) then
217 #ifdef _DEBUG_HOMARD_
218 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
220 call utad02 ( iaux, nharet,
221 > phetar, psomar, jaux , jaux,
225 > ulsort, langue, codret )
227 if ( nbtrto.ne.0 ) then
230 #ifdef _DEBUG_HOMARD_
231 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
233 call utad02 ( iaux, nhtria,
234 > phettr, paretr, jaux , jaux,
238 > ulsort, langue, codret )
242 if ( nbquto.ne.0 ) then
245 #ifdef _DEBUG_HOMARD_
246 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
248 call utad02 ( iaux, nhquad,
249 > phetqu, parequ, jaux , jaux,
253 > ulsort, langue, codret )
257 if ( nbteto.ne.0 ) then
260 if ( nbteca.gt.0 ) then
263 #ifdef _DEBUG_HOMARD_
264 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
266 call utad02 ( iaux, nhtetr,
267 > phette, ptrite, jaux , jaux,
269 > jaux, pcotrt, jaux,
270 > jaux, jaux, parete,
271 > ulsort, langue, codret )
275 if ( nbheto.ne.0 ) then
278 if ( nbheca.gt.0 ) then
281 #ifdef _DEBUG_HOMARD_
282 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
284 call utad02 ( iaux, nhhexa,
285 > phethe, pquahe, jaux , jaux,
287 > jaux, pcoquh, jaux,
288 > jaux, jaux, parehe,
289 > ulsort, langue, codret )
293 if ( nbpyto.ne.0 ) then
296 if ( nbpyca.gt.0 ) then
299 #ifdef _DEBUG_HOMARD_
300 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
302 call utad02 ( iaux, nhpyra,
303 > phetpy, pfacpy, jaux , jaux,
305 > jaux, pcofay, jaux,
306 > jaux, jaux, parepy,
307 > ulsort, langue, codret )
311 if ( nbpeto.ne.0 ) then
314 if ( nbpeca.gt.0 ) then
317 #ifdef _DEBUG_HOMARD_
318 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
320 call utad02 ( iaux, nhpent,
321 > phetpe, pfacpe, jaux , jaux,
323 > jaux, pcofap, jaux,
324 > jaux, jaux, parepe,
325 > ulsort, langue, codret )
333 if ( codret.eq.0 ) then
336 #ifdef _DEBUG_HOMARD_
337 write (ulsort,texte(langue,3)) 'UTCONF', nompro
339 call utconf ( nbarto, nbtrto, nbquto,
340 > nbteto, nbheto, nbpyto, nbpeto,
341 > nbteca, nbheca, nbpyca, nbpeca,
342 > nbtecf, nbhecf, nbpycf, nbpecf,
344 > imem(phettr), imem(paretr),
345 > imem(phetqu), imem(parequ),
346 > imem(phette), imem(ptrite), imem(pcotrt),
347 > imem(phethe), imem(pquahe), imem(pcoquh),
348 > imem(phetpy), imem(pfacpy), imem(pcofay),
349 > imem(phetpe), imem(pfacpe), imem(pcofap),
351 > ulsort, langue, codret )
361 if ( codret.ne.0 ) then
365 write (ulsort,texte(langue,1)) 'Sortie', nompro
366 write (ulsort,texte(langue,2)) codret
367 if ( codret.eq.2 ) then
368 write (ulsort,texte(langue,4))
370 #ifdef _DEBUG_HOMARD_
373 if ( optimp.ne.0 ) then
375 write (ulsort,texte(langue,5)) mess14(langue,3,codret)
376 #ifdef _DEBUG_HOMARD_
386 #ifdef _DEBUG_HOMARD_
387 write (ulsort,texte(langue,1)) 'Sortie', nompro