The TELEMAC-MASCARET system  trunk
mod_handle_weirs.f
Go to the documentation of this file.
1 ! ***********************
2  MODULE mod_handle_weirs
3 ! ***********************
4 !
5 !***********************************************************************
6 ! PARTEL
7 !***********************************************************************
8 !
9 !BRIEF Treatment of weirs
10 !
11 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
12 
13  IMPLICIT NONE
14  CONTAINS
15 ! ***********************
16  SUBROUTINE handle_weirs
17 ! ***********************
18 !
19  & (nameseu, nparts, knogl, npoin2)
20 !
21 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
22 !| NAMESEU |<--| Name of weirs file
23 !| NPARTS |<--| Number of partitions
24 !| KNOGL |<->| Global to local numbering
25 !| NPOIN2 |<--| Number of 2d points
26 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
27 !
28  USE declarations_special
29  USE declarations_partel
30  USE mod_hash_table
31  USE bief, ONLY : nbmaxnshare
32 !
33 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
34 !
35  CHARACTER(LEN=PATH_LEN), INTENT(IN) :: NAMESEU
36  INTEGER, INTENT(IN) :: NPARTS
37  TYPE(hash_table), INTENT(INOUT) ::KNOGL
38  INTEGER, INTENT(IN) :: NPOIN2
39 !
40 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
41 !
42  CHARACTER(LEN=PATH_LEN) :: NAMEOUT
43  INTEGER :: NOUT
44  INTEGER I,J,K,L,M,N,IERR,POSI
45  INTEGER :: NSEU, NBSEU, OPSEU, JJ, PROC
46  INTEGER :: DEB, FIN
47  INTEGER, ALLOCATABLE :: NUM_SEU1(:,:), NUM_SEU2(:,:)
48  INTEGER, ALLOCATABLE :: NUM_SEU1_P(:,:,:), NUM_SEU2_P(:,:,:)
49  INTEGER, ALLOCATABLE :: SEU_P(:,:), CSEU_P(:,:), P_CSEU(:,:)
50  INTEGER, ALLOCATABLE :: LRECV_P(:,:), NRECV_P(:)
51  INTEGER, ALLOCATABLE :: LSEND_PP(:,:,:), LSEND_P(:,:), NSEND_P(:)
52  INTEGER, ALLOCATABLE :: LIST_TMP(:,:)
53  INTEGER, ALLOCATABLE :: IP1(:), IP2(:)
54  INTEGER, ALLOCATABLE :: DEBSEU(:), FINSEU(:)
55  DOUBLE PRECISION :: RELAX
56  DOUBLE PRECISION, ALLOCATABLE :: XSEU1(:), YSEU1(:), ZSEU1(:)
57  DOUBLE PRECISION, ALLOCATABLE :: XSEU2(:), YSEU2(:), ZSEU2(:)
58  DOUBLE PRECISION, ALLOCATABLE :: RP1(:), RP2(:)
59  INTEGER, ALLOCATABLE :: PART_P(:,:)
60  CHARACTER(LEN=11) :: EXTENS
61  EXTERNAL extens
62  CHARACTER(LEN=10) FMT1
63 
64 ! READING THE WEIRS INFORMATIONS
65  CALL get_free_id(nseu)
66  OPEN(nseu,file=trim(nameseu),form='FORMATTED',status='OLD')
67 ! first read to count the total number of elements
68  nbseu = 0
69  READ(nseu,*,end=304,err=305)
70  READ(nseu,*,end=304,err=305) n, k, relax
71  DO i=1, n
72  READ(nseu,*,end=304,err=305)
73  READ(nseu,*,end=304,err=305) k
74  nbseu = nbseu + k
75  DO j=1, k+3
76  READ(nseu,*,end=304,err=305)
77  ENDDO
78  ENDDO
79  rewind(nseu)
80 ! ALLOCATION
81  ALLOCATE (xseu1(nbseu), stat=ierr)
82  CALL check_allocate(ierr, 'XSEU1')
83  xseu1(:) = 0
84  ALLOCATE (yseu1(nbseu), stat=ierr)
85  CALL check_allocate(ierr, 'YSEU1')
86  yseu1(:) = 0
87  ALLOCATE (zseu1(nbseu), stat=ierr)
88  CALL check_allocate(ierr, 'ZSEU1')
89  zseu1(:) = 0
90  ALLOCATE (xseu2(nbseu), stat=ierr)
91  CALL check_allocate(ierr, 'XSEU2')
92  xseu2(:) = 0
93  ALLOCATE (yseu2(nbseu), stat=ierr)
94  CALL check_allocate(ierr, 'YSEU2')
95  yseu2(:) = 0
96  ALLOCATE (zseu2(nbseu), stat=ierr)
97  CALL check_allocate(ierr, 'ZSEU2')
98  zseu2(:) = 0
99  ALLOCATE (rp1(nbseu), stat=ierr)
100  CALL check_allocate(ierr, 'RP1')
101  rp1(:) = 0.d0
102  ALLOCATE (rp2(nbseu), stat=ierr)
103  CALL check_allocate(ierr, 'RP2')
104  rp2(:) = 0.d0
105  ALLOCATE (ip1(nbseu), stat=ierr)
106  CALL check_allocate(ierr, 'IP1')
107  ip1(:) = 0
108  ALLOCATE (ip2(nbseu), stat=ierr)
109  CALL check_allocate(ierr, 'IP2')
110  ip2(:) = 0
111  ALLOCATE (debseu(nbseu), stat=ierr)
112  CALL check_allocate(ierr, 'DEBSEU')
113  debseu(:) = 0
114  ALLOCATE (finseu(nbseu), stat=ierr)
115  CALL check_allocate(ierr, 'FINSEU')
116  finseu(:) = 0
117  ALLOCATE (num_seu1(4,nbseu), stat=ierr)
118  CALL check_allocate(ierr, 'NUM_SEU1')
119  num_seu1(:,:) = 0
120  ALLOCATE (num_seu2(4,nbseu), stat=ierr)
121  CALL check_allocate(ierr, 'NUM_SEU2')
122  num_seu2(:,:) = 0
123 ! Full read of the file
124  READ(nseu,*,end=304,err=305)
125  READ(nseu,*,end=304,err=305) n, opseu, relax
126  j = 0
127  DO m=1, n
128  READ(nseu,*,end=304,err=305)
129  READ(nseu,*,end=304,err=305) jj
130  READ(nseu,*,end=304,err=305)
131  READ(nseu,*,end=304,err=305)
132  READ(nseu,*,end=304,err=305)
133  deb = j+1
134  fin = j+jj
135  DO l=1, jj
136  j = j + 1
137  READ(nseu,*,end=304,err=305) i,
138  & xseu1(j), yseu1(j), zseu1(j),
139  & (num_seu1(k,j), k = 1,4),
140  & xseu2(j), yseu2(j), zseu2(j),
141  & (num_seu2(k,j), k = 1,4),
142  & ip1(j), ip2(j), rp1(j), rp2(j)
143  debseu(j) = deb
144  finseu(j) = fin
145  END DO
146  END DO
147  CLOSE(nseu)
148 !
149  ALLOCATE (part_p(npoin2,0:nbmaxnshare),stat=ierr)
150  CALL check_allocate(ierr, 'PART_P')
151  part_p(:,:)=0
152 ! PARTITION OF THE GLOBAL DOMAIN.
153 ! FOR EACH GLOBAL NODE, PART_P GIVES THE NUMBER AND THE LIST OF SD WHICH CONTAINS THE NODE
154  DO n=1,nparts
155  DO i=1, npoin2
156  IF (hash_table_get(knogl,i,n).GT.0) THEN
157  part_p(i,0)=part_p(i,0)+1
158  posi=part_p(i,0)
159  part_p(i,posi)=n
160  ENDIF
161  END DO
162  END DO
163 !
164  ALLOCATE (seu_p(nbseu,nparts),stat=ierr)
165  CALL check_allocate(ierr, 'SEU_P')
166  seu_p(:,:)=0
167  ALLOCATE (cseu_p(nbseu,0:nbmaxnshare),stat=ierr)
168  CALL check_allocate(ierr, 'CSEU_P')
169  cseu_p(:,:)=0
170  ALLOCATE (p_cseu(nparts,0:nbseu))
171  CALL check_allocate(ierr, 'P_CSEU')
172  p_cseu(:,:)=0
173 ! PARTITION OF THE ELEMENT OF WEIRS.
174 ! SEU_P INDICATE IF THE ELEMENT OF WEIR IS COMPUTED OR NOT BY SD
175  DO n=1,nparts
176  DO j=1,nbseu
177  DO k=1,4
178  IF (hash_table_get(knogl,num_seu1(k,j),n).GT.0) THEN
179  seu_p(j,n)=1
180  END IF
181  IF (hash_table_get(knogl,num_seu2(k,j),n).GT.0) THEN
182  seu_p(j,n)=1
183  END IF
184  END DO
185  END DO
186  END DO
187 ! PARTITION OF THE ELEMENT OF WEIRS.
188 ! FOR EACH ELEMENT, CSEU_P GIVES THE NUMBER AND THE LIST OF SD WHICH COMPUTE THE DISCHARGE
189  DO n=1,nparts
190  DO j=1,nbseu
191  IF (seu_p(j,n)>0) THEN
192  cseu_p(j,0)=cseu_p(j,0)+1
193  posi=cseu_p(j,0)
194  cseu_p(j,posi)=n
195  END IF
196  END DO
197  END DO
198 ! PARTITION OF THE ELEMENT OF WEIRS.
199 ! FOR EACH SD, P_CSEU GIVES THE NUMBER AND THE LIST ELEMENT OF WEIR COMPUTED
200  DO j=1,nbseu
201  DO l=1, cseu_p(j,0)
202  proc = cseu_p(j,l)
203  p_cseu(proc,0) = p_cseu(proc,0)+1
204  posi = p_cseu(proc,0)
205  p_cseu(proc,posi) = j
206  END DO
207  END DO
208 !
209  ALLOCATE (nrecv_p(nparts),stat=ierr)
210  CALL check_allocate(ierr, 'NRECV_P')
211  nrecv_p(:)=0
212  ALLOCATE (lrecv_p(8*nbseu,nparts),stat=ierr)
213  CALL check_allocate(ierr, 'LRECV_P')
214  lrecv_p(:,:)=0
215 ! INFORMATIONS ON THE NODES INVOLVED IN THE ELEMENT OF WEIRS COMPUTATION
216 ! NRECV_P GIVES THE NUMBERS OF NODES USED IN THE COMPUTATION FOR EACH SD
217 ! LRECV_P GIVES THE LIST OF NODES USED IN THE COMPUTATION FOR EACH SD
218  DO n=1,nparts
219  DO j=1,nbseu
220  IF (seu_p(j,n)>0) THEN
221  DO k=1,4
222  DO l=1, nrecv_p(n)
223  IF (num_seu1(k,j) == lrecv_p(l,n)) GOTO 602
224  IF (num_seu1(k,j) < lrecv_p(l,n)) GOTO 601
225  END DO
226  601 CONTINUE
227  nrecv_p(n)=nrecv_p(n)+1
228  DO i= nrecv_p(n),l+1,-1
229  lrecv_p(i,n) = lrecv_p(i-1,n)
230  END DO
231  lrecv_p(l,n)=num_seu1(k,j)
232  602 CONTINUE
233 !
234  DO l=1, nrecv_p(n)
235  IF (num_seu2(k,j) == lrecv_p(l,n)) GOTO 604
236  IF (num_seu2(k,j) < lrecv_p(l,n)) GOTO 603
237  END DO
238  603 CONTINUE
239  nrecv_p(n)=nrecv_p(n)+1
240  DO i= nrecv_p(n),l+1,-1
241  lrecv_p(i,n) = lrecv_p(i-1,n)
242  END DO
243  lrecv_p(l,n)=num_seu2(k,j)
244  604 CONTINUE
245  END DO
246  END IF
247  END DO
248  END DO
249 !
250  ALLOCATE (nsend_p(nparts),stat=ierr)
251  CALL check_allocate(ierr, 'NSEND_P')
252  nsend_p(:)=0
253  ALLOCATE (lsend_p(8*nbseu,nparts),stat=ierr)
254  CALL check_allocate(ierr, 'LSEND_P')
255  lsend_p(:,:)=0
256  ALLOCATE (lsend_pp(nbmaxnshare,8*nbseu,nparts),stat=ierr)
257  CALL check_allocate(ierr, 'LSEND_PP')
258  lsend_pp(:,:,:)=0
259 ! INFORMATIONS ON THE NODES INVOLVED IN THE ELEMENT OF WEIRS COMPUTATION
260 ! NSEND_P GIVES FOR EACH SD THE NUMBERS OF NODES USED IN THE COMPUTATION OF OTHER SD
261 ! LSEND_P GIVES FOR EACH SD THE LIST OF NODES USED IN THE COMPUTATION OF OTHER SD
262 ! LSEND_PP GIVES FOR EACH SD AND FOR EACH NODES USED IN THE COMPUTATION OF OTHER SD THE LIST OF SD
263  DO j=1,nbseu
264  DO m=1, cseu_p(j,0)
265  n = cseu_p(j,m)
266  DO k=1,4
267  IF(hash_table_get(knogl,num_seu1(k,j),n)>0) THEN
268  DO l=1, nsend_p(n)
269  IF (num_seu1(k,j) == lsend_p(l,n)) GOTO 702
270  IF (num_seu1(k,j) < lsend_p(l,n)) GOTO 701
271  END DO
272  701 CONTINUE
273  nsend_p(n)=nsend_p(n)+1
274  DO i= nsend_p(n),l+1,-1
275  lsend_p(i,n) = lsend_p(i-1,n)
276  lsend_pp(:,i,n) = lsend_pp(:,i-1,n)
277  END DO
278  lsend_p(l,n)=num_seu1(k,j)
279  lsend_pp(:,l,n)=0
280  702 CONTINUE
281  DO i=1, cseu_p(j,0)
282  DO jj = 1, nbmaxnshare
283  IF (cseu_p(j,i) == lsend_pp(jj,l,n)) GOTO 703
284  IF (lsend_pp(jj,l,n) == 0) THEN
285  lsend_pp(jj,l,n) = cseu_p(j,i)
286  GOTO 703
287  END IF
288  END DO
289  703 CONTINUE
290  END DO
291  END IF
292 !
293  IF(hash_table_get(knogl,num_seu2(k,j),n)>0) THEN
294  DO l=1, nsend_p(n)
295  IF (num_seu2(k,j) == lsend_p(l,n)) GOTO 705
296  IF (num_seu2(k,j) < lsend_p(l,n)) GOTO 704
297  END DO
298  704 CONTINUE
299  nsend_p(n)=nsend_p(n)+1
300  DO i= nsend_p(n),l+1,-1
301  lsend_p(i,n) = lsend_p(i-1,n)
302  lsend_pp(:,i,n) = lsend_pp(:,i-1,n)
303  END DO
304  lsend_p(l,n)=num_seu2(k,j)
305  lsend_pp(:,l,n)=0
306  705 CONTINUE
307  DO i=1, cseu_p(j,0)
308  DO jj = 1, nbmaxnshare
309  IF (cseu_p(j,i) == lsend_pp(jj,l,n)) GOTO 706
310  IF (lsend_pp(jj,l,n) == 0) THEN
311  lsend_pp(jj,l,n) = cseu_p(j,i)
312  GOTO 706
313  END IF
314  END DO
315  706 CONTINUE
316  END DO
317  END IF
318  END DO
319  END DO
320  END DO
321 !
322  ALLOCATE (num_seu1_p(4,nbseu,nparts), stat=ierr)
323  CALL check_allocate(ierr, 'NUM_SEU1_P')
324  num_seu1_p(:,:,:)=0
325  ALLOCATE (num_seu2_p(4,nbseu,nparts), stat=ierr)
326  CALL check_allocate(ierr, 'NUM_SEU2_P')
327  num_seu2_p(:,:,:)=0
328 ! LOCAL NUMBERING OF NODES INVOLVED IN ELEMENT OF WEIRS DESCRIPTION
329  DO n=1,nparts
330  DO j=1,nbseu
331  IF (seu_p(j,n)>0) THEN
332  DO k=1,4
333  DO l=1, nrecv_p(n)
334  IF (num_seu1(k,j)==lrecv_p(l,n)) THEN
335  num_seu1_p(k,j,n) = l
336  GOTO 605
337  END IF
338  ENDDO
339  WRITE(lu,*) 'HOUSTON ON A UN PROBLEME (1)', j, k, l
340  605 CONTINUE
341  END DO
342 !
343  DO k=1,4
344  DO l=1, nrecv_p(n)
345  IF (num_seu2(k,j)==lrecv_p(l,n)) THEN
346  num_seu2_p(k,j,n) = l
347  GOTO 606
348  END IF
349  ENDDO
350  WRITE(lu,*) 'HOUSTON ON A UN PROBLEME (2)', j, k, l
351  606 CONTINUE
352  END DO
353  END IF
354  END DO
355  END DO
356 !
357 ! WRITE THE WEIR FILE FOR EACH SUBDOMAIN
358  CALL get_free_id(nout)
359  DO n=1,nparts
360  nameout=trim(nameseu)//extens(nparts-1,n-1)
361  WRITE(lu,*) 'WRITING: ', trim(nameout)
362  OPEN (nout,file=trim(nameout),form='FORMATTED',status='NEW')
363  WRITE(nout,*) ' NB DE SINGULARITES OPTION UTAN'
364  WRITE(nout,*) '1 ', opseu, relax
365  WRITE(nout,*) '#Comment line'
366  WRITE(nout,*) sum(seu_p(:,n))
367  WRITE(nout,*) '#Comment line'
368  WRITE(nout,*) '#Comment line'
369  WRITE(nout,*) '#Comment line'
370 ! WRITE THE DESCRIPTION OF ELEMENTS OF WEIRS
371  DO j=1,nbseu
372  IF (seu_p(j,n)>0) THEN
373 1000 FORMAT(i0,1x,3(f27.15, 1x), 4(i0, 1x),
374  & 3(f27.15, 1x), 4(i0, 1x),
375  & 2(i0, 1x), 2(f27.15, 1x),
376  & 2(i0, 1x) )
377  WRITE(nout,1000) j,
378  & xseu1(j), yseu1(j), zseu1(j),
379  & (num_seu1_p(k,j,n), k = 1,4),
380  & xseu2(j), yseu2(j), zseu2(j),
381  & (num_seu2_p(k,j,n), k = 1,4),
382  & ip1(j), ip2(j), rp1(j), rp2(j),
383  & debseu(j), finseu(j)
384  END IF
385  END DO
386 ! WRITE THE PARALLEL INFORMATION WHICH DESCRIBE WHICH SUBDOMAIN NEED TO COMPUTE EACH ELEMENT
387  WRITE(nout,'(A)')
388  & ' /1/ : FOR EACH ELEMENT, NUMBER AND LIST OF SD'//
389  & ' WHICH WILL ALSO COMPUTE DISCHARGE ON IT'
390 !
391  ALLOCATE (list_tmp(1,nbmaxnshare),stat=ierr)
392  CALL check_allocate(ierr, 'LIST_TMP')
393  DO j=1,nbseu
394  IF (seu_p(j,n)>0) THEN
395  list_tmp(:,:)=0
396  i = 0
397  DO k=1, nbmaxnshare
398  IF((cseu_p(j,k)>0).AND.(cseu_p(j,k)/=n)) THEN
399  i = i + 1
400  list_tmp(1,i) = cseu_p(j,k)
401  END IF
402  END DO
403  WRITE(nout,*) j, i
404  IF (i>0) THEN
405  WRITE(nout,*) (list_tmp(1,k)-1, k=1,i)
406  END IF
407  END IF
408  END DO
409  DEALLOCATE (list_tmp)
410 !
411  WRITE(nout,'(A)')
412  & ' /2/ : FOR EACH SD, NUMBER AND LIST OF ELEMENT'//
413  & ' WHICH WILL BE COMPUTED'
414 ! FIRST PASSAGE TO COUNT THE NUMBER OF SD AND WRITE IT IN THE FILE
415  proc = 0
416  DO l=1, nparts
417  IF (l/=n) THEN
418  DO j=1,p_cseu(l,0)
419  IF (seu_p(p_cseu(l,j),n)>0) THEN
420  proc = proc + 1
421  GOTO 501
422  END IF
423  END DO
424  END IF
425  501 CONTINUE
426  END DO
427  WRITE(nout,*) proc
428 !
429  ALLOCATE (list_tmp(1,nbseu),stat=ierr)
430  CALL check_allocate(ierr, 'LIST_TMP')
431  list_tmp(:,:)=0
432  DO l=1, nparts
433  IF (l/=n) THEN
434  i = 0
435  DO j=1,p_cseu(l,0)
436  IF (seu_p(p_cseu(l,j),n)>0) THEN
437  i = i + 1
438  list_tmp(1,i) = p_cseu(l,j)
439  END IF
440  END DO
441  IF (i>0) THEN
442  WRITE(nout,'(I0,1X,I0)') l-1, i
443  fmt1 = ' '
444  WRITE(fmt1, '(I0)') i
445  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
446  & (list_tmp(1,k), k=1,i)
447  END IF
448  END IF
449  END DO
450  DEALLOCATE (list_tmp)
451 ! WRITE THE PARALLEL INFORMATION ABOUT THE NODES INVOLVED IN WEIR DESCRIPTION
452 ! THE VALUES OF THESE NODES SHOULD BE RECEIVE FROM OTHER SD
453  WRITE(nout,'(A)')
454  & ' /3/ : FOR EACH NODE REQUIRED BY THE SD TO'//
455  & ' COMPUTE THE DISCHARGE, NUMBER, LIST AND LOCAL'//
456  & ' NUMBERING OF NODES FROM ALL INVOLVED SD'
457  ALLOCATE (list_tmp(2,nbmaxnshare),stat=ierr)
458  CALL check_allocate(ierr, 'LIST_TMP')
459  WRITE(nout,*) nrecv_p(n)
460  IF (nrecv_p(n)>0) THEN
461  DO i=1, nrecv_p(n)
462  list_tmp(:,:)=0
463  j = 0
464  DO k=1, part_p(lrecv_p(i,n),0)
465  j = j + 1
466  list_tmp(1,k) = part_p(lrecv_p(i,n),k)
467  list_tmp(2,k) = hash_table_get(knogl,
468  & lrecv_p(i,n),part_p(lrecv_p(i,n),k))
469  END DO
470  WRITE(nout,'(I0,1X,I0)') lrecv_p(i,n), j
471  fmt1 = ' '
472  WRITE(fmt1, '(I0)') j
473  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X,I0,1X))')
474  & (list_tmp(1,k)-1,list_tmp(2,k), k=1,j)
475  END DO
476  END IF
477  DEALLOCATE (list_tmp)
478 !
479  WRITE(nout,'(A)')
480  & ' /4/ : FOR EACH OTHER SD WHICH SEND VALUES,'//
481  & ' NUMBER AND LIST OF NODE (WITH LOCAL NUMBER)'
482  proc = 0
483  IF (nrecv_p(n)>0) THEN
484  ALLOCATE (list_tmp(nparts,3*nrecv_p(n)),stat=ierr)
485  CALL check_allocate(ierr, 'LIST_TMP')
486  list_tmp(:,:)=0
487  DO i=1, nrecv_p(n)
488  DO k=1, part_p(lrecv_p(i,n),0)
489  DO j=1, proc
490  IF (list_tmp(j,1) == part_p(lrecv_p(i,n),k)) GOTO 522
491  IF (list_tmp(j,1) > part_p(lrecv_p(i,n),k)) GOTO 521
492  END DO
493  521 CONTINUE
494  proc = proc + 1
495  DO m = proc, j+1, -1
496  list_tmp(m,1) = list_tmp(m-1,1)
497  END DO
498  list_tmp(j,1) = part_p(lrecv_p(i,n),k)
499  522 CONTINUE
500  END DO
501  END DO
502  END IF
503  WRITE(nout,'(I0)') proc
504 !
505  DO m=1, proc
506  posi = 2
507  DO i=1, nrecv_p(n)
508  jj = lrecv_p(i,n)
509  DO k=1, part_p(jj,0)
510  IF (part_p(jj,k)==list_tmp(m,1)) THEN
511  list_tmp(m,posi ) = i
512  list_tmp(m,posi+1) = jj
513  list_tmp(m,posi+2) =
514  & hash_table_get(knogl,jj,part_p(jj,k))
515  posi = posi + 3
516  END IF
517  END DO
518  END DO
519  WRITE(nout,'(I0,1X,I0)') list_tmp(m,1)-1, (posi-1)/3
520  fmt1 = ' '
521  WRITE(fmt1, '(I0)') (posi-1)/3
522  IF (posi > 2) THEN
523  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
524  & (list_tmp(m,3*k-1), k=1,(posi-1)/3)
525  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
526  & (list_tmp(m,3*k ), k=1,(posi-1)/3)
527  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
528  & (list_tmp(m,3*k+1), k=1,(posi-1)/3)
529  END IF
530  END DO
531  IF (ALLOCATED(list_tmp)) DEALLOCATE(list_tmp)
532 !
533 ! WRITE THE PARALLEL INFORMATION ABOUT THE NODES INVOLVED IN WEIR DESCRIPTION OF OTHER SD
534 ! THE VALUES OF THESE NODES SHOULD BE SEND TO OTHER SD
535  WRITE(nout,'(A)')
536  & ' /5/ : FOR EACH NODE INSIDE THE SD, NUMBER AND'//
537  & ' LIST OF OTHERS SD WHICH ALSO NEED THE VALUE'
538  ALLOCATE (list_tmp(2,nbmaxnshare),stat=ierr)
539  CALL check_allocate(ierr, 'LIST_TMP')
540  WRITE(nout,'(I0)') nsend_p(n)
541  IF (nsend_p(n)>0) THEN
542  DO i=1, nsend_p(n)
543  list_tmp(:,:)=0
544  j = 0
545  DO k=1, nbmaxnshare
546  IF (lsend_pp(k,i,n)>0) THEN
547  j = j + 1
548  list_tmp(1,j) = lsend_pp(k,i,n)
549  END IF
550  END DO
551  WRITE(nout,'(I0,1X,I0)') lsend_p(i,n), j
552  fmt1 = ' '
553  WRITE(fmt1, '(I0)') j
554  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
555  & (list_tmp(1,k)-1, k=1,j)
556  END DO
557  END IF
558  DEALLOCATE (list_tmp)
559 !
560  WRITE(nout,'(A)')
561  & ' /6/ : FOR EACH OTHER SD WHICH NEEDS NODE '//
562  & 'VALUES, NUMBER AND LIST OF NODES'
563  proc = 0
564  IF (nsend_p(n)>0) THEN
565  ALLOCATE (list_tmp(nparts,3*nsend_p(n)+1),stat=ierr)
566  CALL check_allocate(ierr, 'LIST_TMP')
567  list_tmp(:,:)=0
568  DO i=1, nsend_p(n)
569  DO k=1, nbmaxnshare
570  IF (lsend_pp(k,i,n)>0) THEN
571  DO j=1, proc
572  IF (list_tmp(j,1) == lsend_pp(k,i,n)) GOTO 512
573  IF (list_tmp(j,1) > lsend_pp(k,i,n)) GOTO 511
574  END DO
575  511 CONTINUE
576  proc = proc + 1
577  DO m = proc, j+1, -1
578  list_tmp(m,1) = list_tmp(m-1,1)
579  END DO
580  list_tmp(j,1) = lsend_pp(k,i,n)
581  512 CONTINUE
582  END IF
583  END DO
584  END DO
585  END IF
586 !
587  WRITE(nout,*) proc
588  IF (nsend_p(n)>0) THEN
589  DO m=1, proc
590  posi = 2
591  DO i=1, nsend_p(n)
592  jj = lsend_p(i,n)
593  DO k=1, nbmaxnshare
594  IF (lsend_pp(k,i,n)==list_tmp(m,1)) THEN
595  j = 1
596  DO WHILE (lrecv_p(j,n) /= jj)
597  j = j + 1
598  END DO
599  list_tmp(m,posi ) = j
600  list_tmp(m,posi+1) = jj
601  j = 1
602  DO WHILE (part_p(jj,j) /= n)
603  j = j + 1
604  END DO
605  list_tmp(m,posi+2) =
606  & hash_table_get(knogl,jj,part_p(jj,j))
607  posi = posi + 3
608  END IF
609  END DO
610  END DO
611  j = (posi-1)/3
612  fmt1 = ' '
613  WRITE(fmt1, '(I0)') j
614  WRITE(nout,'(I0,1X,I0)') list_tmp(m,1)-1, j
615  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
616  & (list_tmp(m,3*k-1), k=1,j)
617  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
618  & (list_tmp(m,3*k ), k=1,j)
619  WRITE(nout,'('//adjustl(fmt1)//'(I0,1X))')
620  & (list_tmp(m,3*k+1), k=1,j)
621  END DO
622  IF (ALLOCATED(list_tmp)) DEALLOCATE (list_tmp)
623  END IF
624 !
625  CLOSE(nout)
626  END DO
627 !
628  DEALLOCATE(xseu1)
629  DEALLOCATE(yseu1)
630  DEALLOCATE(zseu1)
631  DEALLOCATE(xseu2)
632  DEALLOCATE(yseu2)
633  DEALLOCATE(zseu2)
634  DEALLOCATE(rp1)
635  DEALLOCATE(rp2)
636  DEALLOCATE(ip1)
637  DEALLOCATE(ip2)
638  DEALLOCATE(debseu)
639  DEALLOCATE(finseu)
640  DEALLOCATE(num_seu1)
641  DEALLOCATE(num_seu2)
642  DEALLOCATE(num_seu1_p)
643  DEALLOCATE(num_seu2_p)
644  DEALLOCATE(part_p)
645  DEALLOCATE(seu_p)
646  DEALLOCATE(cseu_p)
647  DEALLOCATE(lsend_p)
648  DEALLOCATE(lsend_pp)
649  DEALLOCATE(nrecv_p)
650  DEALLOCATE(lrecv_p)
651 
652  RETURN
653 
654  304 WRITE(lu,*) 'ABNORMAL END OF FILE'
655  GO TO 999
656  305 WRITE(lu,*) 'ERROR WITH WEIR FILE FORMAT'
657  GO TO 999
658 !
659  999 CALL plante(1)
660  stop
661  END SUBROUTINE
662  END MODULE
declarations_special
Definition: declarations_special.F:3
declarations_partel
Definition: declarations_partel.f:3
declarations_special::lu
integer lu
Definition: declarations_special.F:45
mod_hash_table
Definition: mod_hash_table.f:3
mod_hash_table::hash_table
Definition: mod_hash_table.f:37
mod_hash_table::hash_table_get
integer function hash_table_get(HT, X, Y)
Definition: mod_hash_table.f:341
mod_handle_weirs::handle_weirs
subroutine handle_weirs(NAMESEU, NPARTS, KNOGL, NPOIN2)
Definition: mod_handle_weirs.f:21
mod_handle_weirs
Definition: mod_handle_weirs.f:3
bief
Definition: bief.f:3
Generated on Tue Jan 5 2021 14:38:17 for The TELEMAC-MASCARET system by doxygen 1.8.13