1 subroutine sfcaf1 ( nomail, nbarfr, nbqufr,
2 > ncafdg, nocdfr, ncafan, ncafar,
5 > ulsort, langue, codret )
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c Suivi de Frontiere : CAlcul des nouvelles Frontieres - 1
28 c ______________________________________________________________________
30 c . nom . e/s . taille . description .
31 c .____________________________________________________________________.
32 c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 .
33 c . nbarfr . e . 1 . nombre d'aretes concernees .
34 c . nbqufr . e . 1 . nombre de quadrangles concernes .
35 c . ncafdg . e . char*8 . nom de l'objet des frontieres discretes :.
36 c . . . . nom des groupes .
37 c . nocdfr . e . char8 . nom de l'objet description de la frontiere .
38 c . ncafan . e . char*8 . nom de l'objet des frontieres analytiques :.
39 c . . . . description des frontieres .
40 c . ncafar . e . char*8 . nom de l'objet des frontieres analytiques :.
41 c . . . . valeurs reelles .
42 c . suifro . e . 1 . 1 : pas de suivi de frontiere .
43 c . . . . 2x : frontiere discrete .
44 c . . . . 3x : frontiere analytique .
45 c . . . . 5x : frontiere cao .
46 c . ulgrfr . e . * . unite logique des groupes frontieres CAO .
47 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
48 c . taetco . e . lgetco . tableau de l'etat courant .
49 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
50 c . langue . e . 1 . langue des messages .
51 c . . . . 1 : francais, 2 : anglais .
52 c . codret . es . 1 . code de retour des modules .
53 c . . . . en entree = celui du module d'avant .
54 c . . . . en sortie = celui du module en cours .
55 c . . . . 0 : pas de probleme .
56 c . . . . 1 : manque de temps cpu .
57 c . . . . 2x : probleme dans les memoires .
58 c . . . . 3x : probleme dans les fichiers .
59 c . . . . 5 : mauvaises options .
60 c . . . . 6 : problemes dans les noms d'objet .
61 c ______________________________________________________________________
63 c Nombre d'aretes et de quadrangles concernes :
67 c Reperage des noeuds P2 sur les lignes frontiere :
68 c ---> SFNOFL ---> SFNNFL
69 c ---> SFLISO ---> SFSENO
71 c Suivi des frontieres
72 c ---> SFCAF2 ---> SFFA01
78 c Correction des noeuds P2 :
81 c ---> SFCOTL ---> SFCOT1 ---> SFCOVO ---> UTCOTE
83 c ---> UTCORN ---> UTSOQU
84 c ---> SFCOVO ---> UTCOTE
86 c ---> SFCOFA ---> SFTQTR
88 c ---> UTCORN ---> UTSOQU
89 c ---> SFBATR ---> SFBATT
90 c ---> SFCOT2 ---> UTB3F1
94 c Correction des noeuds P2 :
97 c 0. declarations et dimensionnement
100 c 0.1. ==> generalites
106 parameter ( nompro = 'SFCAF1' )
130 character*8 ncafdg, nocdfr, ncafan, ncafar
134 integer nbarfr, nbqufr
137 integer taetco(lgetco)
139 integer ulsort, langue, codret
141 c 0.4. ==> variables locales
145 integer pcoono, adcocs
146 integer adhono, pareno
147 integer adnuno, adlino, adacno
149 integer psomar, phetar, pfilar, pnp2ar, pfacar, pposif
150 integer pcfaar, pfamar
151 integer phettr, paretr, pfiltr
152 integer phetqu, parequ, pfilqu
153 integer pcfaqu, pfamqu
154 integer ptrite, pcotrt, parete, phette, pfilte
155 integer pquahe, pcoquh, parehe, phethe, pfilhe
156 integer pfacpy, pcofay, parepy, phetpy
157 integer pfacpe, pcofap, parepe, phetpe
158 integer advotr, advoqu
159 integer adpptr, adppqu
160 integer adabsc, psomse, psegli, pnumli, ptypli, pgeoco
163 integer nbfrdi, nbfran
164 integer adtra4, adtra5
167 integer codre1, codre2, codre3, codre4, codre5
170 double precision unst2x, epsid2
172 #ifdef _DEBUG_HOMARD_
174 parameter ( action = 'sufr ' )
177 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
178 character*8 nhtetr, nhhexa, nhpyra, nhpent
180 character*8 nhvois, nhsupe, nhsups
181 character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5
183 #ifdef _DEBUG_HOMARD_
188 parameter ( nbmess = 10 )
189 character*80 texte(nblang,nbmess)
191 c 0.5. ==> initialisations
192 c ______________________________________________________________________
200 #ifdef _DEBUG_HOMARD_
201 write (ulsort,texte(langue,1)) 'Entree', nompro
207 #ifdef _DEBUG_HOMARD_
208 if ( codret.eq.0 ) then
211 call utveri ( action, nomail, nompro, iaux,
212 > ulsort, langue, codret )
218 c 2. recuperation des pointeurs
220 c 2.1. ==> structure generale
222 if ( codret.eq.0 ) then
224 #ifdef _DEBUG_HOMARD_
225 write (ulsort,texte(langue,3)) 'UTNOMH', nompro
227 call utnomh ( nomail,
229 > degre, maconf, homolo, hierar,
230 > rafdef, nbmane, typcca, typsfr, maextr,
233 > nhnoeu, nhmapo, nharet,
235 > nhtetr, nhhexa, nhpyra, nhpent,
237 > nhvois, nhsupe, nhsups,
238 > ulsort, langue, codret)
242 c 2.2.==> tableaux du maillage
244 if ( codret.eq.0 ) then
246 #ifdef _DEBUG_HOMARD_
247 write (ulsort,texte(langue,3)) 'UTAD01', nompro
250 if ( homolo.ge.1 ) then
253 call utad01 ( iaux, nhnoeu,
256 > pcoono, pareno, adhono, adcocs,
257 > ulsort, langue, codret )
259 #ifdef _DEBUG_HOMARD_
260 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
263 if ( degre.eq.2 ) then
266 call utad02 ( iaux, nharet,
267 > phetar, psomar, pfilar, jaux,
268 > pfamar, pcfaar, jaux,
269 > jaux, pnp2ar, jaux,
271 > ulsort, langue, codret )
273 if ( nbtrto.gt.0 ) then
275 #ifdef _DEBUG_HOMARD_
276 write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
279 call utad02 ( iaux, nhtria,
280 > phettr, paretr, pfiltr, jaux,
284 > ulsort, langue, codret )
288 if ( nbquto.gt.0 ) then
290 #ifdef _DEBUG_HOMARD_
291 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
294 call utad02 ( iaux, nhquad,
295 > phetqu, parequ, pfilqu, jaux,
296 > pfamqu, pcfaqu, jaux,
299 > ulsort, langue, codret )
303 if ( nbteto.ne.0 ) then
306 if ( nbteca.gt.0 ) then
309 #ifdef _DEBUG_HOMARD_
310 write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
312 call utad02 ( iaux, nhtetr,
313 > phette, ptrite, pfilte, jaux,
315 > jaux, pcotrt, jaux,
316 > jaux, jaux, parete,
317 > ulsort, langue, codret )
321 if ( nbheto.ne.0 ) then
324 if ( nbheca.gt.0 ) then
327 #ifdef _DEBUG_HOMARD_
328 write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
330 call utad02 ( iaux, nhhexa,
331 > phethe, pquahe, pfilhe, jaux,
333 > jaux, pcoquh, jaux,
334 > jaux, jaux, parehe,
335 > ulsort, langue, codret )
339 if ( nbpyto.ne.0 ) then
342 if ( nbpyca.gt.0 ) then
345 #ifdef _DEBUG_HOMARD_
346 write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
348 call utad02 ( iaux, nhpyra,
349 > phetpy, pfacpy, jaux , jaux,
351 > jaux, pcofay, jaux,
352 > jaux, jaux, parepy,
353 > ulsort, langue, codret )
357 if ( nbpeto.ne.0 ) then
360 if ( nbpeca.gt.0 ) then
363 #ifdef _DEBUG_HOMARD_
364 write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
366 call utad02 ( iaux, nhpent,
367 > phetpe, pfacpe, jaux , jaux,
369 > jaux, pcofap, jaux,
370 > jaux, jaux, parepe,
371 > ulsort, langue, codret )
377 if ( codret.eq.0 ) then
379 #ifdef _DEBUG_HOMARD_
380 write (ulsort,texte(langue,3)) 'UTAD04', nompro
383 if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
386 if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
389 if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then
392 call utad04 ( iaux, nhvois,
393 > jaux, jaux, pposif, pfacar,
395 > jaux, jaux, adpptr, adppqu,
400 > ulsort, langue, codret )
403 cgn call gmprsx(nompro,nhvois)
404 cgn call gmprsx(nompro,nhvois//'.Vol/Tri')
406 c 2.3. ==> Stockage des entites concernees par la frontiere
408 if ( codret.eq.0 ) then
410 call gmalot ( ntrav4, 'entier', nbarfr, adtra4, codre1 )
411 if ( nbquto.gt.0 ) then
412 call gmalot ( ntrav5, 'entier', nbqufr, adtra5, codre2 )
417 codre0 = min ( codre1, codre2 )
418 codret = max ( abs(codre0), codret,
423 if ( codret.eq.0 ) then
427 #ifdef _DEBUG_HOMARD_
428 write (ulsort,texte(langue,3)) 'SFCONA', nompro
430 call sfcona ( iaux, nbarfr, imem(adtra4),
431 > imem(phetar), imem(pcfaar), imem(pfamar),
432 > ulsort, langue, codret )
434 #ifdef _DEBUG_HOMARD_
435 call gmprsx(nompro,ntrav4)
440 if ( codret.eq.0 ) then
442 if ( nbqufr.gt.0 ) then
446 #ifdef _DEBUG_HOMARD_
447 write (ulsort,texte(langue,3)) 'SFCONQ', nompro
449 call sfconq ( iaux, nbqufr, imem(adtra5),
450 > imem(phetqu), imem(pcfaqu), imem(pfamqu),
451 > ulsort, langue, codret )
453 #ifdef _DEBUG_HOMARD_
454 call gmprsx(nompro,ntrav5)
461 c 2.4. ==> Tolerance pour les tests de coincidence
462 c Attention : sfcaf1 et sfcoin doivent etre coherents
464 if ( codret.eq.0 ) then
466 unst2x = 1.d0 / rmem(adcocs+10)**2
467 epsid2 = max(1.d-14,epsima)
472 c 3. Les structures des frontieres
474 #ifdef _DEBUG_HOMARD_
475 write (ulsort,90002) '3. Les frontieres ; codret', codret
482 if ( mod(suifro,2).eq.0 ) then
484 c 3.1.1. ==> Combien de frontieres discretes
486 #ifdef _DEBUG_HOMARD_
487 call gmprsx (nompro, ncafdg )
490 if ( codret.eq.0 ) then
492 if ( suifro.gt.0 ) then
494 call gmliat ( ncafdg, 1, nbfrdi, codret )
498 call gmadoj ( ncafdg, pttgrd, nbfrdi, codret )
504 c 3.1.2. ==> Description des frontieres discretes
506 if ( nbfrdi.gt.0 ) then
508 if ( codret.eq.0 ) then
510 #ifdef _DEBUG_HOMARD_
511 call gmliat (nocdfr, 2, iaux, codret )
512 call gmprot (nompro, nocdfr//'.CoorNoeu', 1 , 20 )
513 call gmprot (nompro, nocdfr//'.CoorNoeu', 3*iaux-19 , 3*iaux )
514 call gmprsx (nompro, nocdfr//'.NumeLign' )
515 call gmprsx (nompro, nocdfr//'.PtrSomLi' )
516 call gmprot (nompro, nocdfr//'.SommSegm', 1 , 20 )
517 call gmprot (nompro, nocdfr//'.SommSegm', 999 , 1002 )
518 call gmprot (nompro, nocdfr//'.SommSegm', 1003 , 1008 )
519 call gmprot (nompro, nocdfr//'.SommSegm', 1999 , 2004 )
520 call gmprot (nompro, nocdfr//'.AbsCurvi', 1 , 20 )
521 call gmprot (nompro, nocdfr//'.AbsCurvi', 999 , 1002 )
522 call gmprot (nompro, nocdfr//'.AbsCurvi', 1003 , 1008 )
523 call gmprot (nompro, nocdfr//'.AbsCurvi', 1999 , 2004 )
526 call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 )
527 call gmadoj ( nocdfr//'.NumeLign', pnumli, iaux, codre2 )
528 call gmadoj ( nocdfr//'.TypeLign', ptypli, iaux, codre3 )
529 call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre4 )
530 call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre5 )
531 call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre6 )
533 codre0 = min ( codre1, codre2, codre3, codre4, codre5,
535 codret = max ( abs(codre0), codret,
536 > codre1, codre2, codre3, codre4, codre5,
545 c 3.2. ==> Analytiques
549 if ( mod(suifro,3).eq.0 ) then
551 c 3.2.1. ==> Combien de frontieres analytiques
553 if ( codret.eq.0 ) then
555 call gmliat ( ncafan, 1, nbfran, codret )
559 c 3.2.2. ==> Description des frontieres analytiques
561 if ( nbfran.gt.0 ) then
563 #ifdef _DEBUG_HOMARD_
564 call gmprsx (nompro, ncafar )
567 if ( codret.eq.0 ) then
569 call gmadoj ( ncafar, adcafr, iaux, codret )
577 #ifdef _DEBUG_HOMARD_
578 write (ulsort,90002) 'nbfrdi', nbfrdi
579 write (ulsort,90002) 'nbfran', nbfran
583 c 4. Noeuds initiaux et frontiere
585 #ifdef _DEBUG_HOMARD_
586 write (ulsort,90002) '4. Noeuds ini / frontiere ; codret', codret
589 if ( nbfrdi.gt.0 ) then
591 if ( codret.eq.0 ) then
593 #ifdef _DEBUG_HOMARD_
594 write (ulsort,texte(langue,3)) 'SFNOFL', nompro
596 call sfnofl ( ntrav1, ntrav2, ntrav3,
597 > adnuno, adlino, adacno,
600 > imem(psomar), imem(phetar), imem(pfilar),
602 > imem(pcfaar), imem(pfamar),
603 > rmem(pgeoco), rmem(adabsc),
604 > imem(psomse), imem(psegli),
606 > ulsort, langue, codret )
610 #ifdef _DEBUG_HOMARD_
611 if ( codret.eq.0 ) then
615 call utveri ( action, nomail, nompra, iaux,
616 > ulsort, langue, codret )
624 c 5. Suivi sur les frontieres
626 #ifdef _DEBUG_HOMARD_
627 write (ulsort,90002) '5. Suivi ; codret', codret
630 if ( codret.eq.0 ) then
632 #ifdef _DEBUG_HOMARD_
633 write (ulsort,texte(langue,3)) 'SFCAF2', nompro
635 call sfcaf2 ( suifro, ulgrfr,
636 > nbfrdi, rmem(pgeoco), rmem(adabsc),
637 > imem(adnuno), imem(adlino), rmem(adacno),
638 > imem(ptypli), imem(psomse), imem(psegli),
639 > nbfran, rmem(adcafr),
643 > imem(phetar), imem(psomar), imem(pfilar),
644 > imem(pnp2ar), imem(pcfaar), imem(pfamar),
645 > imem(pfacar), imem(pposif),
646 > imem(phettr), imem(paretr), imem(pfiltr),
648 > imem(phetqu), imem(parequ), imem(pfilqu),
649 > imem(pcfaqu), imem(pfamqu),
652 > ulsort, langue, codret )
656 #ifdef _DEBUG_HOMARD_
657 if ( codret.eq.0 ) then
661 call utveri ( action, nomail, nompra, iaux,
662 > ulsort, langue, codret )
668 c 6. Retablissement des numeros de ligne
671 #ifdef _DEBUG_HOMARD_
672 write (ulsort,90002) '6. retablissement nros ; codret', codret
675 if ( nbfrdi.gt.0 ) then
677 if ( codret.eq.0 ) then
680 #ifdef _DEBUG_HOMARD_
681 write (ulsort,texte(langue,3)) 'SFNULI', nompro
683 call sfnuli ( imem(pcfaar), imem(pnumli), iaux,
685 > ulsort, langue, codret )
692 c 7. Mouvements de noeud induits
694 #ifdef _DEBUG_HOMARD_
695 write (ulsort,90002) '7. Mouvements 1 ; codret', codret
698 if ( codret.eq.0 ) then
700 if ( typsfr.eq.2 ) then
702 #ifdef _DEBUG_HOMARD_
703 write (ulsort,texte(langue,3)) 'SFMOP2', nompro
705 call sfmop2 ( rmem(pcoono), imem(phetno), imem(pareno),
707 > ulsort, langue, codret)
715 #ifdef _DEBUG_HOMARD_
716 write (ulsort,90002) '8. Controles ; codret', codret
719 if ( mod(suifro,5).ne.0 ) then
721 if ( codret.eq.0 ) then
723 #ifdef _DEBUG_HOMARD_
724 write (ulsort,texte(langue,3)) 'SFCOTL', nompro
726 call sfcotl ( rmem(pcoono),
727 > imem(psomar), imem(pfilar), imem(pnp2ar),
728 > imem(pcfaar), imem(pfamar),
729 > imem(pfacar), imem(pposif),
730 > imem(phettr), imem(paretr), imem(pfiltr),
731 > imem(phetqu), imem(parequ), imem(pfilqu),
732 > imem(pcfaqu), imem(pfamqu),
733 > imem(ptrite), imem(pcotrt), imem(parete),
736 > imem(pquahe), imem(pcoquh), imem(parehe),
739 > imem(pfacpy), imem(pcofay), imem(parepy),
741 > imem(pfacpe), imem(pcofap), imem(parepe),
743 > imem(advotr), imem(adpptr),
744 > imem(advoqu), imem(adppqu),
745 > nbarfr, imem(adtra4),
746 > nbqufr, imem(adtra5),
748 > ulsort, langue, codret )
757 #ifdef _DEBUG_HOMARD_
758 write (ulsort,90002) '10. Mouvements 2 ; codret', codret
761 if ( codret.eq.0 ) then
763 if ( typsfr.eq.2 ) then
765 #ifdef _DEBUG_HOMARD_
766 write (ulsort,texte(langue,3)) 'SFMOP2', nompro
768 call sfmop2 ( rmem(pcoono), imem(phetno), imem(pareno),
770 > ulsort, langue, codret)
776 c 11. Mise a jour des coordonnes extremes
779 if ( mod(suifro,5).ne.0 ) then
781 if ( codret.eq.0 ) then
783 #ifdef _DEBUG_HOMARD_
784 write (ulsort,texte(langue,3)) 'UTMMCO', nompro
786 call utmmco ( rmem(adcocs+1), rmem(adcocs+4), rmem(adcocs+7),
787 > nbnoto, sdim, rmem(pcoono),
788 > ulsort, langue, codret )
797 #ifdef _DEBUG_HOMARD_
798 write (ulsort,90002) '12. menage ; codret', codret
801 if ( codret.eq.0 ) then
803 if ( nbfrdi.gt.0 ) then
805 call gmlboj ( ntrav1, codre1 )
806 call gmlboj ( ntrav2, codre2 )
807 call gmlboj ( ntrav3, codre3 )
809 codre0 = min ( codre1, codre2, codre3 )
810 codret = max ( abs(codre0), codret,
811 > codre1, codre2, codre3 )
817 if ( codret.eq.0 ) then
819 call gmlboj ( ntrav4, codre1 )
820 if ( nbquto.gt.0 ) then
821 call gmlboj ( ntrav5, codre2 )
826 codre0 = min ( codre1, codre2 )
827 codret = max ( abs(codre0), codret,
832 #ifdef _DEBUG_HOMARD_
833 if ( codret.eq.0 ) then
836 call utveri ( action, nomail, nompro, iaux,
837 > ulsort, langue, codret )
846 if ( codret.ne.0 ) then
850 write (ulsort,texte(langue,1)) 'Sortie', nompro
851 write (ulsort,texte(langue,2)) codret
855 #ifdef _DEBUG_HOMARD_
856 write (ulsort,texte(langue,1)) 'Sortie', nompro