1 subroutine sfcotl ( coonoe,
2 > somare, filare, np2are,
5 > hettri, aretri, filtri,
6 > hetqua, arequa, filqua,
8 > tritet, cotrte, aretet, hettet,
10 > quahex, coquhe, arehex, hethex,
12 > facpyr, cofapy, arepyr, hetpyr,
13 > facpen, cofape, arepen, hetpen,
19 > ulsort, langue, codret)
20 c ______________________________________________________________________
23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
26 c aupres des huissiers de justice Simart et Lavoir a Clamart
27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
28 c aupres des huissiers de justice
29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
31 c HOMARD est une marque deposee d'Electricite de France
37 c ______________________________________________________________________
39 c Suivi de Frontiere - COnTroLes
41 c ______________________________________________________________________
43 c . nom . e/s . taille . description .
44 c .____________________________________________________________________.
45 c . coonoe . es . nbnoto . coordonnees des noeuds .
47 c . somare . e .2*nbarto. numeros des extremites d'arete .
48 c . filare . e . nbarto . premiere fille des aretes .
49 c . np2are . e . nbarto . noeud milieux des aretes .
50 c . cfaare . e . nctfar*. codes des familles des aretes .
51 c . . . nbfare . 1 : famille MED .
52 c . . . . 2 : type de segment .
53 c . . . . 3 : orientation .
54 c . . . . 4 : famille d'orientation inverse .
55 c . . . . 5 : numero de ligne de frontiere .
56 c . . . . > 0 si concernee par le suivi de frontiere.
57 c . . . . <= 0 si non concernee .
58 c . . . . 6 : famille frontiere active/inactive .
59 c . . . . 7 : numero de surface de frontiere .
60 c . . . . + l : appartenance a l'equivalence l .
61 c . famare . e . nbarto . famille des aretes .
62 c . facare . e . nbfaar . liste des faces contenant une arete .
63 c . posifa . e . nbarto . pointeur sur tableau facare .
64 c . hettri . e . nbtrto . historique de l'etat des triangles .
65 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
66 c . filtri . e . nbtrto . premier fils des triangles .
67 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
68 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
69 c . filqua . e . nbquto . premier fils des quadrangles .
70 c . cfaqua . e . nctfqu*. codes des familles des quadrangles .
71 c . . . nbfqua . 1 : famille MED .
72 c . . . . 2 : type de quadrangle .
73 c . . . . 3 : numero de surface de frontiere .
74 c . . . . 4 : famille des aretes internes apres raf.
75 c . . . . 5 : famille des triangles de conformite .
76 c . . . . 6 : famille de sf active/inactive .
77 c . . . . + l : appartenance a l'equivalence l .
78 c . famqua . e . nbquto . famille des quadrangles .
79 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
80 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
81 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
82 c . hettet . e . nbteto . historique de l'etat des tetraedres .
83 c . filtet . e . nbteto . premier fils des tetraedres .
84 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
85 c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres .
86 c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres .
87 c . hethex . e . nbheto . historique de l'etat des hexaedres .
88 c . filhex . e . nbheto . premier fils des hexaedres .
89 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
90 c . cofapy . e .nbpycf*5. codes des faces des pyramides .
91 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
92 c . hetpyr . e . nbpyto . historique de l'etat des pyramides .
93 c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres .
94 c . cofape . e .nbpecf*5. code des 5 faces des pentaedres .
95 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
96 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
97 c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
98 c . . . . voltri(i,k) definit le i-eme voisin de k .
99 c . . . . 0 : pas de voisin .
100 c . . . . j>0 : tetraedre j .
101 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
102 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
103 c . . . . du triangle k tel que voltri(1/2,k) = -j .
104 c . . . . pypetr(2,j) = numero du pentaedre voisin .
105 c . . . . du triangle k tel que voltri(1/2,k) = -j .
106 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
107 c . . . . volqua(i,k) definit le i-eme voisin de k .
108 c . . . . 0 : pas de voisin .
109 c . . . . j>0 : hexaedre j .
110 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
111 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
112 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
113 c . . . . pypequ(2,j) = numero du pentaedre voisin .
114 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
115 c . nbarfr . e . 1 . nombre d'aretes concernees .
116 c . arefro . e . nbarfr . liste des aretes concernees .
117 c . nbqufr . e . 1 . nombre de quadrangles concernes .
118 c . quafro . e . nbqufr . liste des quadrangles concernes .
119 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
120 c . taetco . e . lgetco . tableau de l'etat courant .
121 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
122 c . langue . e . 1 . langue des messages .
123 c . . . . 1 : francais, 2 : anglais .
124 c . codret . es . 1 . code de retour des modules .
125 c . . . . 0 : pas de probleme .
126 c . . . . x : probleme .
127 c ______________________________________________________________________
130 c 0. declarations et dimensionnement
133 c 0.1. ==> generalites
139 parameter ( nompro = 'SFCOTL' )
162 integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
163 integer posifa(0:nbarto), facare(nbfaar)
164 integer cfaare(nctfar,nbfare), famare(nbarto)
165 integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
166 integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
167 integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
168 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
169 integer hettet(nbteto)
170 integer filtet(nbteto)
171 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
172 integer hethex(nbheto)
173 integer filhex(nbheto)
174 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
175 integer hetpyr(nbpyto)
176 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
177 integer hetpen(nbpeto)
178 integer voltri(2,nbtrto), pypetr(2,*)
179 integer volqua(2,nbquto), pypequ(2,*)
180 integer nbarfr, arefro(nbarfr)
181 integer nbqufr, quafro(nbqufr)
183 double precision coonoe(nbnoto,sdim)
186 integer taetco(lgetco)
188 integer ulsort, langue, codret
190 c 0.4. ==> variables locales
192 integer nretap, nrsset
195 integer nbcoa1, nbcoq1, nuphas
196 integer nbcoa2, nbcoq2
197 integer nbarf0, nbquf0
202 parameter ( nbmess = 20 )
203 character*80 texte(nblang,nbmess)
205 c 0.5. ==> initialisations
206 c ______________________________________________________________________
214 c 1.3. ==> les messages
218 #ifdef _DEBUG_HOMARD_
219 write (ulsort,texte(langue,1)) 'Entree', nompro
223 texte(1,4) = '(/,a6,'' CONTROLES'')'
224 texte(1,5) = '(16(''=''),/)'
225 texte(1,6) = '(/,''Phase de controle'',i10,/,27(''-''))'
226 texte(1,7) = '(/,''. Examen du '',a,i10)'
228 >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'',
230 texte(1,9) = '(''==> Tout va bien.'')'
231 texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)'
232 texte(1,11) = '(''Nombre de '',a,'' a basculer :'',i10)'
233 texte(1,12) = '(''... Reprise du '',a,i10)'
235 texte(2,4) = '(/,a6,'' CHECK'')'
236 texte(2,5) = '(12(''=''),/)'
237 texte(2,6) = '(/,''Checking phase #'',i10,/,26(''-''))'
238 texte(2,7) = '(/,''. Examination of '',a,'' # '',i10)'
240 >'(''==> Number of corrections of nodes connected to '',a,'':'',
242 texte(2,9) = '(''==> Everything is OK.'')'
243 texte(2,10) = '(''Number of involved '',a,'':'',i10)'
244 texte(2,11) = '(''Number of '',a,'' to swap :'',i10)'
245 texte(2,12) = '(''... Correction of '',a,i10)'
247 cgn 1001 format(a,' :',i10,', ',3g13.5)
249 c 1.4. ==> le numero de sous-etape
252 nrsset = taetco(2) + 1
255 call utcvne ( nretap, nrsset, saux, iaux, codret )
259 write (ulsort,texte(langue,4)) saux
260 write (ulsort,texte(langue,5))
269 cgn if ( nbarfr.gt.0 ) return
274 c 3. Controle des retournements pour les decoupages homogenes
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,*) '3. Retournements ; codret = ', codret
280 if ( codret.eq.0 ) then
283 write (ulsort,texte(langue,6)) nuphas
285 #ifdef _DEBUG_HOMARD_
286 write (ulsort,texte(langue,3)) 'SFCOT1', nompro
288 call sfcot1 ( nbcoq1, nbcoa1,
290 > somare, filare, np2are,
293 > hettri, aretri, filtri,
294 > hetqua, arequa, filqua,
296 > tritet, cotrte, aretet,
298 > quahex, coquhe, arehex,
304 > ulsort, langue, codret)
308 if ( codret.eq.0 ) then
310 if ( (nbcoa1+nbcoq1).gt.0 ) then
312 if ( nbcoq1.gt.0 ) then
313 write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq1
316 if ( nbcoa1.gt.0 ) then
317 write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa1
322 write (ulsort,texte(langue,9))
329 c 4. Controle des interpenetrations
331 #ifdef _DEBUG_HOMARD_
332 write (ulsort,*) '4. Interpenetrations ; codret = ', codret
338 #ifdef _DEBUG_HOMARD_
339 if ( codret.eq.0 ) then
342 write (ulsort,texte(langue,6)) nuphas
344 #ifdef _DEBUG_HOMARD_
345 write (ulsort,texte(langue,3)) 'SFCOT2', nompro
347 call sfcot2 ( nbcoq2, nbcoa2,
349 > somare, filare, np2are,
352 > hettri, aretri, filtri,
353 > hetqua, arequa, filqua,
355 > tritet, cotrte, aretet, hettet,
357 > quahex, coquhe, arehex, hethex,
359 > facpyr, cofapy, arepyr, hetpyr,
360 > facpen, cofape, arepen, hetpen,
365 > ulsort, langue, codret)
370 if ( codret.eq.0 ) then
372 if ( (nbcoa2+nbcoq2).gt.0 ) then
374 if ( nbcoq2.gt.0 ) then
375 write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq2
378 if ( nbcoa2.gt.0 ) then
379 write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa2
384 write (ulsort,texte(langue,9))
392 c 5. Tant qu'il y a eu une correction, on recommence les tests
395 if ( codret.eq.0 ) then
397 if ( (nbcoa1+nbcoq1+nbcoq2+nbcoa2).gt.0 ) then
399 c On raccourcit les listes des quadrangles et aretes a controler
403 do 51 , iaux = 1 , jaux
404 if ( arefro(iaux).gt.0 ) then
406 arefro(nbarf0) = arefro(iaux)
412 do 52 , iaux = 1 , jaux
413 if ( quafro(iaux).gt.0 ) then
415 quafro(nbquf0) = quafro(iaux)
431 if ( codret.ne.0 ) then
435 write (ulsort,texte(langue,1)) 'Sortie', nompro
436 write (ulsort,texte(langue,2)) codret
440 #ifdef _DEBUG_HOMARD_
441 write (ulsort,texte(langue,1)) 'Sortie', nompro