1 subroutine sfcoin ( nomail,
2 > lgopti, taopti, lgopts, taopts,
4 > ulsort, langue, codret )
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c Suivi de Frontiere : COnversions INitiales
27 c ______________________________________________________________________
29 c . nom . e/s . taille . description .
30 c .____________________________________________________________________.
31 c . nomail . e . char8 . nom de l'objet maillage homard .
32 c . lgopti . e . 1 . longueur du tableau des options .
33 c . taopti . e . lgopti . tableau des options .
34 c . lgopts . e . 1 . longueur du tableau des options caracteres .
35 c . taopts . e . lgopts . tableau des options caracteres .
36 c . lgetco . e . 1 . longueur du tableau de l'etat courant .
37 c . taetco . e . lgetco . tableau de l'etat courant .
38 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
39 c . langue . e . 1 . langue des messages .
40 c . . . . 1 : francais, 2 : anglais .
41 c . codret . es . 1 . code de retour des modules .
42 c . . . . en entree = celui du module d'avant .
43 c . . . . en sortie = celui du module en cours .
44 c . . . . 0 : pas de probleme .
45 c . . . . 1 : manque de temps cpu .
46 c . . . . 2x : probleme dans les memoires .
47 c . . . . 3x : probleme dans les fichiers .
48 c . . . . 5 : mauvaises options .
49 c . . . . 6 : problemes dans les noms d'objet .
50 c ______________________________________________________________________
53 c 0. declarations et dimensionnement
56 c 0.1. ==> generalites
62 parameter ( nompro = 'SFCOIN' )
85 integer taopti(lgopti)
88 character*8 taopts(lgopts)
91 integer taetco(lgetco)
93 integer ulsort, langue, codret
95 c 0.4. ==> variables locales
97 integer iaux, jaux, kaux
98 integer nretap, nrsset
100 integer nbarfr, nbqufr
102 integer adnuno, adlino, adacno
103 integer adabsc, psomse, psegli, pgeoco
104 integer pcoono, adcocs
107 integer psomar, phetar, pfilar, pnp2ar
108 integer pcfaar, pfamar
109 integer parequ, phetqu
110 integer pcfaqu, pfamqu
112 integer adfrgr, adnogr, nbfrgr, adulgr
116 integer codre1, codre2, codre3, codre4
118 double precision unst2x, epsid2
124 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
125 character*8 nhtetr, nhhexa, nhpyra, nhpent
127 character*8 nhvois, nhsupe, nhsups
128 character*8 ntrav1, ntrav2, ntrav3
129 character*8 ncafdg, nocdfr, ncafan, ncfgnf, ncfgng, ncafar
133 parameter ( nbmess = 10 )
134 character*80 texte(nblang,nbmess)
136 c 0.5. ==> initialisations
137 c ______________________________________________________________________
140 c 1. les initialisations
142 c 1.1. ==> les messages
146 #ifdef _DEBUG_HOMARD_
147 write (ulsort,texte(langue,1)) 'Entree', nompro
151 texte(1,4) = '(/,a6,'' PRISE EN COMPTE DES FRONTIERES'')'
152 texte(1,5) = '(37(''=''),/)'
153 texte(1,6) = '(''Aucun '',a,''n''''est concerne.'')'
154 texte(1,7) = '(''Nombre de '',a,''concernes :'',i10)'
155 texte(1,8) = '(/,''. Conversion de la geometrie discrete'',/)'
157 texte(2,4) = '(/,a6,'' BOUNDARY EXAMINATION'')'
158 texte(2,5) = '(27(''=''),/)'
159 texte(2,6) = '(''No '',a,''is involved'')'
160 texte(2,7) = '(''Number of involved '',a,'':'',i10)'
161 texte(2,8) = '(/,''. Conversion of discrete geometry'',/)'
165 c 1.4. ==> le numero de sous-etape
168 nrsset = taetco(2) + 1
171 call utcvne ( nretap, nrsset, saux, iaux, codret )
175 if ( taopti(4).ne.2 ) then
176 write (ulsort,texte(langue,4)) saux
177 write (ulsort,texte(langue,5))
181 c 2. recuperation des pointeurs
183 c 2.1. ==> structure generale
185 if ( codret.eq.0 ) then
187 #ifdef _DEBUG_HOMARD_
188 write (ulsort,texte(langue,3)) 'UTNOMH', nompro
190 call utnomh ( nomail,
192 > degre, maconf, homolo, hierar,
193 > rafdef, nbmane, typcca, typsfr, maextr,
196 > nhnoeu, nhmapo, nharet,
198 > nhtetr, nhhexa, nhpyra, nhpent,
200 > nhvois, nhsupe, nhsups,
201 > ulsort, langue, codret)
205 c 2.2.==> tableaux du maillage
207 if ( codret.eq.0 ) then
209 #ifdef _DEBUG_HOMARD_
210 write (ulsort,texte(langue,3)) 'UTAD01', nompro
213 call utad01 ( iaux, nhnoeu,
216 > pcoono, pareno, jaux, adcocs,
217 > ulsort, langue, codret )
221 #ifdef _DEBUG_HOMARD_
222 write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
225 if ( degre.eq.2 ) then
228 call utad02 ( iaux, nharet,
229 > phetar, psomar, pfilar, jaux,
230 > pfamar, pcfaar, jaux,
231 > jaux , pnp2ar, jaux,
233 > ulsort, langue, codret )
235 if ( nbquto.gt.0 ) then
237 #ifdef _DEBUG_HOMARD_
238 write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
241 call utad02 ( iaux, nhquad,
242 > phetqu, parequ, jaux, jaux,
243 > pfamqu, pcfaqu, jaux,
246 > ulsort, langue, codret )
250 epsid2 = max(1.d-14,epsima)
251 #ifdef _DEBUG_HOMARD_
252 write (ulsort,90004) 'epsid2', epsid2
258 c 3. Decompte des entites concernees par la frontiere
260 #ifdef _DEBUG_HOMARD_
261 write (ulsort,90002) '3. Decompte ; codret', codret
264 c 3.1. ==> Decompte des aretes concernees par la frontiere
266 if ( codret.eq.0 ) then
271 #ifdef _DEBUG_HOMARD_
272 write (ulsort,texte(langue,3)) 'SFCONA', nompro
274 call sfcona ( iaux, nbarfr, imem(iaux),
275 > imem(phetar), imem(pcfaar), imem(pfamar),
276 > ulsort, langue, codret )
280 #ifdef _DEBUG_HOMARD_
281 if ( codret.eq.0 ) then
282 if ( nbarfr.eq.0 ) then
283 write (ulsort,texte(langue,6)) mess14(langue,1,1)
285 write (ulsort,texte(langue,7)) mess14(langue,3,1), nbarfr
290 c 3.2. ==> Decompte des quadrangles concernes par la frontiere
293 cgn if ( nbquto.lt.0 ) then
295 cgn if ( codret.eq.0 ) then
300 cgn#ifdef _DEBUG_HOMARD_
301 cgn write (ulsort,texte(langue,3)) 'SFCONQ', nompro
303 cgn call sfconq ( iaux, nbqufr, imem(iaux),
304 cgn > imem(phetqu), imem(pcfaqu), imem(pfamqu),
305 cgn > ulsort, langue, codret )
309 cgn#ifdef _DEBUG_HOMARD_
310 cgn if ( codret.eq.0 ) then
311 cgn if ( nbarfr.eq.0 ) then
312 cgn write (ulsort,texte(langue,6)) mess14(langue,1,4)
314 cgn write (ulsort,texte(langue,7)) mess14(langue,3,4), nbqufr
321 c 3.3. ==> Nombre de frontieres discretes ou CAO
322 #ifdef _DEBUG_HOMARD_
323 write (ulsort,90002) '3.3 ; codret', codret
324 write (ulsort,90002) 'nbarfr', nbarfr
325 write (ulsort,90002) 'taopti(29) (suifro)', taopti(29)
326 call gmprsx ( nompro, taopts(17) )
329 if ( nbarfr.gt.0 .and.
330 > ( mod(taopti(29),2).eq.0 ) ) then
332 c 3.3.1. ==> Au premier passage
334 if ( taopti(10).eq.0 ) then
336 if ( codret.eq.0 ) then
339 call gmliat ( ncafdg, 1, nbfrdi, codret )
347 if ( codret.eq.0 ) then
349 call gmliat ( nhsupe, 10, nbfrdi, codret )
355 #ifdef _DEBUG_HOMARD_
356 write (ulsort,90002) 'nbfrdi', nbfrdi
364 #ifdef _DEBUG_HOMARD_
365 write (ulsort,90002) '4. Affichage ; codret', codret
366 write (ulsort,90002) 'nbarfr', nbarfr
369 if ( nbarfr.gt.0 ) then
371 if ( codret.eq.0 ) then
378 #ifdef _DEBUG_HOMARD_
379 write (ulsort,texte(langue,3)) 'SFFAFF', nompro
381 call sffaff ( taopti(29),
382 > ncafdg, ncafan, ncfgnf, ncfgng, ncafar,
384 > ulsort, langue, codret )
391 c 5. frontiere CAO : initialisations des fichiers
393 #ifdef _DEBUG_HOMARD_
394 write (ulsort,90002) '5. frontiere CAO ; codret', codret
397 if ( mod(taopti(29),5).eq.0 ) then
399 if ( codret.eq.0 ) then
400 #ifdef _DEBUG_HOMARD_
401 call gmprsx ( nompro, nhsupe//'.Tab10' )
402 call gmprsx ( nompro, nhsups//'.Tab10' )
405 call gmadoj ( nhsupe//'.Tab10', adfrgr, iaux, codre1 )
406 call gmadoj ( nhsups//'.Tab10', adnogr, iaux, codre2 )
407 call gmliat ( nhsupe, 10, nbfrgr, codre3 )
409 codre0 = min ( codre1, codre2, codre3 )
410 codret = max ( abs(codre0), codret,
411 > codre1, codre2, codre3 )
415 if ( codret.eq.0 ) then
417 call gmalot ( taopts(27), 'entier', nbfrgr, adulgr, codret )
421 if ( codret.eq.0 ) then
425 do 51 , iaux = 1, nbfrgr
427 if ( imem(adfrgr+iaux-1).gt.0 ) then
431 elseif ( imem(adfrgr+iaux-1).lt.0 ) then
439 if ( jaux.ge.0 ) then
441 if ( codret.eq.0 ) then
443 call utench ( jaux, '0', kaux, saux02,
444 > ulsort, langue, codret )
448 call guoufs ( saux07, jaux, kaux, codret )
452 if ( codret.eq.0 ) then
454 call uts8ch ( smem(adnogr+(iaux-1)*10), 80, saux80,
455 > ulsort, langue, codret )
456 write (kaux,*) saux80
466 imem(adulgr+iaux-1) = kaux
471 #ifdef _DEBUG_HOMARD_
472 call gmprsx ( nompro, taopts(27) )
478 c 6. Conversion de la description de la geometrie analytique
479 c Il faut normaliser les axes ; on ne le fait pas avant pour
480 c avoir un affichage conforme a la donnee de l'utilisateur
482 #ifdef _DEBUG_HOMARD_
483 write (ulsort,90002) '6. Conversion geometrie ; codret', codret
486 if ( nbarfr.gt.0 .and. mod(taopti(29),3).eq.0 ) then
488 if ( codret.eq.0 ) then
490 call gmadoj ( ncafar, adcafr, jaux, codret )
494 if ( codret.eq.0 ) then
497 #ifdef _DEBUG_HOMARD_
498 write (ulsort,texte(langue,3)) 'SFCOI1', nompro
500 call sfcoi1 ( jaux, rmem(adcafr),
501 > ulsort, langue, codret)
508 c 7. Conversion de la description de la geometrie discrete
510 #ifdef _DEBUG_HOMARD_
511 write (ulsort,90002) '7. Conversion geometrie ; codret', codret
512 write (ulsort,90002) 'taopti(29)', taopti(29)
513 write (ulsort,90002) 'nbfrdi', nbfrdi
514 write (ulsort,90002) 'nbarfr', nbarfr
517 if ( taopti(29).lt.0 .and. mod(taopti(29),2).eq.0 .and.
518 > nbfrdi.gt.0 .and. nbarfr.gt.0 ) then
520 if ( codret.eq.0 ) then
522 #ifdef _DEBUG_HOMARD_
523 write (ulsort,texte(langue,3)) 'SFCONV', nompro
525 call sfconv ( lgopti, taopti, lgopts, taopts,
527 > ulsort, langue, codret)
531 if ( codret.eq.0 ) then
535 call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 )
536 call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre2 )
537 call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre3 )
538 call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre4 )
540 codre0 = min ( codre1, codre2, codre3, codre4 )
541 codret = max ( abs(codre0), codret,
542 > codre1, codre2, codre3, codre4 )
549 c 8. Quand on est parti d'un macro-maillage : inhibition du suivi
550 c de frontiere sur les lignes droites
553 #ifdef _DEBUG_HOMARD_
554 write (ulsort,90002) '8. lignes droites ; codret', codret
557 if ( nbfrdi.gt.0 .and. nbarfr.gt.0 ) then
559 if ( taopti(10).eq.0 ) then
561 if ( codret.eq.0 ) then
563 #ifdef _DEBUG_HOMARD_
564 write (ulsort,texte(langue,3)) 'SFINDR', nompro
566 call sfindr ( imem(psegli), imem(pcfaar), imem(pfamar),
568 > ulsort, langue, codret )
577 c 9. Quand on est parti d'un macro-maillage : determination du
578 c comportement en degre 2
580 #ifdef _DEBUG_HOMARD_
581 write (ulsort,90002) '9. degre 2 ; codret', codret
584 if ( taopti(10).eq.0 ) then
586 if ( codret.eq.0 ) then
588 c 9.1. ==> en degre 1, c'est simple
590 if ( degre.eq.1 ) then
594 c 9.2. ==> en degre 2, tout depent de la position initiale des noeuds P2
598 #ifdef _DEBUG_HOMARD_
599 write (ulsort,texte(langue,3)) 'SFPOP2', nompro
601 call sfpop2 ( typsfr,
603 > imem(psomar), imem(pnp2ar),
604 > imem(pcfaar), imem(pfamar),
606 > ulsort, langue, codret)
610 if ( codret.eq.0 ) then
611 call gmecat ( nomail, 10, typsfr, codret )
619 c 10. Noeuds initiaux et frontiere
620 c Attention : sfcaf1 et sfcoin doivent etre coherents
622 #ifdef _DEBUG_HOMARD_
623 write (ulsort,90002) '10. Noeuds ini / frontiere ; codret', codret
626 if ( taopti(10).eq.0 ) then
628 if ( taopti(29).lt.0 .and. nbfrdi.gt.0 ) then
630 cgn call gmprot(nompro,nhnoeu//'.Coor',115,115)
632 if ( codret.eq.0 ) then
634 unst2x = 1.d0 / rmem(adcocs+10)**2
636 #ifdef _DEBUG_HOMARD_
637 write (ulsort,texte(langue,3)) 'SFNOFL', nompro
639 call sfnofl ( ntrav1, ntrav2, ntrav3,
640 > adnuno, adlino, adacno,
643 > imem(psomar), imem(phetar), imem(pfilar),
645 > imem(pcfaar), imem(pfamar),
646 > rmem(pgeoco), rmem(adabsc),
647 > imem(psomse), imem(psegli),
649 > ulsort, langue, codret )
657 cgn call gmprot(nompro,nhnoeu//'.Coor',115,115)
663 if ( codret.eq.0 ) then
665 taopti(29) = abs(taopti(29))
673 if ( codret.ne.0 ) then
677 write (ulsort,texte(langue,1)) 'Sortie', nompro
678 write (ulsort,texte(langue,2)) codret
682 #ifdef _DEBUG_HOMARD_
683 write (ulsort,texte(langue,1)) 'Sortie', nompro