1 subroutine utveri ( action, nomail,
3 > ulsort, langue, codret )
4 c ______________________________________________________________________
8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
11 c aupres des huissiers de justice Simart et Lavoir a Clamart
12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
13 c aupres des huissiers de justice
14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
16 c HOMARD est une marque deposee d'Electricite de France
22 c ______________________________________________________________________
24 c UTilitaire : VERIfication
26 c ______________________________________________________________________
28 c . nom . e/s . taille . description .
29 c .____________________________________________________________________.
30 c . action . e . char8 . action en cours .
31 c . nomail . e . char8 . nom de l'objet maillage homard a verifier .
32 c . nmprog . e . char* . nom du programme a pister .
33 c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" .
34 c . . . . 2 : impression apres l'appel a "nmprog" .
35 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
36 c . langue . e . 1 . langue des messages .
37 c . . . . 1 : francais, 2 : anglais .
38 c . codret . es . 1 . code de retour des modules .
39 c . . . . 0 : pas de probleme .
40 c ______________________________________________________________________
43 c 0. declarations et dimensionnement
46 c 0.1. ==> generalites
52 parameter ( nompro = 'UTVERI' )
81 integer ulsort, langue, codret
83 c 0.4. ==> variables locales
86 integer codre1, codre2, codre3
88 integer iaux, jaux, kaux
89 integer pcoono, psomar
92 integer phette, ptrite, pcotrt, parete
93 integer phethe, pquahe, pcoquh, parehe
94 integer phetpy, pfacpy, pcofay, parepy
95 integer phetpe, pfacpe, pcofap, parepe
97 integer degre, maconf, homolo, hierar
98 integer rafdef, nbmane, typcca, typsfr, maextr
100 integer nbnoal, nbtral, nbqual
101 integer nbteal, nbtaal
102 integer nbheal, nbhaal
103 integer nbpyal, nbyaal
104 integer nbpeal, nbpaal
105 integer nuroul, lnomfl
108 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
109 character*8 nhtetr, nhhexa, nhpyra, nhpent
111 character*8 nhvois, nhsupe, nhsups
116 parameter ( nbmess = 10 )
117 character*80 texte(nblang,nbmess)
119 c 0.5. ==> initialisations
120 c ______________________________________________________________________
128 #ifdef _DEBUG_HOMARD_
129 write (ulsort,texte(langue,1)) 'Entree', nompro
133 texte(1,4) = '(/,''A l''''entree de '',a,'' :'',/)'
134 texte(1,5) = '(/,''Avant appel a '',a,'' :'')'
135 texte(1,6) = '(/,''Apres appel a '',a,'' :'')'
136 texte(1,7) = '(/,''Mauvais code pour '',a,'' : '',i8,/)'
137 texte(1,8) = '(''Le maillage est a corriger.'',/,27(''=''))'
138 texte(1,9) = '(''Action en cours : '',a)'
140 texte(2,4) = '(/,''At the beginning of '',a,'' :'',/)'
141 texte(2,5) = '(/,''Before calling '',a,'':'')'
142 texte(2,6) = '(/,''After calling '',a,'':'')'
143 texte(2,7) = '(/,''Bad code for '',a,'': '',i8,/)'
144 texte(2,8) = '(''This mesh is not correct.'',/,25(''=''))'
145 texte(2,9) = '(''Current action: '',a)'
149 #ifdef _DEBUG_HOMARD_
150 if ( avappr.ge.0 .and. avappr.le.2 ) then
151 write (ulsort,texte(langue,4+avappr)) nmprog
153 write (ulsort,texte(langue,7)) nmprog, avappr
155 write (ulsort,texte(langue,9)) action
161 c 2. recuperation des pointeurs
164 c 2.1. ==> structure generale
166 if ( codret.eq.0 ) then
168 call utnomh ( nomail,
170 > degre, maconf, homolo, hierar,
171 > rafdef, nbmane, typcca, typsfr, maextr,
174 > nhnoeu, nhmapo, nharet,
176 > nhtetr, nhhexa, nhpyra, nhpent,
178 > nhvois, nhsupe, nhsups,
179 > ulsort, langue, codret)
185 if ( codret.eq.0 ) then
187 call gmliat ( nhnoeu, 1, nbnoal, codre1 )
188 call gmadoj ( nhnoeu//'.Coor', pcoono, iaux, codre2 )
189 call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 )
191 codre0 = min ( codre1, codre2, codre3 )
192 codret = max ( abs(codre0), codret,
193 > codre1, codre2, codre3 )
195 if ( nbtrto.ne.0 ) then
197 call gmliat ( nhtria, 1, nbtral, codre1 )
198 call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre2 )
200 codre0 = min ( codre1, codre2 )
201 codret = max ( abs(codre0), codret,
206 if ( nbquto.ne.0 ) then
208 call gmliat ( nhquad, 1, nbqual, codre1 )
209 call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre2 )
211 codre0 = min ( codre1, codre2 )
212 codret = max ( abs(codre0), codret,
217 if ( nbteto.ne.0 ) then
219 call gmliat ( nhtetr, 1, nbteal, codre1 )
220 call gmliat ( nhtetr, 2, nbtaal, codre2 )
222 codre0 = min ( codre1, codre2 )
223 codret = max ( abs(codre0), codret,
226 #ifdef _DEBUG_HOMARD_
227 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
230 if ( nbtaal.gt.0 ) then
233 call utad02 ( iaux, nhtetr,
234 > phette, ptrite, jaux, jaux,
236 > jaux, pcotrt, jaux,
237 > jaux, jaux, parete,
238 > ulsort, langue, codret )
242 if ( nbheto.ne.0 ) then
244 call gmliat ( nhhexa, 1, nbheal, codre1 )
245 call gmliat ( nhhexa, 2, nbhaal, codre2 )
247 codre0 = min ( codre1, codre2 )
248 codret = max ( abs(codre0), codret,
251 #ifdef _DEBUG_HOMARD_
252 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
255 if ( nbhaal.gt.0 ) then
258 call utad02 ( iaux, nhhexa,
259 > phethe, pquahe, jaux, jaux,
261 > jaux, pcoquh, jaux,
262 > jaux, jaux, parehe,
263 > ulsort, langue, codret )
267 if ( nbpyto.ne.0 ) then
269 call gmliat ( nhpyra, 1, nbpyal, codre1 )
270 call gmliat ( nhpyra, 2, nbyaal, codre2 )
272 codre0 = min ( codre1, codre2 )
273 codret = max ( abs(codre0), codret,
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
280 if ( nbyaal.gt.0 ) then
283 call utad02 ( iaux, nhpyra,
284 > phetpy, pfacpy, jaux, jaux,
286 > jaux, pcofay, jaux,
287 > jaux, jaux, parepy,
288 > ulsort, langue, codret )
292 if ( nbpeto.ne.0 ) then
294 call gmliat ( nhpent, 1, nbpeal, codre1 )
295 call gmliat ( nhpent, 2, nbpaal, codre2 )
297 codre0 = min ( codre1, codre2 )
298 codret = max ( abs(codre0), codret,
301 #ifdef _DEBUG_HOMARD_
302 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
305 if ( nbpaal.gt.0 ) then
308 call utad02 ( iaux, nhpent,
309 > phetpe, pfacpe, jaux, jaux,
311 > jaux, pcofap, jaux,
312 > jaux, jaux, parepe,
313 > ulsort, langue, codret )
320 c 3. fichier de sortie du bilan
322 #ifdef _DEBUG_HOMARD_
323 write (ulsort,90002) '3. fichier sortie ; codret', codret
326 if ( codret.eq.0 ) then
328 saux15 = 'verif_'//action
331 if ( rafdef.eq.31 ) then
336 #ifdef _DEBUG_HOMARD_
337 write (ulsort,texte(langue,3)) 'UTULBI', nompro
339 call utulbi ( nuroul, nomflo, lnomfl,
340 > iaux, saux15, kaux, jaux,
341 > ulsort, langue, codret )
348 #ifdef _DEBUG_HOMARD_
349 write (ulsort,90002) '4. controles ; codret', codret
352 c 4.1. ==> les aretes
354 if ( codret.eq.0 ) then
356 #ifdef _DEBUG_HOMARD_
357 write (ulsort,texte(langue,3)) 'UTEARE', nompro
359 call uteare ( nbarto, nbnoto, imem(psomar),
360 > nmprog, avappr, nuroul,
361 > ulsort, langue, codret )
365 c 4.2. ==> les triangles
366 #ifdef _DEBUG_HOMARD_
367 write (ulsort,90002) '4.2. tria ; codret', codret
370 if ( codret.eq.0 ) then
372 if ( nbtrto.ne.0 ) then
374 #ifdef _DEBUG_HOMARD_
375 write (ulsort,texte(langue,3)) 'UTETRI', nompro
377 call utetri ( nbtrto, nbtral,
378 > imem(paretr), imem(psomar),
379 > nmprog, avappr, nuroul,
380 > ulsort, langue, codret )
386 c 4.3. ==> les quadrangles
387 #ifdef _DEBUG_HOMARD_
388 write (ulsort,90002) '4.3. quad ; codret', codret
391 if ( codret.eq.0 ) then
393 if ( nbquto.ne.0 ) then
395 #ifdef _DEBUG_HOMARD_
396 write (ulsort,texte(langue,3)) 'UTEQUA', nompro
398 call utequa ( nbquto, nbqual, nbnoal, sdim,
399 > rmem(pcoono), imem(psomar), imem(parequ),
400 > nmprog, avappr, nuroul,
401 > ulsort, langue, codret )
407 c 4.4. ==> les tetraedres
408 #ifdef _DEBUG_HOMARD_
409 write (ulsort,90002) '4.4. tetr ; codret', codret
412 if ( codret.eq.0 ) then
414 if ( nbteto.ne.0 ) then
416 iaux = nbteal - nbtaal
417 #ifdef _DEBUG_HOMARD_
418 write (ulsort,texte(langue,3)) 'UTETET', nompro
420 call utetet ( nbteto, iaux, nbtaal, nbtral,
421 > imem(psomar), imem(paretr),
422 > imem(ptrite), imem(pcotrt), imem(parete),
423 > nmprog, avappr, nuroul,
424 > ulsort, langue, codret )
430 c 4.5. ==> les hexaedres
431 #ifdef _DEBUG_HOMARD_
432 write (ulsort,90002) '4.5. hexa ; codret', codret
435 if ( codret.eq.0 ) then
437 if ( nbheto.ne.0 ) then
439 iaux = nbheal - nbhaal
440 #ifdef _DEBUG_HOMARD_
441 write (ulsort,texte(langue,3)) 'UTEHEX', nompro
443 call utehex ( nbheto, iaux, nbhaal, nbqual,
444 > imem(psomar), imem(parequ),
445 > imem(pquahe), imem(pcoquh), imem(parehe),
446 > nmprog, avappr, nuroul,
447 > ulsort, langue, codret )
453 c 4.6. ==> les pyramides
454 #ifdef _DEBUG_HOMARD_
455 write (ulsort,90002) '4.6. pyra ; codret', codret
458 if ( codret.eq.0 ) then
460 if ( nbpyto.ne.0 ) then
462 iaux = nbpyal - nbyaal
463 #ifdef _DEBUG_HOMARD_
464 write (ulsort,texte(langue,3)) 'UTEPYR', nompro
466 call utepyr ( nbpyto, iaux, nbyaal, nbtral,
467 > imem(psomar), imem(paretr),
468 > imem(pfacpy), imem(pcofay), imem(parepy),
469 > nmprog, avappr, nuroul,
470 > ulsort, langue, codret )
476 c 4.7. ==> les pentaedres
477 #ifdef _DEBUG_HOMARD_
478 write (ulsort,90002) '4.7. pent ; codret', codret
481 if ( codret.eq.0 ) then
483 if ( nbpeto.ne.0 ) then
485 iaux = nbpeal - nbpaal
486 #ifdef _DEBUG_HOMARD_
487 write (ulsort,texte(langue,3)) 'UTEPEN', nompro
489 call utepen ( nbpeto, iaux, nbpaal, nbqual,
492 > imem(pfacpe), imem(pcofap), imem(parepe),
493 > nmprog, avappr, nuroul,
494 > ulsort, langue, codret )
501 c 5. fermeture du fichier de sortie du bilan
503 #ifdef _DEBUG_HOMARD_
504 write (ulsort,90002) '5. fermeture ; codret', codret
507 if ( codret.eq.0 ) then
509 call gufeul ( nuroul , codret )
514 c 6. On impose un code de retour nul si c'est un maillage avec ajout
515 c de joint car par construction des mailles sont aplaties
517 #ifdef _DEBUG_HOMARD_
518 write (ulsort,90002) '6. impose ; codret', codret
521 if ( rafdef.eq.31 ) then
531 if ( codret.ne.0 ) then
535 write (nuroul,texte(langue,8))
536 write (ulsort,texte(langue,1)) 'Sortie', nompro
537 write (ulsort,texte(langue,2)) codret
541 #ifdef _DEBUG_HOMARD_
542 write (ulsort,texte(langue,1)) 'Sortie', nompro