1 subroutine cmmisa ( 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 Creation du Maillage - MISe A jour de la structure de donnees
26 c ______________________________________________________________________
28 c but : mise a jour de la structure de donnees pour le maillage adapte
30 c - reconstruction des voisinages
31 c - traitement des homologues
32 c ______________________________________________________________________
34 c . nom . e/s . taille . description .
35 c .____________________________________________________________________.
36 c . nomail . e . ch8 . nom de l'objet contenant le maillage .
37 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
38 c . taetco . e . lgetco . tableau de l'etat courant .
39 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
40 c . langue . e . 1 . langue des messages .
41 c . . . . 1 : francais, 2 : anglais .
42 c . codret . es . 1 . code de retour des modules .
43 c . . . . 0 : pas de probleme .
44 c ______________________________________________________________________
48 c 0. declarations et dimensionnement
51 c 0.1. ==> generalites
57 parameter ( nompro = 'CMMISA' )
85 integer taetco(lgetco)
87 integer ulsort, langue, codret
89 c 0.4. ==> variables locales
93 integer nretap, nrsset
96 integer codre0, codre1, codre2, codre3, codre4
97 integer codre5, codre6, codre7, codre8
98 integer phetno, pcoono
99 integer psomar, phetar, pfilar, pnp2ar
100 integer pposif, pfacar
101 integer phettr, paretr, pfiltr, ppertr, pnivtr
102 integer phetqu, parequ, pfilqu, pperqu, pnivqu
103 integer ptrite, phette, pfilte
104 integer pquahe, phethe, pfilhe
105 integer pfacpy, phetpy, pfilpy
106 integer pfacpe, phetpe, pfilpe
107 integer adhono, adhoar, adhotr, adhoqu
110 integer nvacar, nvactr, nvacqu, nvacte, nvache, nvacpy, nvacpe
111 integer vofaar, vovofa
115 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
116 character*8 nhtetr, nhhexa, nhpyra, nhpent
118 character*8 nhvois, nhsupe, nhsups
122 parameter ( nbmess = 11 )
123 character*80 texte(nblang,nbmess)
125 c 0.5. ==> initialisations
126 c ______________________________________________________________________
134 c=======================================================================
135 if ( codava.eq.0 ) then
136 c=======================================================================
138 c 1.1. ==> le debut des mesures de temps
143 c 1.3. ==> les messages
147 #ifdef _DEBUG_HOMARD_
148 write (ulsort,texte(langue,1)) 'Entree', nompro
153 > '(/,a6,'' MISE A JOUR DES DONNEES DU MAILLAGE ADAPTE'')'
154 texte(1,5) = '(49(''=''),/)'
156 texte(1,6) = '(5x,''Nombre de noeuds :'',i10)'
157 texte(1,7) = '(5x,''Nombre de '',a,'' actifs :'',i10)'
158 texte(1,8) = '(5x,''Niveau minimum des '',a,'':'',i10)'
159 texte(1,9) = '(5x,''Niveau minimum des '',a,'':'',i10,''.5'')'
160 texte(1,10) = '(5x,''Niveau maximum des '',a,'':'',i10)'
161 texte(1,11) = '(5x,''Niveau maximum des '',a,'':'',i10,''.5'')'
163 texte(2,4) = '(/,a6,'' UPDATING OF DATA ON ADAPTED MESH'')'
164 texte(2,5) = '(39(''=''),/)'
165 texte(2,6) = '(5x,''Number of nodes :'',i10)'
166 texte(2,7) = '(5x,''Number of active '',a,'':'',i10)'
167 texte(2,8) = '(5x,''Minimum level of '',a,'':'',i10)'
168 texte(2,9) = '(5x,''Minimum level of '',a,'':'',i10,''.5'')'
169 texte(2,10) = '(5x,''Maximum level of '',a,'':'',i10)'
170 texte(2,11) = '(5x,''Maximum level of '',a,'':'',i10,''.5'')'
174 c 1.4. ==> le numero de sous-etape
177 nrsset = taetco(2) + 1
180 call utcvne ( nretap, nrsset, saux, iaux, codret )
184 write ( ulsort,texte(langue,4)) saux
185 write ( ulsort,texte(langue,5))
188 c 2. recuperation des pointeurs
191 c 2.1. ==> structure generale
193 if ( codret.eq.0 ) then
195 #ifdef _DEBUG_HOMARD_
196 write (ulsort,texte(langue,3)) 'UTNOMH', nompro
198 call utnomh ( nomail,
200 > degre, maconf, homolo, hierar,
201 > rafdef, nbmane, typcca, typsfr, maextr,
204 > nhnoeu, nhmapo, nharet,
206 > nhtetr, nhhexa, nhpyra, nhpent,
208 > nhvois, nhsupe, nhsups,
209 > ulsort, langue, codret)
214 #ifdef _DEBUG_HOMARD_
215 write (ulsort,90002) '2.2. tableaux ; codret', codret
218 if ( codret.eq.0 ) then
221 if ( homolo.ge.1 ) then
224 #ifdef _DEBUG_HOMARD_
225 write (ulsort,texte(langue,3)) 'UTAD01', nompro
227 call utad01 ( iaux, nhnoeu,
230 > pcoono, jaux, adhono, jaux,
231 > ulsort, langue, codret )
234 if ( degre.eq.2 ) then
237 if ( homolo.ge.2 ) then
240 #ifdef _DEBUG_HOMARD_
241 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
243 call utad02 ( iaux, nharet,
244 > phetar, psomar, pfilar, jaux,
246 > jaux, pnp2ar, jaux,
247 > jaux, adhoar, jaux,
248 > ulsort, langue, codret )
250 if ( nouvtr.ne.0 ) then
253 if ( homolo.ge.3 ) then
256 #ifdef _DEBUG_HOMARD_
257 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
259 call utad02 ( iaux, nhtria,
260 > phettr, paretr, pfiltr, ppertr,
262 > pnivtr, jaux, jaux,
263 > jaux, adhotr, jaux,
264 > ulsort, langue, codret )
268 if ( nouvqu.ne.0 ) then
271 if ( homolo.ge.3 ) then
274 #ifdef _DEBUG_HOMARD_
275 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
277 call utad02 ( iaux, nhquad,
278 > phetqu, parequ, pfilqu, pperqu,
280 > pnivqu, jaux, jaux,
281 > jaux, adhoqu, jaux,
282 > ulsort, langue, codret )
286 if ( nouvte.ne.0 ) then
289 #ifdef _DEBUG_HOMARD_
290 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
292 call utad02 ( iaux, nhtetr,
293 > phette, ptrite, pfilte, jaux,
297 > ulsort, langue, codret )
301 if ( nouvhe.ne.0 ) then
304 #ifdef _DEBUG_HOMARD_
305 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
307 call utad02 ( iaux, nhhexa,
308 > phethe, pquahe, pfilhe, jaux,
312 > ulsort, langue, codret )
316 if ( nouvpy.ne.0 ) then
319 #ifdef _DEBUG_HOMARD_
320 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
322 call utad02 ( iaux, nhpyra,
323 > phetpy, pfacpy, pfilpy, jaux,
327 > ulsort, langue, codret )
331 if ( nouvpe.ne.0 ) then
334 #ifdef _DEBUG_HOMARD_
335 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
337 call utad02 ( iaux, nhpent,
338 > phetpe, pfacpe, pfilpe, jaux,
342 > ulsort, langue, codret )
349 c 3. comptage des entites actives du maillage
351 #ifdef _DEBUG_HOMARD_
352 write (ulsort,90002) '3. comptage entites active ; codret', codret
355 if ( codret.eq.0 ) then
357 #ifdef _DEBUG_HOMARD_
358 write (ulsort,texte(langue,3)) 'CMCACT', nompro
360 call cmcact ( imem(phetno),
362 > imem(pfiltr), imem(pnivtr),
363 > imem(pfilqu), imem(pnivqu),
364 > imem(pfilte), imem(pfilhe),
365 > imem(pfilpy), imem(pfilpe),
366 > nvacar, nvactr, nvacqu,
367 > nvacte, nvache, nvacpy, nvacpe,
368 > ulsort, langue, codret )
373 c 4. mise a jour des nombres d'entites du maillage adapte
375 #ifdef _DEBUG_HOMARD_
376 write (ulsort,90002) '4. mise a jour des nombres ; codret', codret
380 if ( codret.eq.0 ) then
382 c 4.1. commun "nombno" --> noeuds
384 c nbpnho = mis a jour en 5.1
385 c nbnois = non modifie
386 c nbnoei = non modifie
387 c nbnoma = non modifie
388 c nbnomp = non modifie
389 cgn write (ulsort,90002) 'nouvno,provp1',nouvno,provp1
390 cgn write (ulsort,90002) 'nouvp2,nouvim',nouvp2,nouvim
391 cgn write (ulsort,90002) 'nbnoei,nbnois',nbnoei,nbnois
392 nbnop1 = nouvno - nouvp2 - nouvim - nbnomp - nbnoei - nbnois
396 nbnoin = provp1 - nbquq5/3
397 cgn write (ulsort,90002) 'p1,p2,im,to',nbnop1,nbnop2,nbnoim,nbnoto
399 c 4.2. commun "nombar" --> aretes
402 nbarde = permar - nbarma
403 c nbart2 = calcule dans utplco
404 c nbarq2 = calcule dans utplco
405 c nbarq3 = calcule dans utplco
406 c nbarq5 = calcule dans utplco
407 c nbpaho = mis a jour en 5.1
408 c nbarin = calcule dans utplco
409 c nbarma = non modifie
412 cgn write (ulsort,*) nbarac,nbarde,nbarpe,nbarto
414 c 4.3. commun "nombtr" --> triangles
417 nbtrde = permtr - nbtrma
418 c nbtrt2 = calcule dans utplco
419 c nbtrq3 = calcule dans utplco
420 c nbptho = mis a jour en 5.1
421 c nbtrhc = calcule dans utplco
422 c nbtrpc = calcule dans utplco
423 c nbtrtc = calcule dans utplco
424 c nbtrma = non modifie
427 cgn write (ulsort,*) nbtrac,nbtrde,nbtrpe,nbtrto
429 c 4.4. commun "nombqu" --> quadrangles
432 nbqude = permqu - nbquma
433 c nbquq2 = calcule dans utplco
434 c nbquq5 = calcule dans utplco
437 cgn write (ulsort,*) nbquac,nbqude,nbqupe,nbquto
439 c 4.5. commun "nombte" --> tetraedres
442 c nbtea2 = calcule dans utplco
443 c nbtea4 = calcule dans utplco
444 nbtede = permte - nbtema
445 c nbtef4 = calcule dans utplco
446 c nbtema = non modifie
450 nbtecf = nbteto - nbteca
451 cgn write (ulsort,90002) 'nbteac,nbtepe,nbteto,nbtecf,nbteca',
452 cgn > nbteac,nbtepe,nbteto,nbtecf,nbteca
454 c 4.6. commun "nombhe" --> hexaedres
457 nbhede = permhe - nbhema
458 c nbhema = non modifie
462 nbhecf = nbheto - nbheca
463 cgn write (ulsort,90002) 'nbheac,nbhepe,nbheto,nbhecf,nbheca',
464 cgn > nbheac,nbhepe,nbheto,nbhecf,nbheca
466 c 4.7. commun "nombpy" --> pyramides
469 c nbpyma = non modifie
473 nbpycf = nbpyto - nbpyca
474 cgn write (ulsort,90002) 'nbpyac,nbpype,nbpyto,nbpycf,nbpyca',
475 cgn > nbpyac,nbpype,nbpyto,nbpycf,nbpyca
477 c 4.8. commun "nombpe" --> pentaedres
480 nbpede = permpe - nbpema
481 c nbpema = non modifie
486 nbpecf = nbpeto - nbpeca
487 cgn write (ulsort,90002) 'nbpeac,nbpepe,nbpeto,nbpecf,nbpeca',
488 cgn > nbpeac,nbpepe,nbpeto,nbpecf,nbpeca
492 call gmecat ( nhnoeu, 1 , nbnoto, codre1 )
493 call gmecat ( nharet, 1 , nbarto, codre2 )
494 call gmecat ( nhtria, 1 , nbtrto, codre3 )
495 call gmecat ( nhquad, 1 , nbquto, codre4 )
496 call gmecat ( nhtetr, 1 , nbteto, codre5 )
497 call gmecat ( nhhexa, 1 , nbheto, codre6 )
498 call gmecat ( nhpyra, 1 , nbpyto, codre7 )
499 call gmecat ( nhpent, 1 , nbpeto, codre8 )
501 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
502 > codre6, codre7, codre8 )
503 codret = max ( abs(codre0), codret,
504 > codre1, codre2, codre3, codre4, codre5,
505 > codre6, codre7, codre8 )
507 call gmecat ( nhtetr, 2, nbteca, codre1 )
508 call gmecat ( nhhexa, 2, nbheca, codre2 )
509 call gmecat ( nhpyra, 2, nbpyca, codre3 )
510 call gmecat ( nhpent, 2, nbpeca, codre4 )
512 codre0 = min ( codre1, codre2, codre3, codre4 )
513 codret = max ( abs(codre0), codret,
514 > codre1, codre2, codre3, codre4 )
519 c 5. determination des voisinages
521 #ifdef _DEBUG_HOMARD_
522 write (ulsort,90002) '5. voisinages ; codret', codret
525 c 5.1. ==> determination des faces voisines des aretes
527 if ( codret.eq.0 ) then
531 #ifdef _DEBUG_HOMARD_
532 write (ulsort,texte(langue,3)) 'UTVGFA', nompro
535 call utvgfa ( nhvois, nharet, nhtria, nhquad,
537 > nbfaar, pposif, pfacar,
538 > ulsort, langue, codret )
542 #ifdef _DEBUG_HOMARD_
543 if ( codret.eq.0 ) then
545 write (ulsort,texte(langue,3)) 'UTVERI_UTVGFA_apres', nompro
546 call utveri ( 'adap ', nomail, 'UTVGFA', iaux,
547 > ulsort, langue, codret )
551 c 5.2. ==> determination des volumes voisins des faces
553 if ( codret.eq.0 ) then
557 #ifdef _DEBUG_HOMARD_
558 write (ulsort,texte(langue,3)) 'UTVGVF', nompro
561 call utvgvf ( nhvois, nhtria, nhquad,
562 > nhtetr, nhhexa, nhpyra, nhpent,
564 > ulsort, langue, codret)
568 #ifdef _DEBUG_HOMARD_
569 if ( codret.eq.0 ) then
571 write (ulsort,texte(langue,3)) 'UTVERI_UTVGVF_apres', nompro
572 call utveri ( 'adap ', nomail, 'UTVGVF', iaux,
573 > ulsort, langue, codret )
578 c 6. mise a jour eventuelle pour les homologues
580 #ifdef _DEBUG_HOMARD_
581 write (ulsort,90002) '6. homologues ; codret', codret
584 if ( homolo.ne.0 ) then
586 if ( codret.eq.0 ) then
588 c 6.1. ==> comptage des entites du maillage concernees par une
589 c condition homologue et mise a jour des tables
590 c provisoires de correspondance
592 #ifdef _DEBUG_HOMARD_
593 write (ulsort,texte(langue,3)) 'CMHOMO', nompro
596 > imem(adhono), imem(adhoar), imem(adhotr), imem(adhoqu),
597 > imem(psomar), imem(pfilar), imem(phetar), imem(pnp2ar),
598 > imem(paretr), imem(pfiltr), imem(phettr),
599 > imem(parequ), imem(pfilqu), imem(phetqu),
600 > ulsort, langue, codret )
607 c 7. mise a jour eventuelle pour les non conformites
609 #ifdef _DEBUG_HOMARD_
610 write (ulsort,90002) '7. maj non-conformite ; codret', codret
613 if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then
615 if ( codret.eq.0 ) then
617 #ifdef _DEBUG_HOMARD_
618 write (ulsort,texte(langue,3)) 'UTNC08', nompro
620 call utnc08 ( nharet, nhtria, nhquad, nhvois,
622 > ulsort, langue, codret )
626 #ifdef _DEBUG_HOMARD_
627 if ( codret.eq.0 ) then
628 write (ulsort,texte(langue,3)) 'UTVERI_UTNC08_apres', nompro
630 call utveri ( 'adap ', nomail, 'UTNC08', iaux,
631 > ulsort, langue, codret )
640 #ifdef _DEBUG_HOMARD_
641 write (ulsort,90002) '8. Impressions ; codret', codret
644 if ( codret.eq.0 ) then
646 write(ulsort,texte(langue,6)) nbnoto
647 write(ulsort,texte(langue,7)) mess14(langue,3,1), nbarac
648 if ( nbtrto.ne.0 ) then
649 write(ulsort,texte(langue,7)) mess14(langue,3,2), nbtrac
651 if ( nbquto.ne.0 ) then
652 write(ulsort,texte(langue,7)) mess14(langue,3,4), nbquac
654 if ( nbteto.ne.0 ) then
655 write(ulsort,texte(langue,7)) mess14(langue,3,3), nbteac
657 if ( nbheto.ne.0 ) then
658 write(ulsort,texte(langue,7)) mess14(langue,3,6), nbheac
660 if ( nbpyto.ne.0 ) then
661 write(ulsort,texte(langue,7)) mess14(langue,3,5), nbpyac
663 if ( nbpeto.ne.0 ) then
664 write(ulsort,texte(langue,7)) mess14(langue,3,7), nbpeac
666 if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then
667 if ( nbquto.eq.0 ) then
668 saux14 = mess14(langue,3,2)
669 elseif ( nbtrto.eq.0 ) then
670 saux14 = mess14(langue,3,4)
672 saux14 = mess14(langue,3,8)
674 iaux = mod(niincf,10)
675 if ( iaux.ne.0 ) then
676 if ( nivinf.le.((niincf-5)/10) ) then
680 if ( iaux.eq.0 ) then
681 write (ulsort,texte(langue,8)) saux14, nivinf
683 write (ulsort,texte(langue,9)) saux14, (niincf-5)/10
685 iaux = mod(nisucf,10)
686 if ( iaux.eq.0 ) then
687 write (ulsort,texte(langue,10)) saux14, nivsup
689 write (ulsort,texte(langue,11)) saux14, (nisucf-5)/10
699 c 9.1. ==> message si erreur
701 if ( codret.ne.0 ) then
705 write (ulsort,texte(langue,1)) 'Sortie', nompro
706 write (ulsort,texte(langue,2)) codret
710 c 9.2. ==> fin des mesures de temps de la section
714 c=======================================================================
716 c=======================================================================
718 #ifdef _DEBUG_HOMARD_
719 write (ulsort,texte(langue,1)) 'Sortie', nompro