The TELEMAC-MASCARET system  trunk
paraco_comp.f
Go to the documentation of this file.
1 ! **********************
2  SUBROUTINE paraco_comp
3 ! **********************
4 !
5  &(v1,v2,v3,errx,npoin,icom,ian,nplan,nb_neighb,nb_neighb_pt,
6  & list_send,nh_com,dimnhcom,buf_send,buf_recv,dimbuf,
7  & buf_send_err, buf_recv_err )
8 !
9 !***********************************************************************
10 ! BIEF V7P3 24/02/2016
11 !***********************************************************************
12 !
13 !brief ASSEMBLES DATA AND THEIR COMMITED ERRORS SHARED BY SEVERAL PROCESSORS.
14 !
15 !history R.NHEILI (Univerte de Perpignan, DALI)
16 !+ 24/02/2016
17 !+ V7P3
18 !+
19 !
20 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
21 !| BUF_RECV |<->| BUFFER FOR RECEIVING DATA
22 !| BUF_RECV_ERR |<->| BUFFER FOR RECEIVING DATA ERRORS
23 !| BUF_SEND |<->| BUFFER FOR SENDING DATA
24 !| BUF_SEND_ERR |<->| BUFFER FOR SENDING DATA ERRORS
25 !| DIMBUF |-->| FIRST DIMENSION OF BUFFERS
26 !| DIMNHCOM |---|
27 !| IAN |-->| NUMBER OF VECTORS TO BE CONDIDERED (1, 2 OR 3)
28 !| ICOM |-->| OPTION OF COMMUNICATION :
29 !| | | = 1 : VALUE WITH MAXIMUM ABSOLUTE VALUE
30 !| | | = 2 : CONTRIBUTIONS ADDED
31 !| | | = 3 : MAXIMUM CONTRIBUTION RETAINED
32 !| | | = 4 : MINIMUM CONTRIBUTION RETAINED
33 !| LIST_SEND |-->| LIST OF PROCESSORS NUMBERS
34 !| NB_NEIGHB |-->| NUMBER OF NEIGHBOURING SUB-DOMAINS
35 !| NB_NEIGHB_PT |-->| NUMBER OF POINTS SHARED WITH A SUB-DOMAIN
36 !| NH_COM |-->| NH_COM(I,IL) : GLOBAL NUMBER IN THIS
37 !| | | SUB-DOMAIN OF THE POINT NUMBER I IN THE LIST
38 !| | | OF POINTS SHARED WITH PROCESSOR NUMBER IL
39 !| | | WHOSE REAL NUMBER IS LIST_SEND(IL)
40 !| NPLAN |-->| SECOND DIMENSION OF V1,V2,V3
41 !| NPOIN |-->| FIRST DIMENSION OF V1,V2,V3
42 !| V1 |<->| VECTOR TO BE COMPLETED
43 !| V2 |<->| VECTOR TO BE COMPLETED
44 !| V3 |<->| VECTOR TO BE COMPLETED
45 !|ERRX |<->| ERRORS VECTOR TO BE COMPLETED
46 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
47 !
48  USE bief_def
49  USE interface_parallel
50  USE declarations_telemac, ONLY : paraco_msg_tag
51 !
52  USE declarations_special
53  IMPLICIT NONE
54 !
55 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
56 !
57  INTEGER, INTENT(IN) :: NPOIN,ICOM,IAN,NPLAN,NB_NEIGHB
58  INTEGER, INTENT(IN) :: DIMNHCOM,DIMBUF
59  INTEGER, INTENT(IN) :: NB_NEIGHB_PT(nb_neighb)
60  INTEGER, INTENT(IN) :: LIST_SEND(nb_neighb),NH_COM(dimnhcom,*)
61 !
62  DOUBLE PRECISION, INTENT(INOUT) :: BUF_SEND(dimbuf,*)
63  DOUBLE PRECISION, INTENT(INOUT) :: BUF_SEND_ERR(dimbuf,*)
64  DOUBLE PRECISION, INTENT(INOUT) :: BUF_RECV(dimbuf,*)
65  DOUBLE PRECISION, INTENT(INOUT) :: BUF_RECV_ERR(dimbuf,*)
66  DOUBLE PRECISION, INTENT(INOUT) :: V1(npoin,nplan)
67  DOUBLE PRECISION, INTENT(INOUT) :: V2(npoin,nplan)
68  DOUBLE PRECISION, INTENT(INOUT) :: V3(npoin,nplan)
69  DOUBLE PRECISION, INTENT(INOUT) :: ERRX(*)
70 !
71 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
72 !
73  INTEGER IKA,IL,II,I,J,K,IPA
74 !
75  INTRINSIC abs
76 !
77  DOUBLE PRECISION TMP
78  DOUBLE PRECISION ERROR ,ERROR2
79  INTEGER SEND_REQ(100),RECV_REQ(100)
80 !
81 !----------------------------------------------------------------------
82 !
83  IF(ian.NE.1.AND.ian.NE.2.AND.ian.NE.3) THEN
84  WRITE(lu,*) 'FALSCHE FREIWERTZAHL BEI KOMMUNIKATION',ian,
85  & ' AUF PROZESSOR',ipid
86  CALL plante(1)
87  stop
88  ENDIF
89 !
90 ! MESSAGE TAG UPDATE
91 !
92  IF(paraco_msg_tag.LT.1000000) THEN
93  paraco_msg_tag = paraco_msg_tag + 1
94  ELSE
95  paraco_msg_tag = 5001
96  ENDIF
97 !
98 !== RECEIVE STEP
99 !
100  DO il=1,nb_neighb
101  ika = nb_neighb_pt(il)
102  ipa = list_send(il)
103  CALL p_read(buf_recv(1:dimbuf,il),ian*ika*nplan,8,
104  & ipa,paraco_msg_tag,recv_req(il))
105  IF(ian.EQ.1) THEN
106  CALL p_read(buf_recv_err(1:dimbuf,il),ian*ika*nplan,8,
107  & ipa,paraco_msg_tag,recv_req(il))
108  ENDIF
109  ENDDO
110 !
111 !== SEND STEP
112 !
113  DO il=1,nb_neighb
114  ika = nb_neighb_pt(il)
115  ipa = list_send(il)
116 !
117 !** INITIALISES THE COMMUNICATION ARRAYS
118 !
119  k = 1
120  IF(ian.EQ.3) THEN
121  DO j=1,nplan
122  DO i=1,ika
123  ii=nh_com(i,il)
124  buf_send(k,il) =v1(ii,j)
125  buf_send(k+1,il)=v2(ii,j)
126  buf_send(k+2,il)=v3(ii,j)
127  k=k+3
128  ENDDO
129  ENDDO
130  ELSEIF(ian.EQ.2) THEN
131  DO j=1,nplan
132  DO i=1,ika
133  ii=nh_com(i,il)
134  buf_send(k,il) =v1(ii,j)
135  buf_send(k+1,il)=v2(ii,j)
136  k=k+2
137  ENDDO
138  ENDDO
139  ELSEIF(ian.EQ.1) THEN
140  DO j=1,nplan
141  DO i=1,ika
142  ii=nh_com(i,il)
143  buf_send(k,il) =v1(ii,j)
144  buf_send_err(k,il) =errx(ii)
145  k=k+1
146  ENDDO
147  ENDDO
148  ENDIF
149 !
150  CALL p_write(buf_send(1:dimbuf,il),ian*ika*nplan,8,
151  & ipa,paraco_msg_tag,send_req(il))
152  IF(ian.EQ.1) THEN
153  CALL p_write(buf_send_err(1:dimbuf,il),ian*ika*nplan,8,
154  & ipa,paraco_msg_tag,send_req(il))
155  ENDIF
156 !
157  ENDDO
158 !
159 !== WAIT RECEIVED MESSAGES (POSSIBILITY OF COVERING)
160 !
161  DO il=1,nb_neighb
162  ika = nb_neighb_pt(il)
163  ipa = list_send(il)
164  CALL p_wait_paraco(recv_req(il),1)
165 !
166  k=1
167 !
168  IF(icom.EQ.1) THEN
169  IF(ian.EQ.3) THEN
170  DO j=1,nplan
171  DO i=1,ika
172  ii=nh_com(i,il)
173  IF(abs(buf_recv(k,il)).GT.abs(v1(ii,j)))
174  & v1(ii,j)=buf_recv(k ,il)
175  IF(abs(buf_recv(k+1,il)).GT.abs(v2(ii,j)))
176  & v2(ii,j)=buf_recv(k+1,il)
177  IF(abs(buf_recv(k+2,il)).GT.abs(v3(ii,j)))
178  & v3(ii,j)=buf_recv(k+2,il)
179  k=k+3
180  ENDDO
181  ENDDO
182  ELSEIF(ian.EQ.2) THEN
183  DO j=1,nplan
184  DO i=1,ika
185  ii=nh_com(i,il)
186  IF(abs(buf_recv(k,il)).GT.abs(v1(ii,j)))
187  & v1(ii,j)=buf_recv(k ,il)
188  IF(abs(buf_recv(k+1,il)).GT.abs(v2(ii,j)))
189  & v2(ii,j)=buf_recv(k+1,il)
190  k=k+2
191  ENDDO
192  ENDDO
193  ELSEIF(ian.EQ.1) THEN
194  DO j=1,nplan
195  DO i=1,ika
196  ii=nh_com(i,il)
197  IF(abs(buf_recv(k,il)).GT.abs(v1(ii,j)))
198  & v1(ii,j)=buf_recv(k ,il)
199  IF(abs(buf_recv_err(k,il)).GT.abs(errx(ii)))
200  & errx(ii)=buf_recv_err(k ,il)
201  k=k+1
202  ENDDO
203  ENDDO
204  ENDIF
205  ELSEIF(icom.EQ.2) THEN
206  IF(ian.EQ.3) THEN
207  DO j=1,nplan
208  DO i=1,ika
209  ii=nh_com(i,il)
210  v1(ii,j)=v1(ii,j)+buf_recv(k ,il)
211  v2(ii,j)=v2(ii,j)+buf_recv(k+1,il)
212  v3(ii,j)=v3(ii,j)+buf_recv(k+2,il)
213  k=k+3
214  ENDDO
215  ENDDO
216  ELSEIF(ian.EQ.2) THEN
217  DO j=1,nplan
218  DO i=1,ika
219  ii=nh_com(i,il)
220  v1(ii,j)=v1(ii,j)+buf_recv(k ,il)
221  v2(ii,j)=v2(ii,j)+buf_recv(k+1,il)
222  k=k+2
223  ENDDO
224  ENDDO
225  ELSEIF(ian.EQ.1) THEN
226  DO j=1,nplan
227  DO i=1,ika
228  ii=nh_com(i,il)
229  tmp = v1(ii,j)
230  CALL twosum(tmp,buf_recv(k,il)
231  & ,v1(ii,j),error)
232  tmp = errx(ii)
233  CALL twosum(tmp,buf_recv_err(k,il)
234  & ,errx(ii),error2)
235  error=error+error2
236  errx(ii)=errx(ii)+error
237  k=k+1
238  ENDDO
239  ENDDO
240  ENDIF
241  ELSEIF(icom.EQ.3) THEN
242  IF(ian.EQ.3) THEN
243  DO j=1,nplan
244  DO i=1,ika
245  ii=nh_com(i,il)
246  IF(buf_recv(k ,il).GT.v1(ii,j))
247  & v1(ii,j)=buf_recv(k ,il)
248  IF(buf_recv(k+1,il).GT.v2(ii,j))
249  & v2(ii,j)=buf_recv(k+1,il)
250  IF(buf_recv(k+2,il).GT.v3(ii,j))
251  & v3(ii,j)=buf_recv(k+2,il)
252  k=k+3
253  ENDDO
254  ENDDO
255  ELSEIF(ian.EQ.2) THEN
256  DO j=1,nplan
257  DO i=1,ika
258  ii=nh_com(i,il)
259  IF(buf_recv(k ,il).GT.v1(ii,j))
260  & v1(ii,j)=buf_recv(k ,il)
261  IF(buf_recv(k+1,il).GT.v2(ii,j))
262  & v2(ii,j)=buf_recv(k+1,il)
263  k=k+2
264  ENDDO
265  ENDDO
266  ELSEIF(ian.EQ.1) THEN
267  DO j=1,nplan
268  DO i=1,ika
269  ii=nh_com(i,il)
270  IF(buf_recv(k ,il).GT.v1(ii,j))
271  & v1(ii,j)=buf_recv(k ,il)
272  k=k+1
273  ENDDO
274  ENDDO
275  ENDIF
276  ELSEIF(icom.EQ.4) THEN
277  IF(ian.EQ.3) THEN
278  DO j=1,nplan
279  DO i=1,ika
280  ii=nh_com(i,il)
281  IF(buf_recv(k ,il).LT.v1(ii,j))
282  & v1(ii,j)=buf_recv(k ,il)
283  IF(buf_recv(k+1,il).LT.v2(ii,j))
284  & v2(ii,j)=buf_recv(k+1,il)
285  IF(buf_recv(k+2,il).LT.v3(ii,j))
286  & v3(ii,j)=buf_recv(k+2,il)
287  k=k+3
288  ENDDO
289  ENDDO
290  ELSEIF(ian.EQ.2) THEN
291  DO j=1,nplan
292  DO i=1,ika
293  ii=nh_com(i,il)
294  IF(buf_recv(k ,il).LT.v1(ii,j))
295  & v1(ii,j)=buf_recv(k ,il)
296  IF(buf_recv(k+1,il).LT.v2(ii,j))
297  & v2(ii,j)=buf_recv(k+1,il)
298  k=k+2
299  ENDDO
300  ENDDO
301  ELSEIF(ian.EQ.1) THEN
302  DO j=1,nplan
303  DO i=1,ika
304  ii=nh_com(i,il)
305  IF(buf_recv(k ,il).LT.v1(ii,j))
306  & v1(ii,j)=buf_recv(k ,il)
307  k=k+1
308  ENDDO
309  ENDDO
310  ENDIF
311  ENDIF
312 !
313  ENDDO
314 !
315 !== WAIT SENT MESSAGES
316 !
317  CALL p_wait_paraco(send_req,nb_neighb)
318 !
319 !-----------------------------------------------------------------------
320 !
321  RETURN
322  END
interface_parallel
Definition: interface_parallel.f:3
declarations_special
Definition: declarations_special.F:3
declarations_special::lu
integer lu
Definition: declarations_special.F:45
declarations_telemac
Definition: declarations_telemac.f:3
interface_parallel::p_write
Definition: interface_parallel.f:370
bief_def::ipid
integer ipid
Definition: bief_def.f:49
declarations_telemac::paraco_msg_tag
integer paraco_msg_tag
Definition: declarations_telemac.f:277
paraco_comp
subroutine paraco_comp(V1, V2, V3, ERRX, NPOIN, ICOM, IAN, NPLAN, NB_NEIGHB, NB_NEIGHB_PT, LIST_SEND, NH_COM, DIMNHCOM, BUF_SEND, BUF_RECV, DIMBUF, BUF_SEND_ERR, BUF_RECV_ERR)
Definition: paraco_comp.f:9
bief_def
Definition: bief_def.f:3
p_wait_paraco
subroutine p_wait_paraco(IBUF, NB)
Definition: p_wait_paraco.F:7
interface_parallel::p_read
Definition: interface_parallel.f:340
twosum
subroutine twosum(A, B, X, Y)
Definition: twosum.f:7
Generated on Tue Jan 5 2021 14:37:22 for The TELEMAC-MASCARET system by doxygen 1.8.13