1 subroutine sfcot1 ( nbcoqu, nbcoar,
3 > somare, filare, np2are,
6 > hettri, aretri, filtri,
7 > hetqua, arequa, filqua,
9 > tritet, cotrte, aretet,
11 > quahex, coquhe, arehex,
17 > ulsort, langue, codret)
18 c ______________________________________________________________________
21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
24 c aupres des huissiers de justice Simart et Lavoir a Clamart
25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
26 c aupres des huissiers de justice
27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
29 c HOMARD est une marque deposee d'Electricite de France
35 c ______________________________________________________________________
37 c Suivi de Frontiere - COnTroles - phase 1
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . nbcoqu . s . 1 . nombre de corrections pour les quadrangles .
44 c . nbcoar . s . 1 . nombre de corrections pour les aretes .
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 triangles des tetraedres .
80 c . cotrte . e .nbtecf*4. codes des 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 . voltri . e .2*nbtrto. numeros des 2 volumes par triangle .
90 c . . . . voltri(i,k) definit le i-eme voisin de k .
91 c . . . . 0 : pas de voisin .
92 c . . . . j>0 : tetraedre j .
93 c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
94 c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
95 c . . . . du triangle k tel que voltri(1/2,k) = -j .
96 c . . . . pypetr(2,j) = numero du pentaedre voisin .
97 c . . . . du triangle k tel que voltri(1/2,k) = -j .
98 c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle .
99 c . . . . volqua(i,k) definit le i-eme voisin de k .
100 c . . . . 0 : pas de voisin .
101 c . . . . j>0 : hexaedre j .
102 c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
103 c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
104 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
105 c . . . . pypequ(2,j) = numero du pentaedre voisin .
106 c . . . . du quadrangle k tel que volqua(1/2,k) = -j .
107 c . nbarfr . e . 1 . nombre d'aretes concernees .
108 c . arefro . es . nbarfr . liste des aretes concernees .
109 c . nbqufr . e . 1 . nombre de quadrangles concernes .
110 c . quafro . es . nbqufr . liste des quadrangles concernes .
111 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
112 c . langue . e . 1 . langue des messages .
113 c . . . . 1 : francais, 2 : anglais .
114 c . codret . es . 1 . code de retour des modules .
115 c . . . . 0 : pas de probleme .
116 c . . . . x : probleme .
117 c ______________________________________________________________________
120 c 0. declarations et dimensionnement
123 c 0.1. ==> generalites
129 parameter ( nompro = 'SFCOT1' )
153 integer nbcoar, nbcoqu
154 integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
155 integer posifa(0:nbarto), facare(nbfaar)
156 integer cfaare(nctfar,nbfare), famare(nbarto)
157 integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
158 integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
159 integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
160 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
161 integer hettet(nbteto)
162 integer filtet(nbteto)
163 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
164 integer hethex(nbheto)
165 integer filhex(nbheto)
166 integer voltri(2,nbtrto), pypetr(2,*)
167 integer volqua(2,nbquto), pypequ(2,*)
168 integer nbarfr, arefro(nbarfr)
169 integer nbqufr, quafro(nbqufr)
171 double precision coonoe(nbnoto,sdim)
173 integer ulsort, langue, codret
175 c 0.4. ==> variables locales
179 integer larete, lequad, laface
180 integer nuarfr, nuqufr
181 integer nbexam, examno(2), examar(2)
182 integer nufade, nufafi, decafv
184 integer nbtetr, nbhexa, nbpyra, nbpent
185 integer lisvoi(tbdim)
186 integer bilan, nbbato
187 integer libasc(tbdim), nbbasc
190 parameter ( nbmess = 20 )
191 character*80 texte(nblang,nbmess)
193 c 0.5. ==> initialisations
194 c ______________________________________________________________________
200 c 1.1. ==> les messages
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,texte(langue,1)) 'Entree', nompro
209 texte(1,7) = '(/,''. Examen du '',a,i10)'
211 >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'',
213 texte(1,9) = '(''==> Tout va bien.'')'
214 texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)'
215 texte(1,11) = '(''Nombre de '',a,'' a basculer :'',i10)'
216 texte(1,12) = '(''... Reprise du '',a,i10)'
218 texte(2,7) = '(/,''. Examination of '',a,'' # '',i10)'
220 >'(''==> Number of corrections of nodes connected to '',a,'':'',
222 texte(2,9) = '(''==> Everything is OK.'')'
223 texte(2,10) = '(''Number of involved '',a,'':'',i10)'
224 texte(2,11) = '(''Number of '',a,'' to swap :'',i10)'
225 texte(2,12) = '(''... Correction of '',a,i10)'
235 nbvoto = nbteto + nbheto + nbpyto + nbpeto
237 #ifdef _DEBUG_HOMARD_
238 write (ulsort,90002) 'typsfr', typsfr
242 c 2. Boucle sur les quadrangles qui viennent d'etre decoupes et
243 c qui font partie d'une frontiere reconnue
245 #ifdef _DEBUG_HOMARD_
246 write (ulsort,90002) '2. boucle quadrangles ; codret', codret
249 #ifdef _DEBUG_HOMARD_
250 write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqufr
255 do 21 , nuqufr = 1 , nbqufr
257 c 2.1. ==> Elimination des situations ou il est inutile
258 c de controler car le quadrangle a deja ete ramene
260 lequad = quafro(nuqufr)
262 if ( lequad.le.0 ) then
266 c 2.2. ==> Reperage des situations a examiner :
267 c . le noeud central du quadrangle decoupe
268 c . les noeuds P2 courbes : a faire
269 c ce noeud central est la seconde extremite de la 2eme ou 3eme
270 c arete de l'un quelconque des quadrangles fils (cf. cmrdqu)
272 if ( codret.eq.0 ) then
274 if ( typsfr.le.2 ) then
276 larete = arequa(filqua(lequad),2)
277 examno(1) = somare(2,larete)
286 if ( codret.eq.0 ) then
288 #ifdef _DEBUG_HOMARD_
289 write (ulsort,texte(langue,7)) mess14(langue,1,4), lequad
292 do 23 , iaux = 1 , nbexam
296 c 2.3.1. ==> Controle des volumes s'appuyant sur ce quadrangle
298 if ( nbvoto.ne.0 ) then
300 if ( codret.eq.0 ) then
302 #ifdef _DEBUG_HOMARD_
303 write (ulsort,texte(langue,3)) 'UTVGVQ', nompro
305 call utvgvq ( lequad,
307 > nbhexa, nbpyra, nbpent,
309 > ulsort, langue, codret )
313 if ( codret.eq.0 ) then
317 #ifdef _DEBUG_HOMARD_
318 write (ulsort,texte(langue,3)) 'SFCOVO', nompro
321 > nbtetr, nbhexa, nbpyra, nbpent,
327 > tritet, cotrte, aretet,
329 > quahex, coquhe, arehex,
331 > ulsort, langue, codret)
335 if ( codret.eq.0 ) then
337 if ( bilan.ne.0 ) then
345 c 2.3.2. ==> Corrections eventuelles
349 if ( codret.eq.0 ) then
351 if ( bilan.ne.0 ) then
353 #ifdef _DEBUG_HOMARD_
354 write (ulsort,texte(langue,12)) mess14(langue,1,-1), examno(iaux)
358 quafro(nuqufr) = -lequad
360 #ifdef _DEBUG_HOMARD_
361 write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro
363 call utcorn ( examno(iaux), lequad, jaux,
369 > ulsort, langue, codret)
382 c 3. Boucle sur les aretes qui viennent d'etre decoupees et
383 c qui font partie d'une frontiere reconnue
385 #ifdef _DEBUG_HOMARD_
386 write (ulsort,90002) '3. boucle aretes ; codret', codret
389 #ifdef _DEBUG_HOMARD_
390 write (ulsort,texte(langue,10)) mess14(langue,3,1), nbarfr
393 do 31 , nuarfr = 1 , nbarfr
395 c 3.1. ==> Elimination des situations ou il est inutile
396 c de controler car l'arete a deja ete ramenee
398 if ( codret.eq.0 ) then
400 larete = arefro(nuarfr)
402 if ( larete.le.0 ) then
408 c 3.2. ==> Reperage des situations a examiner :
409 c . le noeud milieu de l'arete decoupee ou
410 cgnc . les noeuds P2 courbes
412 if ( codret.eq.0 ) then
414 cgn if ( typsfr.le.2 ) then
417 examno(1) = somare(2,filare(examar(1)))
420 cgn examar(1) = filare(larete)
421 cgn examno(1) = np2are(examar(1))
422 cgn examar(2) = examar(1) + 1
423 cgn examno(2) = np2are(examar(2))
430 if ( codret.eq.0 ) then
432 do 33 , iaux = 1 , nbexam
434 c 3.3.1. ==> Faces s'appuyant sur l'arete : s'il n'y en a pas, on
437 nufade = posifa(examar(iaux)-1) + 1
438 nufafi = posifa(examar(iaux))
440 if ( nufafi.lt.nufade ) then
446 #ifdef _DEBUG_HOMARD_
447 write (ulsort,texte(langue,7)) mess14(langue,1,1), examar(iaux)
450 c 3.3.2. ==> Controle des volumes s'appuyant sur cette arete
452 if ( nbvoto.ne.0 ) then
454 if ( codret.eq.0 ) then
456 #ifdef _DEBUG_HOMARD_
457 write (ulsort,texte(langue,3)) 'UTVGVA', nompro
459 call utvgv1 ( nufade, nufafi,
462 > nbtetr, nbhexa, nbpyra, nbpent,
464 > ulsort, langue, codret )
468 if ( codret.eq.0 ) then
470 decafv = 2 * ( nufafi - nufade + 1 )
472 #ifdef _DEBUG_HOMARD_
473 write (ulsort,texte(langue,3)) 'SFCOVO', nompro
476 > nbtetr, nbhexa, nbpyra, nbpent,
482 > tritet, cotrte, aretet,
484 > quahex, coquhe, arehex,
486 > ulsort, langue, codret)
490 if ( codret.eq.0 ) then
492 if ( bilan.ne.0 ) then
500 c 3.3.3. ==> Controle des surfaces vraiment 2D s'appuyant sur l'arete
502 if ( codret.eq.0 ) then
504 #ifdef _DEBUG_HOMARD_
505 write (ulsort,texte(langue,3)) 'SFCOFA', nompro
508 call sfcofa ( bilan, nbbasc, libasc,
509 > examno(iaux), examar(iaux),
510 > nufade, nufafi, nbvoto,
512 > somare, filare, np2are,
516 > hetqua, arequa, filqua,
518 > ulsort, langue, codret)
522 #ifdef _DEBUG_HOMARD_
523 if ( codret.eq.0 ) then
524 write (ulsort,texte(langue,11)) mess14(langue,3,1), nbbasc
528 c 3.3.4. ==> Corrections eventuelles
532 c 3.3.4.1. ==> Retour au milieu
534 if ( codret.eq.0 ) then
536 if ( bilan.ne.0 ) then
538 #ifdef _DEBUG_HOMARD_
539 write (ulsort,texte(langue,12)) mess14(langue,1,-1), examno(iaux)
543 arefro(nuarfr) = -larete
545 #ifdef _DEBUG_HOMARD_
546 write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro
548 call utcorn ( examno(iaux), jaux, larete,
554 > ulsort, langue, codret)
560 c 3.3.4.2. ==> On fait les basculements d'aretes necessaires
562 if ( codret.eq.0 ) then
564 nbbato = nbbato + nbbasc
566 do 3342 , jaux = 1 , nbbasc
568 laface = libasc(jaux)
570 #ifdef _DEBUG_HOMARD_
571 write (ulsort,texte(langue,3)) 'SFBATR', nompro
573 call sfbatr ( examno(iaux), examar(iaux), laface,
576 > hettri, aretri, filtri,
577 > ulsort, langue, codret)
593 #ifdef _DEBUG_HOMARD_
594 if ( (nbcoqu+nbcoar).eq.0 ) then
595 write (ulsort,texte(langue,9))
597 if ( nbcoqu.gt.0 ) then
598 write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoqu
600 if ( nbcoar.gt.0 ) then
601 write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoar
606 if ( nbbato.gt.0 ) then
607 write (ulsort,texte(langue,11)) mess14(langue,3,1), nbbato
610 if ( codret.ne.0 ) then
614 write (ulsort,texte(langue,1)) 'Sortie', nompro
615 write (ulsort,texte(langue,2)) codret
619 #ifdef _DEBUG_HOMARD_
620 write (ulsort,texte(langue,1)) 'Sortie', nompro