subroutine sfliso ( numnoe, lignoe, abscno, > unst2x, epsid2, > coonoe, > somare, hetare, filare, np2are, > cfaare, famare, > geocoo, abscur, > somseg, seglig, segnoe, > ulsort, langue, codret) c ______________________________________________________________________ c c H O M A R D c c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D c c Version originale enregistree le 18 juin 1996 sous le numero 96036 c aupres des huissiers de justice Simart et Lavoir a Clamart c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 c aupres des huissiers de justice c Lavoir, Silinski & Cherqui-Abrahmi a Clamart c c HOMARD est une marque deposee d'Electricite de France c c Copyright EDF 1996 c Copyright EDF 1998 c Copyright EDF 2002 c Copyright EDF 2020 c ______________________________________________________________________ c c Suivi de Frontiere - LIen des SOmmets c - - -- -- c ______________________________________________________________________ c . . . . . c . nom . e/s . taille . description . c .____________________________________________________________________. c . numnoe . s . mcnvnf . liste des noeuds de calcul de frontiere . c . lignoe . s . mcnvnf . liste lignes pour ces noeuds . c . abscno . s . mcnvnf . abscisse curviligne de ces noeuds . c . unst2x . e . 1 . inverse de la taille maximale au carre . c . epsid2 . e . 1 . precision relative pour carre de distance . c . coonoe . es . nbnoto . coordonnees des noeuds . c . . . *sdim . . c . somare . e .2*nbarto. numeros des extremites d'arete . c . hetare . e . nbarto . historique de l'etat des aretes . c . filare . e . nbarto . premiere fille des aretes . c . np2are . e . nbarto . noeud milieux des aretes . c . cfaare . e . nctfar*. codes des familles des aretes . c . . . nbfare . 1 : famille MED . c . . . . 2 : type de segment . c . . . . 3 : orientation . c . . . . 4 : famille d'orientation inverse . c . . . . 5 : numero de ligne de frontiere . c . . . . > 0 si concernee par le suivi de frontiere. c . . . . <= 0 si non concernee . c . . . . 6 : famille frontiere active/inactive . c . . . . 7 : numero de surface de frontiere . c . . . . + l : appartenance a l'equivalence l . c . famare . es . nbarto . famille des aretes . c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . c . abscur . e . sfnbse . abscisse curviligne des somm des segments . c . somseg . e . sfnbse . liste des sommets des lignes separees par . c des 0 . c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . c . . . . segments de la ligne i sont aux places de . c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . c . segnoe . aux . nbnoto . segments lies aux noeuds . c . ulsort . e . 1 . numero d'unite logique de la liste standard. c . langue . e . 1 . langue des messages . c . . . . 1 : francais, 2 : anglais . c . codret . es . 1 . code de retour des modules . c . . . . 0 : pas de probleme . c . . . . x : probleme . c ______________________________________________________________________ c c==== c 0. declarations et dimensionnement c==== c c 0.1. ==> generalites c implicit none save c character*6 nompro parameter ( nompro = 'SFLISO' ) c #include "nblang.h" #include "cofaar.h" #include "cofina.h" c c 0.2. ==> communs c #include "envex1.h" #include "envca1.h" #include "front1.h" #include "front2.h" #include "dicfen.h" #include "nbfami.h" #include "nombno.h" #include "nombar.h" #include "impr02.h" c c 0.3. ==> arguments c double precision unst2x, epsid2 double precision coonoe(nbnoto,sdim), geocoo(sfnbso,*) double precision abscno(mcnxnf) double precision abscur(sfnbse) c integer numnoe(mcnxnf), lignoe(mcnxnf) integer seglig(0:sfnbli), somseg(sfnbse) integer segnoe(nbnoto) integer somare(2,nbarto), hetare(nbarto), filare(nbarto) integer np2are(nbarto) integer famare(nbarto), cfaare(nctfar,nbfare) c integer ulsort, langue, codret c c 0.4. ==> variables locales c integer iaux, jaux integer lenoeu, larete integer seg, segm(3) integer lig, ligv integer nbsomm integer nbar00 #ifdef _DEBUG_HOMARD_ integer glop common / tutu / glop #endif c double precision coop(3), acnoeu c integer nbmess parameter ( nbmess = 20 ) character*80 texte(nblang,nbmess) c c 0.5. ==> initialisations c ______________________________________________________________________ c c==== c 1. messages c==== c 1.1. ==> les messages c #include "impr01.h" c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Entree', nompro call dmflsh (iaux) #endif c texte(1,4) = '(''. Nombre de '',a,'' du maillage :'',i10)' texte(1,5) = '(''Boucle sur les aretes'')' texte(1,6) = '(/,''Arete'',i10,'', sur la ligne'',i10)' texte(1,7) = >'(/,'' .. Examen du noeud du cote'',i2,'' :'',i10,'', seg ='',i5)' texte(1,9) = '(6x,''Une arete est de longueur'')' texte(1,10) = '(i5,'' aretes sont de longueur'')' texte(1,11) = > '(6x,''inferieure a la discretisation de la frontiere'')' texte(1,12) = '(a,'' Inhibition du sf sur l''''arete'',i10)' texte(1,20) = >'(5x,''Examen des noeuds situes sur des extremites de ligne'')' c texte(2,4) = '(''. Number of '',a,'' in mesh :'',i10)' texte(2,5) = '(''Loop over edges'')' texte(2,6) = '(/,''Edge #'',i10,'', on line'',i10)' texte(2,7) = > '(/,'' .. Examination of node #'',i2,'' #'',i10,'', seg ='',i5)' texte(2,9) = '(6x,''One edge is with length'')' texte(2,10) = '(i5,'' edges are with length'')' texte(2,11) = > '(6x,''lower than the discretization of the boundary'')' texte(2,12) = '(a,'' Inhibition of bf for the edge #'',i10)' texte(2,20) = '(5x,''Examination of nodes located on lines'')' c #include "impr03.h" c c 1.2. ==> a priori, aucun segment n'est attache a un noeud c do 12 , lenoeu = 1 , nbnoto segnoe(lenoeu) = 0 12 continue c if ( typsfr.le.2 ) then nbsomm = 2 else nbsomm = 3 endif c nbar00 = 0 c mcnvnf = 0 c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarto #endif c cgn write(ulsort,90002) 'somseg', somseg #ifdef _DEBUG_HOMARD_ do 13 , iaux = 1, sfnbli write(ulsort,90002) 'somseg pour la ligne numero', iaux jaux = 0 do 131 , seg = seglig(iaux-1)+1, seglig(iaux)-1 jaux = jaux + 1 write(ulsort,90012) '.. sommet numero', jaux, somseg(seg) 131 continue 13 continue #endif c c==== c 2. Boucle sur les aretes qui sont actives et positionnees sur c une ligne de frontiere c On va situer les sommets sur la ligne c==== #ifdef _DEBUG_HOMARD_ write (ulsort,*) '2. boucle sur les aretes ; codret = ', codret #endif c if ( codret.eq.0 ) then c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,5)) #endif c do 20 , larete = 1 , nbarto c #ifdef _DEBUG_HOMARD_ c if ( larete.le.0 .or. c > ( larete.eq.1 .or. larete.eq.8 .or. c > larete.eq.9 ) ) then if ( larete.le.0 ) then glop = 1 else glop = 0 endif #endif c lig = cfaare(cosfli,famare(larete)) #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write (ulsort,texte(langue,6)) larete, lig endif #endif c if ( lig.gt.0 ) then c if ( hetare(larete).ne.50 ) then #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then iaux = seglig(lig-1) + 1 jaux = seglig(lig) write (ulsort,90002) 'Sommets extremites de cette ligne', >somseg(iaux), somseg(jaux-1) endif #endif c c On parcourt les noeuds de l'arete c do 200 , jaux = 1 , nbsomm c c 2.1. ==> Le noeud et son segment initial c if ( codret.eq.0 ) then c if ( jaux.le.2 ) then lenoeu = somare(jaux,larete) else lenoeu = np2are(larete) endif seg = segnoe(lenoeu) #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write (ulsort,texte(langue,7)) jaux, lenoeu, seg if ( seg.lt.0 ) then write (ulsort,90002) > 'Le noeud est une extremite de la ligne', lig elseif ( seg.eq.0 ) then write (ulsort,*) '... Ce noeud n''est pas encore place.' else write (ulsort,90002) > 'Le noeud a deja ete place sur le segment', seg endif endif #endif c c 2.2. ==> Le noeud est une extremite de ligne ou n'a pas ete place c if ( seg.le.0 ) then c do 221 , iaux = 1 , sdim coop(iaux) = coonoe(lenoeu,iaux) 221 continue c #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write (ulsort,90024) 'apres 221, coop du noeud', > lenoeu, (coop(iaux),iaux=1,sdim) endif #endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'SFSENO', nompro #endif call sfseno ( coop, lig, unst2x, epsid2, > seglig, somseg, geocoo, abscur, > seg, acnoeu ) c #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write (ulsort,90024) 'apres appel a sfseno, coop du noeud', > lenoeu, (coop(iaux),iaux=1,sdim) write (ulsort,90004) '==> acnoeu', acnoeu write (ulsort,90002) 'Ce noeud a ete mis sur le segment', seg endif #endif segm(jaux) = seg c if ( seg.ne.0 ) then c do 222 , iaux = 1 , mcnvnf if ( numnoe(iaux).eq.lenoeu ) then if ( lignoe(iaux).eq.lig ) then cgn write (ulsort,*) ' enregistrement deja fait' goto 200 endif endif 222 continue c segnoe(lenoeu) = seg c mcnvnf = mcnvnf + 1 cgn write (ulsort,90002) ' enregistrement a la position', mcnvnf numnoe(mcnvnf) = lenoeu lignoe(mcnvnf) = lig abscno(mcnvnf) = acnoeu c les noeuds sont forces sur la frontiere cgn acnoeu=0.d0 cgn do 2222 , iaux = 1 , sdim cgn acnoeu = acnoeu+(coonoe(lenoeu,iaux)-coop(iaux))**2 cgn 2222 continue cgn write (ulsort,*) 223, lenoeu,acnoeu #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 .or. lenoeu.eq.-102 ) then write (ulsort,90024) 'avant 222, coonoe du noeud', > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) endif #endif do 223 , iaux = 1 , sdim cgn write (ulsort,*) iaux,coonoe(lenoeu,iaux),coop(iaux) coonoe(lenoeu,iaux) = coop(iaux) 223 continue #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 .or. lenoeu.eq.-102 ) then write (ulsort,90024) 'apres 223, coonoe du noeud', > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) endif #endif #ifdef _DEBUG_HOMARD_ c else c codret = codret + 1 #endif c endif c c 2.3. ==> Le noeud est deja situe sur un segment interieur c De quelle ligne ? c else #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 .or. lenoeu.eq.-102 ) then write (ulsort,90024) ' .... Noeud', > lenoeu,(coonoe(lenoeu,iaux),iaux=1,sdim) write (ulsort,*) 'deja sur le segment ',seg endif #endif c call sflise( ligv, seg, seglig, > ulsort, langue, codret) c if ( codret.eq.0 ) then c if ( ligv.eq.lig ) then c c 2.3.1 ==> meme ligne : pas de probleme c segm(jaux) = seg c else c c 2.3.2 ==> autre ligne : on le retire c segm(jaux) = 0 c endif c endif c endif c endif c 200 continue c c 2.4. ==> Combien de noeuds de l'arete pointent sur la ligne ? c if ( codret.eq.0 ) then c if ( segm(1).eq.0 .and. segm(2).eq.0 ) then c c 2.4.1. ==> Aucun : impression, et prohibition du sf c 20100 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ', > 'un sommet n''est pas situe') write(ulsort,20100) > larete,(somare(iaux,larete),iaux=1,2),lig iaux = cfaare(cosfin,famare(larete)) famare(larete) = iaux #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write(ulsort,texte(langue,12)) '2.4.1', larete endif #endif if ( mod(hetare(larete),10).eq.2 ) then do 241 , iaux = 0 , 1 jaux = cfaare(cosfin,famare(filare(larete)+iaux)) famare(filare(larete)+iaux) = jaux #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write(ulsort,texte(langue,12)) '2.4.1',filare(larete)+iaux endif #endif 241 continue endif c elseif ( abs(segm(1)).eq.abs(segm(2)) ) then c c 2.4.2. ==> Les deux ; et ils pointent vers le meme segment c Il ne sert plus a rien de suivre la frontiere pour c cette arete : on a atteint la discretisation minimale c #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then 20200 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ', > 'meme segment',i10) write(ulsort,20200) > larete,(somare(iaux,larete),iaux=1,2),lig,abs(segm(1)) write(ulsort,texte(langue,12)) '2.4.2', larete endif #endif nbar00 = nbar00 + 1 iaux = cfaare(cosfin,famare(larete)) famare(larete) = iaux if ( mod(hetare(larete),10).eq.2 ) then do 242 , iaux = 0 , 1 jaux = cfaare(cosfin,famare(filare(larete)+iaux)) famare(filare(larete)+iaux) = jaux #ifdef _DEBUG_HOMARD_ if ( glop.ne.0 ) then write(ulsort,texte(langue,12)) '2.4.2',filare(larete)+iaux endif #endif 242 continue endif c endif c endif c endif c endif c 20 continue c endif c c==== c 3. impressions c==== #ifdef _DEBUG_HOMARD_ write(ulsort,*) '3. impressions, codret =', codret #endif c if ( nbar00.ne.0 ) then if ( nbar00.eq.1 ) then write (ulsort,texte(langue,9)) else write (ulsort,texte(langue,10)) nbar00 endif write (ulsort,texte(langue,11)) endif c c==== c 4. la fin c==== c if ( codret.ne.0 ) then c #include "envex2.h" c write (ulsort,texte(langue,1)) 'Sortie', nompro write (ulsort,texte(langue,2)) codret c endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Sortie', nompro call dmflsh (iaux) #endif c end