1 subroutine utnc13 ( option,
2 > nbnoct, trreca, trrecb,
3 > nbnocq, qureca, qurecb,
4 > arequa, filqua, perqua,
7 > ulsort, langue, codret )
8 c ______________________________________________________________________
12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
15 c aupres des huissiers de justice Simart et Lavoir a Clamart
16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
17 c aupres des huissiers de justice
18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
20 c HOMARD est une marque deposee d'Electricite de France
26 c ______________________________________________________________________
28 c UTilitaire - Non Conformite - phase 13
30 c On change les numeros des faces concernees par les non-conformites
31 c . les faces recouvrantes sont mises au debut.
32 c . les faces recouvertes sont mises a la fin, en les regroupant
34 c ______________________________________________________________________
36 c . nom . e/s . taille . description .
37 c .____________________________________________________________________.
38 c . option . e . 1 . option de l'operation de renumerotation .
39 c . . . . 1 : on enleve des nbnocq premieres places .
40 c . . . . les faces recouvertes .
41 c . . . . 2 : on met aux nbnocq premieres places les .
42 c . . . . faces recouvrantes .
43 c . . . . 3 : on regroupe par fratries les faces .
44 c . . . . recouvertes .
45 c . nbnoct . e . 1 . nombre de non conformites de quadrangles .
46 c . trreca . s .4*nbnoct. liste des triangles recouvrant un autre .
47 c . trrecb . s .4*nbnoct. liste des triangles recouverts par un autre.
48 c . nbnocq . e . 1 . nombre de non conformites de quadrangles .
49 c . qureca . e .4*nbnocq. liste des quad. recouvrant un autre .
50 c . qurecb . e .4*nbnocq. liste des quad. recouverts par un autre .
51 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
52 c . filqua . e . nbquto . premier fils des quadrangles .
53 c . perqua . e . nbquto . pere des quadrangles .
54 c . filare . e . nbarto . premiere fille des aretes .
55 c . nouqua . s . nbquto . nouveau numero des quadrangles .
56 c . tabaux . a .5*nbnocq. tableau auxiliaire .
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 = 'UTNC13' )
90 integer nbnoct, trreca(4*nbnoct), trrecb(4*nbnoct)
91 integer nbnocq, qureca(4*nbnocq), qurecb(4*nbnocq)
92 integer arequa(nbquto,4)
93 integer filqua(nbquto), perqua(nbquto)
94 integer filare(nbarto)
95 integer nouqua(0:nbquto)
98 integer ulsort, langue, codret
100 c 0.4. ==> variables locales
102 integer iaux, jaux, kaux, laux, maux
105 integer lequa1, lequag, lequad
106 integer lefils(4), quangl(4)
108 integer f1ai, f2ai, f1aim1, f2aim1
114 parameter ( nbmess = 20 )
115 character*80 texte(nblang,nbmess)
117 c 0.5. ==> initialisations
118 c ______________________________________________________________________
128 #ifdef _DEBUG_HOMARD_
129 write (ulsort,texte(langue,1)) 'Entree', nompro
134 > '(''Nombre de paquets de 4 '',a,'' non-conformes :'',i10))'
135 texte(1,5) = '(''Decalage des quadrangles recouverts'')'
136 texte(1,6) = '(''Renumerotation des quadrangles recouvrants'')'
137 texte(1,7) = '(''Regroupement des quadrangles recouverts'')'
138 texte(1,8) = '(''Examen du '',a,'' numero'',i10)'
139 texte(1,9) = '(''.. couvert par le '',a,'' numero'',i10)'
140 texte(1,10) = '(''.. couvrant les '',a,'' numero'',4i10)'
141 texte(1,11) = '(''dont les '',a,'' sont :'',4i10)'
144 > '(''Number of packs of 4 non-conformal '',a,'' :'',i10))'
145 texte(2,5) = '(''Shift of covered edges'')'
146 texte(2,6) = '(''Renumbering of covering edges'')'
147 texte(2,7) = '(''Gathering of covered edges'')'
148 texte(2,8) = '(''Examination of '',a,'' #'',i10)'
149 texte(2,9) = '(''.. covered by '',a,'' #'',i10)'
150 texte(2,10) = '(''.. covering '',a,'' #'',4i10)'
151 texte(2,11) = '(''with '',a,'' # :'',4i10)'
155 #ifdef _DEBUG_HOMARD_
156 write (ulsort,texte(langue,4)) mess14(langue,3,2), nbnoct
157 write (ulsort,texte(langue,4)) mess14(langue,3,4), nbnocq
158 write (ulsort,texte(langue,4+option))
161 c 1.2. ==> Aucune renumerotation au depart
163 do 12 , iaux = 0 , nbquto
168 c 2. option numero 1 : plus aucune face recouverte ne doit se trouver
169 c parmi les nbnocq premieres
170 c On examine chacune des faces recouvertes. Si son numero
171 c est inferieur a nbnocq, on la permute avec une face de numero
172 c superieur a nbnocq et qui n'est pas une recouverte
175 if ( option.eq.1 ) then
177 if ( codret.eq.0 ) then
181 do 21 , iaux = 1 , ifin
183 if ( codret.eq.0 ) then
185 lequad = qurecb(iaux)
187 if ( lequad.le.nbnocq ) then
189 #ifdef _DEBUG_HOMARD_
190 write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
192 do 211 , jaux = debut, nbquto
193 if ( perqua(jaux).eq.0 ) then
203 nouqua(kaux) = lequad
204 nouqua(lequad) = kaux
206 cgn write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
207 cgn write (ulsort,*) lequad,' devient', kaux
218 c 3. option numero 2 : les faces recouvrantes sont mises aux nbnocq
220 c On examine chacune des faces recouvrantes dans la liste qureca. Si
221 c son numero est superieur a nbnocq, on la permute avec une face
222 c de numero inferieur a nbnocq et qui n'est pas une recouvrante. Il
223 c faut noter que chaque face apparait plusieurs fois. Il ne faut la
224 c permuter que la 1ere fois : cela se repere avec son nouveau numero
227 elseif ( option.eq.2 ) then
229 if ( codret.eq.0 ) then
233 do 31 , iaux = 1 , ifin
235 if ( codret.eq.0 ) then
237 lequad = qureca(iaux)
239 if ( lequad.gt.nbnocq .and. nouqua(lequad).eq.lequad ) then
241 #ifdef _DEBUG_HOMARD_
242 write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
244 do 311 , jaux = debut, nbnocq
245 if ( filqua(jaux).eq.0 ) then
255 nouqua(kaux) = lequad
256 nouqua(lequad) = kaux
258 cgn write (ulsort,*) lequad,' devient', kaux
269 c 4. option numero 3 : les faces recouvertes sont regroupees par
273 elseif ( option.eq.3 ) then
275 c 4.1. ==> Regroupement des fils adoptifs et de leur pere
276 c 4.1.1. ==> Aucun regroupement au depart
278 do 41 , iaux = 1 , nbnocq
288 c 4.1.2. ==> On regroupe les fils adoptifs et leur pere
292 do 42 , iaux = 1 , ifin
294 lequa1 = qurecb(iaux)
295 lequag = qureca(iaux)
297 #ifdef _DEBUG_HOMARD_
298 write (ulsort,texte(langue,8)) mess14(langue,1,4), lequa1
299 write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
302 c on cherche si on a deja place le quadrangle jumeau de lequa1
303 c . si oui, on place le quadrangle courant en position 3, 4 ou 5
304 c . si non, on place le quadrangle pere en position 1 et le fils
307 do 422 , jaux = 1, lgtab
309 if ( tabaux(1,jaux).eq.lequag ) then
310 if ( tabaux(3,jaux).eq.0 ) then
311 tabaux(3,jaux) = lequa1
312 elseif ( tabaux(4,jaux).eq.0 ) then
313 tabaux(4,jaux) = lequa1
315 tabaux(5,jaux) = lequa1
323 tabaux(1,lgtab) = lequag
324 tabaux(2,lgtab) = lequa1
327 cgn print *,'lgtab = ', lgtab
329 c 4.3. ==> Les quadrangles recouverts : on les place par 2 ou 4
330 c On cherche en partant de la fin de la numerotation 2 ou 4 places
331 c contigues qui ne soient pas deja des quadrangles recouverts.
332 c Remarque : ce ne peut pas etre des recouvrants car on les
333 c a mis au debut au cours du passage option=1
336 do 43 , iaux = 1 , lgtab
338 if ( codret.eq.0 ) then
340 lequag = tabaux(1,iaux)
341 lefils(1) = tabaux(2,iaux)
342 lefils(2) = tabaux(3,iaux)
343 lefils(3) = tabaux(4,iaux)
344 lefils(4) = tabaux(5,iaux)
346 #ifdef _DEBUG_HOMARD_
347 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1)
348 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2)
349 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3)
350 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4)
351 write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
354 c Pour 2 fils, on ne fait rien car pas prevu aujourd'hui
355 if ( lefils(3).eq.0 ) then
357 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1)
358 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2)
359 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3)
360 write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4)
361 write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
366 do 432 , jaux = debut, nbquto
367 if ( perqua(jaux ).eq.0 .and. perqua(jaux+1).eq.0 .and.
368 > perqua(jaux+2).eq.0 .and. perqua(jaux+3).eq.0 ) then
378 #ifdef _DEBUG_HOMARD_
379 write (ulsort,*) 'kaux = ', kaux
382 c 4.4. ==> Dans le cas de 4 fils, on doit reperer dans quel angle du
383 c pere se situe chacun d'eux pour respecter la convention
386 if ( codret.eq.0 ) then
390 if ( codret.eq.0 ) then
392 c 4.4.1. ==> Les 2 aretes j et j-1 du pere ainsi que leurs filles
394 arei = arequa(lequag,jaux)
398 jauxm1 = per1a4(-1,jaux)
399 areim1 = arequa(lequag,jauxm1)
400 f1aim1 = filare(areim1)
403 c 4.4.2. ==> Lequel des 4 quadrangles fils est dans cet angle ?
405 do 442 , laux = 1 , 4
407 c 4.4.2.1. ==> Les aretes du laux-eme fils
409 do 4421 , maux = 1 , 4
410 aretf(maux) = arequa(lefils(laux),maux)
413 #ifdef _DEBUG_HOMARD_
414 write (ulsort,texte(langue,8))
415 > mess14(langue,1,4)//'fils', lefils(laux)
416 write (ulsort,texte(langue,11)) mess14(langue,3,1),
420 c 4.4.2.2. ==> Quelle arete du laux-eme fils est fille de l'arete i ?
421 c Si on n'en a pas trouve, on passe au fils suivant
423 do 4422 , maux = 1 , 4
425 if ( aretf(maux).eq.f1ai .or.
426 > aretf(maux).eq.f2ai ) then
436 c 4.4.2.3. ==> Quelle arete du fils est fille de l'arete i-1 ?
437 c Si on n'en a pas trouve, on passe au fils suivant
439 do 4423 , maux = 1 , 4
441 if ( aretf(maux).eq.f1aim1 .or.
442 > aretf(maux).eq.f2aim1 ) then
452 c 4.4.2.4. ==> Si on arrive ici, c'est que le laux-eme fils est
454 c On passe a l'angle suivant.
456 quangl(jaux) = lefils(laux)
461 c 4.4.3. ==> Si on arrive ici, c'est qu'aucun fils n'est
469 cgn write (ulsort,*) 'quangle : ',quangl
473 c 4.5. ==> On renumerote en placant dans les angles corrects
475 if ( codret.eq.0 ) then
479 cgn if ( kaux.eq.1501)then
480 cgn write(ulsort,*) 'kaux=1501 ',quangl(jaux)
481 cgn elseif ( quangl(jaux).eq.1501)then
482 cgn write(ulsort,*) 'quangl(jaux)=1501 ',kaux
484 nouqua(kaux) = quangl(jaux)
485 nouqua(quangl(jaux)) = kaux
500 c 5. option autre : impossible
513 if ( codret.ne.0 ) then
517 write (ulsort,texte(langue,1)) 'Sortie', nompro
518 write (ulsort,texte(langue,2)) codret
522 #ifdef _DEBUG_HOMARD_
523 write (ulsort,texte(langue,1)) 'Sortie', nompro