The TELEMAC-MASCARET system  trunk
ranbo.f
Go to the documentation of this file.
1 ! ****************
2  SUBROUTINE ranbo
3 ! ****************
4 !
5  &(nbor,kp1bor,ifabor,ikle,ncolor,trav1,nptfr,x,y,ncolfr,
6  & ndp,npoin,nelem,nelmax,mesh)
7 !
8 !***********************************************************************
9 ! PROGICIEL : STBTEL V5.2 10/02/93 J.M. JANIN (LNH)
10 !***********************************************************************
11 !
12 !brief Building the table of boundary segments
13 !
14 
15 !history S.E.BOURBAN (HRW)
16 !+ 21/03/2017
17 !+ V7P3
18 !+ Replacement of the DATA declarations by the PARAMETER associates
19 !
20 !-----------------------------------------------------------------------
21 ! ARGUMENTS
22 ! .________________.____.______________________________________________.
23 ! | NOM |MODE| ROLE |
24 ! |________________|____|______________________________________________|
25 ! | NBOR |<-- | TABLEAU DES POINTS DE BORD |
26 ! | IFABOR | -->| TABLEAU DES VOISINS DES FACES. |
27 ! | IKLE | -->| NUMEROS GLOBAUX DES POINTS DE CHAQUE ELEMENT |
28 ! | NCOLOR | -->| TABLEAU DES COULEURS DES POINTS |
29 ! | NCOLFR |<-- | TABLEAU DES COULEURS DES POINTS DE BORD |
30 ! | TRAV1 |<-->| TABLEAU DE TRAVAIL |
31 ! | NPTFR |<-- | NOMBRE DE POINTS DE BORD
32 ! |________________|____|______________________________________________
33 ! | COMMON: | |
34 ! | GEO: | |
35 ! | MESH | -->| TYPE DES ELEMENTS DU MAILLAGE
36 ! | NDP | -->| NOMBRE DE NOEUDS PAR ELEMENTS
37 ! | NPOIN | -->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
38 ! | NELEM | -->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
39 ! | NELMAX | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
40 ! | | | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
41 ! |________________|____|______________________________________________|
42 ! MODE: -->(DONNEE NON MODIFIEE),<--(RESULTAT),<-->(DONNEE MODIFIEE)
43 !-----------------------------------------------------------------------
44 ! APPELE PAR : STBTEL
45 ! APPEL DE : -
46 !***********************************************************************
47 !
49  IMPLICIT NONE
50 !
51 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
52 !
53  INTEGER, INTENT(IN) :: NDP,NELMAX,MESH,NELEM,NPOIN
54  INTEGER, INTENT(INOUT) :: NPTFR
55  INTEGER, INTENT(INOUT) :: NBOR(*),KP1BOR(*),NCOLFR(*)
56  INTEGER, INTENT(INOUT) :: TRAV1(npoin,2)
57  INTEGER, INTENT(IN) :: IFABOR(nelmax,*),IKLE(nelmax,ndp)
58  INTEGER, INTENT(IN) :: NCOLOR(*)
59  DOUBLE PRECISION, INTENT(IN) :: X(npoin),Y(npoin)
60 !
61 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
62 !
63  INTEGER IILE,NILE,I,ISUIV,IELEM,IFACE,NOEUD1,NOEUD2
64  INTEGER IERROR, I1, I2
65 !
66  DOUBLE PRECISION SOM1,SOM2,Y2
67 !
68  LOGICAL SWAP
69 !
70  INTEGER :: SOMSUI(4) = (/ 2 , 3 , 4 , 0 /)
71  DOUBLE PRECISION, PARAMETER :: EPSILO = 1.d-6
72 !
73 !=======================================================================
74 ! INITIALISATION
75 !=======================================================================
76 !
77  somsui(ndp) = 1
78  IF (mesh.NE.2.AND.mesh.NE.3) THEN
79  WRITE(lu,4000) mesh
80 4000 FORMAT(/,1x,'RANBO : MESH NOT ALLOWED , MESH = ',i4,/)
81  CALL plante(1)
82  stop
83  ENDIF
84 !
85 !=======================================================================
86 ! RECHERCHE DES ARETES DE BORD,NUMEROTEES DE 1 A NPTFR
87 !=======================================================================
88 !
89  nptfr = 0
90  DO ielem=1,nelem
91  DO iface=1,ndp
92  IF(ifabor(ielem,iface).LE.0) THEN
93  nptfr = nptfr + 1
94  trav1(nptfr,1) = ikle(ielem, iface )
95  trav1(nptfr,2) = ikle(ielem,somsui(iface))
96  ENDIF
97  ENDDO
98  ENDDO
99 !
100 !=======================================================================
101 ! ON VERIFIE QUE CHAQUE POINT N'APPARAIT QUE DEUX FOIS
102 ! ( UNE FOIS COMME NOEUD 1 , UNE FOIS COMME NOEUD 2 )
103 !=======================================================================
104 !
105  ierror = 0
106  DO i=1,nptfr
107  i1 = 1
108  i2 = 1
109  DO isuiv=1,nptfr
110  IF (trav1(i,1).EQ.trav1(isuiv,2)) i1 = i1 + 1
111  IF (trav1(i,2).EQ.trav1(isuiv,1)) i2 = i2 + 1
112  ENDDO
113  IF (i1.NE.2) THEN
114  ierror = ierror + 1
115  WRITE(lu,1020) x(trav1(i,1)),y(trav1(i,1)),i1
116  ENDIF
117  IF (i2.NE.2) THEN
118  ierror = ierror + 1
119  WRITE(lu,1020) x(trav1(i,2)),y(trav1(i,2)),i2
120  ENDIF
121  ENDDO
122 !
123 1020 FORMAT(1x,'ERROR ON BOUNDARY NODE :',/,
124  & 1x,'X=',f13.3,' Y=',f13.3,/,
125  & 1x,'IT BELONGS TO',i2,' BOUNDARY SEGMENT(S)')
126 !
127  IF (ierror.GT.0) THEN
128  CALL plante(1)
129  stop
130  ENDIF
131 !
132 !=======================================================================
133 ! RANGEMENT DES ARETES DE BORD BOUT A BOUT.
134 ! ON COMMENCE ARBITRAIREMENT PAR LE POINT LE PLUS SUD-OUEST
135 ! ( PUIS LE PLUS SUD SI CONFLIT ) AFIN D'ETRE SUR DE COMMENCER
136 ! SUR LE CONTOUR ET NON SUR UNE ILE |||
137 !=======================================================================
138 !
139  som2 = x(1) + y(1)
140  y2 = y(1)
141 !
142  DO i=1,nptfr
143 !
144  som1 = x(trav1(i,1)) + y(trav1(i,1))
145  IF (abs(som1-som2).LE.abs(epsilo*som1)) THEN
146  IF (y(trav1(i,1)).LE.y2) THEN
147  y2 = y(trav1(i,1))
148  som2 = som1
149  isuiv = i
150  ENDIF
151  ELSEIF (som1.LE.som2) THEN
152  y2 = y(trav1(i,1))
153  som2 = som1
154  isuiv = i
155  ENDIF
156 !
157  ENDDO
158 !
159  noeud1 = trav1(isuiv,1)
160  noeud2 = trav1(isuiv,2)
161  trav1(isuiv,1) = trav1(1,1)
162  trav1(isuiv,2) = trav1(1,2)
163  trav1(1,1) = noeud1
164  trav1(1,2) = noeud2
165 !
166  iile = 0
167  nile = 1
168 !
169  DO i=2,nptfr
170  swap = .false.
171 !
172 !=======================================================================
173 ! RECHERCHE DE L'ARETE DONT LE PREMIER NOEUD EST IDENTIQUE AU SECOND
174 ! DE L'ARETE PRECEDENTE
175 !=======================================================================
176 !
177  DO isuiv=i,nptfr
178 !
179  IF (trav1(isuiv,1).EQ.trav1(i-1,2)) THEN
180 !
181 !=======================================================================
182 ! PERMUTATION DES ARETES DE NUMEROS I+1 ET ISUIV
183 !=======================================================================
184 !
185  noeud1 = trav1(isuiv,1)
186  noeud2 = trav1(isuiv,2)
187  trav1(isuiv,1) = trav1(i,1)
188  trav1(isuiv,2) = trav1(i,2)
189  trav1(i,1) = noeud1
190  trav1(i,2) = noeud2
191  kp1bor(i+nptfr) = i-1
192  kp1bor(i-1) = i
193  swap = .true.
194  EXIT
195 !
196  ENDIF
197 !
198  ENDDO
199  IF(swap) cycle
200 !
201 !=======================================================================
202 ! SI ON NE TROUVE PAS DE POINT SUIVANT : ON VERIFIE QUE LE DERNIER POINT
203 ! TROUVE EST IDENTIQUE AU PREMIER , DANS CE CAS ON EST EN PRESENCE D'UNE
204 ! ILE ET ON ITERE LE PROCESSUS GLOBAL
205 !=======================================================================
206 !
207  IF (trav1(nile,1).NE.trav1(i-1,2)) THEN
208 !
209 !=======================================================================
210 ! SINON IL Y A ERREUR
211 !=======================================================================
212 !
213  WRITE(lu,4500) trav1(i-1,2)
214 4500 FORMAT(1x,'ERROR IN STORING THE EDGE SEGMENTS',/,
215  & 1x,'FOR THE NODE ',i5)
216  CALL plante(1)
217  stop
218  ENDIF
219 !
220  kp1bor(nile+nptfr) = i-1
221  kp1bor(i-1) = nile
222  iile = iile+1
223  nile = i
224 !
225  ENDdo! ISUIV
226 !
227 !=======================================================================
228 ! ON VERIFIE QUE LA DERNIERE ILE EST FERMEE
229 !=======================================================================
230 !
231  IF (trav1(nile,1).NE.trav1(nptfr,2)) THEN
232  WRITE(lu,5000) trav1(nile,1),trav1(nptfr,2)
233 5000 FORMAT(1x,'ERROR, THE BOUNDARY IS NOT CLOSED :',/,
234  & 1x,'FIRST POINT :',i5,2x,'LAST POINT : ',i5)
235  CALL plante(1)
236  stop
237  ENDIF
238 !
239  kp1bor(nile+nptfr) = nptfr
240  kp1bor(nptfr) = nile
241 !
242  WRITE(lu,5500) nptfr
243  WRITE(lu,5600) iile
244  5500 FORMAT(1x,'NUMBER OF BOUNDARY POINTS : ',i5)
245  5600 FORMAT(1x,'NUMBER OF ISLANDS : ',i5)
246 !
247 !=======================================================================
248 ! REMPLISSAGE DU TABLEAU NBOR ET STOCKAGE DE LA COULEUR DES POINTS DE
249 ! BORD DANS LE TABLEAU NCOLFR
250 !=======================================================================
251 !
252  DO i=1,nptfr
253  nbor(i ) = trav1(i,1)
254  nbor(i+nptfr) = trav1(i,2)
255  ncolfr(i) = ncolor(trav1(i,1))
256  ENDDO
257 !
258  RETURN
259  END
subroutine ranbo(NBOR, KP1BOR, IFABOR, IKLE, NCOLOR, TRAV1, NPTFR, X, Y, NCOLFR, NDP, NPOIN, NELEM, NELMAX, MESH)
Definition: ranbo.f:8