1 subroutine utnc04 ( nbanci, arreca, arrecb,
4 > somare, hetare, np2are,
5 > merare, filare, insoar,
6 > coexar, narsho, narsca,
9 > ulsort, langue, codret )
10 c ______________________________________________________________________
14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
17 c aupres des huissiers de justice Simart et Lavoir a Clamart
18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
19 c aupres des huissiers de justice
20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
22 c HOMARD est une marque deposee d'Electricite de France
28 c ______________________________________________________________________
30 c UTilitaire - Non Conformite - phase 04
32 c ______________________________________________________________________
34 c . nom . e/s . taille . description .
35 c .____________________________________________________________________.
36 c . nbanci . e . 1 . nombre d'aretes de non conformite initiale .
37 c . . . . egal au nombre d'aretes recouvrant 2 autres.
38 c . arreca . es .2*nbanci. liste des aretes recouvrant une autre .
39 c . arrecb . es .2*nbanci. liste des aretes recouvertes par une autre .
40 c . nouare . e . nbarto . nouveau numero des aretes .
41 c . tabaux . a . * . tableau auxiliaire .
42 c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour.
43 c . . . . un noeud milieu .
44 c . somare . es .2*nbarto. numeros des extremites d'arete .
45 c . hetare . es . nbarto . historique de l'etat des aretes .
46 c . np2are . es . nbarto . noeud milieux des aretes .
47 c . merare . es . nbarto . mere des aretes .
48 c . filare . es . nbarto . premiere fille des aretes .
49 c . insoar . es . nbarto . information sur les sommets des aretes .
50 c . coexar . es . nbarto*. codes de conditions aux limites portants .
51 c . . . nctfar . sur les aretes .
52 c . narsho . es . rsarac . numero des aretes dans HOMARD .
53 c . narsca . es . rsarto . numero des aretes du calcul .
54 c . ngenar . es . nbarto . nombre de generations au-dessus des aretes .
55 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
56 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
57 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
58 c . langue . e . 1 . langue des messages .
59 c . . . . 1 : francais, 2 : anglais .
60 c . codret . es . 1 . code de retour des modules .
61 c . . . . 0 : pas de probleme .
62 c ______________________________________________________________________
65 c 0. declarations et dimensionnement
68 c 0.1. ==> generalites
74 parameter ( nompro = 'UTNC04' )
94 integer arreca(2*nbanci), arrecb(2*nbanci)
95 integer nouare(0:nbarto)
97 integer arenoe(nbnoto)
98 integer somare(2,nbarto), hetare(nbarto), np2are(nbarto)
99 integer filare(nbarto), merare(nbarto), insoar(nbarto)
100 integer coexar(nbarto,nctfar)
101 integer narsho(rsarac), narsca(rsarto)
102 integer ngenar(nbarto)
103 integer aretri(nbtrto,3)
104 integer arequa(nbquto,4)
106 integer ulsort, langue, codret
108 c 0.4. ==> variables locales
110 integer iaux, jaux, kaux
116 parameter ( nbmess = 10 )
117 character*80 texte(nblang,nbmess)
119 c 0.5. ==> initialisations
120 c ______________________________________________________________________
130 #ifdef _DEBUG_HOMARD_
131 write (ulsort,texte(langue,1)) 'Entree', nompro
139 c 2. A-t-on vraiment besoin ?
143 do 21 , iaux = 1 , nbarto
145 if ( nouare(iaux).ne.iaux ) then
146 cgn print *,iaux, nouare(iaux)
154 cgn print *, 'afaire = ',afaire
159 c 3. Prise en compte du changement de numerotation des aretes
160 c dans les tableaux de reperage des non conformites
164 do 31 , iaux = 1 , ifin
165 cgn if ( iaux.eq.10 .or. iaux.eq.15 ) then
166 cgn write (ulsort,*) 'arreca(',iaux,') = ',arreca(iaux)
167 cgn write (ulsort,*) 'arrecb(',iaux,') = ',arrecb(iaux)
168 cgn write (ulsort,*)'nouare(',arreca(iaux),') = ',nouare(arreca(iaux))
169 cgn write (ulsort,*)'nouare(',arrecb(iaux),') = ',nouare(arrecb(iaux))
172 arreca(iaux) = nouare(arreca(iaux))
173 arrecb(iaux) = nouare(arrecb(iaux))
178 c 4. Renumerotation des aretes liees aux noeuds
181 do 41 , iaux = 1 , nbnoto
183 arenoe(iaux) = nouare(arenoe(iaux))
188 c 5. Renumerotation des caracteristiques liees aux aretes
192 if ( codret.eq.0 ) then
196 #ifdef _DEBUG_HOMARD_
197 write (ulsort,texte(langue,3)) 'UTCHNU - somare', nompro
199 call utchnu ( iaux, nbarto, nouare,
200 > jaux, nbarto, somare,
202 > ulsort, langue, codret )
206 c 5.2. ==> Historiques de l'etat
208 if ( codret.eq.0 ) then
212 #ifdef _DEBUG_HOMARD_
213 write (ulsort,texte(langue,3)) 'UTCHNU - hetare', nompro
215 call utchnu ( iaux, nbarto, nouare,
216 > jaux, nbarto, hetare,
218 > ulsort, langue, codret )
222 c 5.3. ==> Eventuel noeud milieu
224 if ( degre.eq.2 ) then
226 if ( codret.eq.0 ) then
230 #ifdef _DEBUG_HOMARD_
231 write (ulsort,texte(langue,3)) 'UTCHNU - np2are', nompro
233 call utchnu ( iaux, nbarto, nouare,
234 > jaux, nbarto, np2are,
236 > ulsort, langue, codret )
242 c 5.4. ==> Eventuelle information sur les sommets
244 if ( nbelig.gt.0 ) then
246 if ( codret.eq.0 ) then
250 #ifdef _DEBUG_HOMARD_
251 write (ulsort,texte(langue,3)) 'UTCHNU - insoar', nompro
253 call utchnu ( iaux, nbarto, nouare,
254 > jaux, nbarto, insoar,
256 > ulsort, langue, codret )
262 c 5.5. ==> Code externe sur les conditions aux limites
264 if ( codret.eq.0 ) then
267 #ifdef _DEBUG_HOMARD_
268 write (ulsort,texte(langue,3)) 'UTCHNU - coexar', nompro
270 call utchnu ( iaux, nbarto, nouare,
271 > nbarto, nctfar, coexar,
273 > ulsort, langue, codret )
279 if ( codret.eq.0 ) then
281 do 561 , iaux = 1 , nbarto
287 do 562 , iaux = 1 , kaux
289 if ( filare(jaux).eq.0 ) then
290 filare(jaux) = arrecb(iaux)
293 filare(jaux) = min(arrecb(iaux),filare(jaux))
295 merare(arrecb(iaux)) = jaux
300 cgn print *,filare(jaux),merare(jaux)
303 c 5.7. ==> Eventuelle renumerotation avec le code de calcul
305 if ( rsarac.gt.0 ) then
307 if ( codret.eq.0 ) then
311 #ifdef _DEBUG_HOMARD_
312 write (ulsort,texte(langue,3)) 'UTCHNU - narsho', nompro
314 call utchnu ( iaux, nbarto, nouare,
315 > jaux, rsarac, narsho,
317 > ulsort, langue, codret )
323 if ( rsarto.gt.0 ) then
325 if ( codret.eq.0 ) then
329 #ifdef _DEBUG_HOMARD_
330 write (ulsort,texte(langue,3)) 'UTCHNU - narsca', nompro
332 call utchnu ( iaux, nbarto, nouare,
333 > jaux, rsarto, narsca,
335 > ulsort, langue, codret )
341 c 5.8. ==> Nombre de generations de l'ascendance
343 if ( codret.eq.0 ) then
347 #ifdef _DEBUG_HOMARD_
348 write (ulsort,texte(langue,3)) 'UTCHNU - ngenar', nompro
350 call utchnu ( iaux, nbarto, nouare,
351 > jaux, nbarto, ngenar,
353 > ulsort, langue, codret )
358 c 6. Renumerotation des aretes definissant les triangles
361 if ( nbtrto.gt.0 ) then
363 if ( codret.eq.0 ) then
365 #ifdef _DEBUG_HOMARD_
366 write (ulsort,texte(langue,3)) 'UTCHNU - aretri', nompro
370 call utchnu ( iaux, nbarto, nouare,
371 > nbtrto, jaux, aretri,
373 > ulsort, langue, codret )
377 cgn print *,(aretri(jaux,iaux),iaux=1,3)
383 c 7. Renumerotation des aretes definissant les quadrangles
386 if ( nbquto.gt.0 ) then
388 if ( codret.eq.0 ) then
390 #ifdef _DEBUG_HOMARD_
391 write (ulsort,texte(langue,3)) 'UTCHNU - arequa', nompro
395 call utchnu ( iaux, nbarto, nouare,
396 > nbquto, jaux, arequa,
398 > ulsort, langue, codret )
402 cgn print *,(arequa(jaux,iaux),iaux=1,4)
413 if ( codret.ne.0 ) then
417 write (ulsort,texte(langue,1)) 'Sortie', nompro
418 write (ulsort,texte(langue,2)) codret
422 #ifdef _DEBUG_HOMARD_
423 write (ulsort,texte(langue,1)) 'Sortie', nompro