Context Navigation

transfert_mpi_legacy.f90

Last change on this file was 963, checked in by adurocher, 5 years ago
Merge 'mpi_rewrite' into trunk
File size: 56.2 KB

Rev	Line
[963]	1	MODULE transfert_mpi_legacy_mod
[26]	2	USE genmod
[151]	3	USE field_mod
[667]	4	IMPLICIT NONE
[963]	5
[26]	6	TYPE array
[953]	7	INTEGER,POINTER :: value(:)=>null()
	8	INTEGER,POINTER :: sign(:)=>null()
[26]	9	INTEGER :: domain
	10	INTEGER :: rank
[186]	11	INTEGER :: tag
[26]	12	INTEGER :: size
[186]	13	INTEGER :: offset
	14	INTEGER :: ireq
[953]	15	INTEGER,POINTER :: buffer(:)=>null()
	16	REAL,POINTER :: buffer_r(:)=>null()
	17	INTEGER,POINTER :: src_value(:)=>null()
[26]	18	END TYPE array
[963]	19
[151]	20	TYPE t_buffer
[186]	21	REAL,POINTER :: r(:)
	22	INTEGER :: size
	23	INTEGER :: rank
[963]	24	END TYPE t_buffer
	25
[26]	26	TYPE t_request
	27	INTEGER :: type_field
	28	INTEGER :: max_size
	29	INTEGER :: size
[146]	30	LOGICAL :: vector
[26]	31	INTEGER,POINTER :: src_domain(:)
	32	INTEGER,POINTER :: src_i(:)
	33	INTEGER,POINTER :: src_j(:)
	34	INTEGER,POINTER :: src_ind(:)
	35	INTEGER,POINTER :: target_ind(:)
	36	INTEGER,POINTER :: target_i(:)
	37	INTEGER,POINTER :: target_j(:)
[146]	38	INTEGER,POINTER :: target_sign(:)
[26]	39	INTEGER :: nrecv
	40	TYPE(ARRAY),POINTER :: recv(:)
	41	INTEGER :: nsend
[176]	42	INTEGER :: nreq_mpi
[186]	43	INTEGER :: nreq_send
	44	INTEGER :: nreq_recv
[26]	45	TYPE(ARRAY),POINTER :: send(:)
	46	END TYPE t_request
[963]	47
[186]	48	TYPE(t_request),SAVE,POINTER :: req_i1(:)
	49	TYPE(t_request),SAVE,POINTER :: req_e1_scal(:)
	50	TYPE(t_request),SAVE,POINTER :: req_e1_vect(:)
[711]	51	TYPE(t_request),SAVE,POINTER :: req_z1_scal(:)
[963]	52
[186]	53	TYPE(t_request),SAVE,POINTER :: req_i0(:)
	54	TYPE(t_request),SAVE,POINTER :: req_e0_scal(:)
	55	TYPE(t_request),SAVE,POINTER :: req_e0_vect(:)
	56
	57	TYPE t_reorder
	58	INTEGER :: ind
	59	INTEGER :: rank
	60	INTEGER :: tag
	61	INTEGER :: isend
[963]	62	END TYPE t_reorder
	63
[151]	64	TYPE t_message
[364]	65	CHARACTER(LEN=100) :: name ! for debug
[151]	66	TYPE(t_request), POINTER :: request(:)
	67	INTEGER :: nreq
[186]	68	INTEGER :: nreq_send
	69	INTEGER :: nreq_recv
	70	TYPE(t_reorder), POINTER :: reorder(:)
[151]	71	INTEGER, POINTER :: mpi_req(:)
	72	INTEGER, POINTER :: status(:,:)
[963]	73	TYPE(t_buffer),POINTER :: buffers(:)
[151]	74	TYPE(t_field),POINTER :: field(:)
	75	LOGICAL :: completed
	76	LOGICAL :: pending
[364]	77	LOGICAL :: open ! for debug
[176]	78	INTEGER :: number
[953]	79	LOGICAL :: ondevice=.false. !<Ready to transfer ondevice field
[151]	80	END TYPE t_message
[266]	81
[963]	82	integer :: profile_mpi_copies, profile_mpi_waitall, profile_mpi_omp_barrier
[266]	83
[963]	84	CONTAINS
[266]	85
[962]	86
[26]	87	SUBROUTINE init_transfert
[667]	88	USE profiling_mod
[26]	89	USE domain_mod
	90	USE dimensions
	91	USE field_mod
	92	USE metric
	93	USE mpipara
[186]	94	USE mpi_mod
[26]	95	IMPLICIT NONE
	96	INTEGER :: ind,i,j
[667]	97
	98	CALL register_id('MPI', id_mpi)
[962]	99	CALL register_id('MPI_copies', profile_mpi_copies)
	100	CALL register_id('MPI_waitall', profile_mpi_waitall)
	101	CALL register_id('MPI_omp_barrier', profile_mpi_omp_barrier)
[667]	102
[26]	103	CALL create_request(field_t,req_i1)
	104
	105	DO ind=1,ndomain
	106	CALL swap_dimensions(ind)
	107	DO i=ii_begin,ii_end+1
	108	CALL request_add_point(ind,i,jj_begin-1,req_i1)
	109	ENDDO
	110
	111	DO j=jj_begin,jj_end
	112	CALL request_add_point(ind,ii_end+1,j,req_i1)
[963]	113	ENDDO
[26]	114	DO i=ii_begin,ii_end
	115	CALL request_add_point(ind,i,jj_end+1,req_i1)
[963]	116	ENDDO
[26]	117
	118	DO j=jj_begin,jj_end+1
	119	CALL request_add_point(ind,ii_begin-1,j,req_i1)
[963]	120	ENDDO
	121
[26]	122	ENDDO
[963]	123
[26]	124	CALL finalize_request(req_i1)
[148]	125
	126
	127	CALL create_request(field_t,req_i0)
	128
	129	DO ind=1,ndomain
	130	CALL swap_dimensions(ind)
[963]	131
[148]	132	DO i=ii_begin,ii_end
	133	CALL request_add_point(ind,i,jj_begin,req_i0)
	134	ENDDO
	135
	136	DO j=jj_begin,jj_end
	137	CALL request_add_point(ind,ii_end,j,req_i0)
[963]	138	ENDDO
	139
[148]	140	DO i=ii_begin,ii_end
	141	CALL request_add_point(ind,i,jj_end,req_i0)
[963]	142	ENDDO
[148]	143
	144	DO j=jj_begin,jj_end
	145	CALL request_add_point(ind,ii_begin,j,req_i0)
[963]	146	ENDDO
	147
[148]	148	ENDDO
	149
[963]	150	CALL finalize_request(req_i0)
[148]	151
[963]	152
[146]	153	CALL create_request(field_u,req_e1_scal)
[26]	154	DO ind=1,ndomain
	155	CALL swap_dimensions(ind)
	156	DO i=ii_begin,ii_end
[146]	157	CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup)
	158	CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup)
[26]	159	ENDDO
	160
	161	DO j=jj_begin,jj_end
[146]	162	CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left)
[963]	163	ENDDO
[327]	164	DO j=jj_begin,jj_end
[146]	165	CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup)
[963]	166	ENDDO
	167
[26]	168	DO i=ii_begin,ii_end
[146]	169	CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown)
	170	CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown)
[963]	171	ENDDO
[26]	172
	173	DO j=jj_begin,jj_end
[146]	174	CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right)
[963]	175	ENDDO
[327]	176	DO j=jj_begin,jj_end
[146]	177	CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown)
[963]	178	ENDDO
[26]	179
	180	ENDDO
[146]	181
	182	CALL finalize_request(req_e1_scal)
[148]	183
	184
	185	CALL create_request(field_u,req_e0_scal)
	186	DO ind=1,ndomain
	187	CALL swap_dimensions(ind)
	188
	189
	190	DO i=ii_begin+1,ii_end-1
	191	CALL request_add_point(ind,i,jj_begin,req_e0_scal,right)
	192	CALL request_add_point(ind,i,jj_end,req_e0_scal,right)
	193	ENDDO
[963]	194
[148]	195	DO j=jj_begin+1,jj_end-1
	196	CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup)
	197	CALL request_add_point(ind,ii_end,j,req_e0_scal,rup)
[963]	198	ENDDO
[148]	199
	200	CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left)
	201	CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown)
	202	CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left)
	203	CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown)
	204
	205	ENDDO
	206
	207	CALL finalize_request(req_e0_scal)
	208
	209
[963]	210
[146]	211	CALL create_request(field_u,req_e1_vect,.TRUE.)
	212	DO ind=1,ndomain
	213	CALL swap_dimensions(ind)
	214	DO i=ii_begin,ii_end
	215	CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup)
	216	CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup)
	217	ENDDO
	218
	219	DO j=jj_begin,jj_end
	220	CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left)
[963]	221	ENDDO
[327]	222	DO j=jj_begin,jj_end
[146]	223	CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup)
[963]	224	ENDDO
	225
[146]	226	DO i=ii_begin,ii_end
	227	CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown)
	228	CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown)
[963]	229	ENDDO
[146]	230
	231	DO j=jj_begin,jj_end
	232	CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right)
[963]	233	ENDDO
[327]	234	DO j=jj_begin,jj_end
[146]	235	CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown)
[963]	236	ENDDO
[146]	237
	238
[963]	239	ENDDO
	240
[146]	241	CALL finalize_request(req_e1_vect)
[963]	242
	243
[148]	244	CALL create_request(field_u,req_e0_vect,.TRUE.)
	245	DO ind=1,ndomain
	246	CALL swap_dimensions(ind)
[963]	247
[148]	248	DO i=ii_begin+1,ii_end-1
	249	CALL request_add_point(ind,i,jj_begin,req_e0_vect,right)
	250	CALL request_add_point(ind,i,jj_end,req_e0_vect,right)
	251	ENDDO
[963]	252
[148]	253	DO j=jj_begin+1,jj_end-1
	254	CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup)
	255	CALL request_add_point(ind,ii_end,j,req_e0_vect,rup)
[963]	256	ENDDO
[146]	257
[148]	258	CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left)
	259	CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown)
	260	CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left)
	261	CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown)
	262
[963]	263	ENDDO
	264
[148]	265	CALL finalize_request(req_e0_vect)
	266
[711]	267	CALL create_request(field_z,req_z1_scal)
	268	DO ind=1,ndomain
	269	CALL swap_dimensions(ind)
	270	DO i=ii_begin,ii_end
	271	CALL request_add_point(ind,i,jj_begin-1,req_z1_scal,vrup)
	272	CALL request_add_point(ind,i+1,jj_begin-1,req_z1_scal,vup)
	273	ENDDO
[148]	274
[711]	275	DO j=jj_begin,jj_end
	276	CALL request_add_point(ind,ii_end+1,j,req_z1_scal,vlup)
[963]	277	ENDDO
[711]	278	DO j=jj_begin,jj_end
	279	CALL request_add_point(ind,ii_end+1,j-1,req_z1_scal,vup)
[963]	280	ENDDO
	281
[711]	282	DO i=ii_begin,ii_end
	283	CALL request_add_point(ind,i,jj_end+1,req_z1_scal,vdown)
	284	CALL request_add_point(ind,i-1,jj_end+1,req_z1_scal,vrdown)
[963]	285	ENDDO
[711]	286
	287	DO j=jj_begin,jj_end
	288	CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrup)
[963]	289	ENDDO
[711]	290	DO j=jj_begin,jj_end
	291	CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrdown)
[963]	292	ENDDO
[711]	293
	294	ENDDO
	295
	296	CALL finalize_request(req_z1_scal)
	297
[26]	298	END SUBROUTINE init_transfert
[963]	299
[146]	300	SUBROUTINE create_request(type_field,request,vector)
[26]	301	USE domain_mod
	302	USE field_mod
	303	IMPLICIT NONE
	304	INTEGER :: type_field
	305	TYPE(t_request),POINTER :: request(:)
[146]	306	LOGICAL,OPTIONAL :: vector
[963]	307
[26]	308	TYPE(t_request),POINTER :: req
	309	TYPE(t_domain),POINTER :: d
	310	INTEGER :: ind
	311	INTEGER :: max_size
[963]	312
[26]	313	ALLOCATE(request(ndomain))
	314
	315	DO ind=1,ndomain
	316	req=>request(ind)
	317	d=>domain(ind)
	318	IF (type_field==field_t) THEN
	319	Max_size=2(d%iim+2)+2(d%jjm+2)
	320	ELSE IF (type_field==field_u) THEN
	321	Max_size=3(2(d%iim+2)+2*(d%jjm+2))
	322	ELSE IF (type_field==field_z) THEN
	323	Max_size=2(2(d%iim+2)+2*(d%jjm+2))
	324	ENDIF
	325
	326	req%type_field=type_field
	327	req%max_size=max_size*2
	328	req%size=0
[146]	329	req%vector=.FALSE.
	330	IF (PRESENT(vector)) req%vector=vector
[26]	331	ALLOCATE(req%src_domain(req%max_size))
	332	ALLOCATE(req%src_ind(req%max_size))
	333	ALLOCATE(req%target_ind(req%max_size))
	334	ALLOCATE(req%src_i(req%max_size))
	335	ALLOCATE(req%src_j(req%max_size))
	336	ALLOCATE(req%target_i(req%max_size))
	337	ALLOCATE(req%target_j(req%max_size))
[146]	338	ALLOCATE(req%target_sign(req%max_size))
[26]	339	ENDDO
[963]	340
[26]	341	END SUBROUTINE create_request
	342
	343	SUBROUTINE reallocate_request(req)
	344	IMPLICIT NONE
	345	TYPE(t_request),POINTER :: req
[963]	346
[26]	347	INTEGER,POINTER :: src_domain(:)
	348	INTEGER,POINTER :: src_ind(:)
	349	INTEGER,POINTER :: target_ind(:)
	350	INTEGER,POINTER :: src_i(:)
	351	INTEGER,POINTER :: src_j(:)
	352	INTEGER,POINTER :: target_i(:)
	353	INTEGER,POINTER :: target_j(:)
[146]	354	INTEGER,POINTER :: target_sign(:)
[26]	355
	356	PRINT *,"REALLOCATE_REQUEST"
	357	src_domain=>req%src_domain
	358	src_ind=>req%src_ind
	359	target_ind=>req%target_ind
	360	src_i=>req%src_i
	361	src_j=>req%src_j
	362	target_i=>req%target_i
	363	target_j=>req%target_j
[146]	364	target_sign=>req%target_sign
[151]	365
[26]	366	ALLOCATE(req%src_domain(req%max_size*2))
	367	ALLOCATE(req%src_ind(req%max_size*2))
	368	ALLOCATE(req%target_ind(req%max_size*2))
	369	ALLOCATE(req%src_i(req%max_size*2))
	370	ALLOCATE(req%src_j(req%max_size*2))
	371	ALLOCATE(req%target_i(req%max_size*2))
	372	ALLOCATE(req%target_j(req%max_size*2))
[146]	373	ALLOCATE(req%target_sign(req%max_size*2))
[963]	374
[26]	375	req%src_domain(1:req%max_size)=src_domain(:)
	376	req%src_ind(1:req%max_size)=src_ind(:)
	377	req%target_ind(1:req%max_size)=target_ind(:)
	378	req%src_i(1:req%max_size)=src_i(:)
	379	req%src_j(1:req%max_size)=src_j(:)
	380	req%target_i(1:req%max_size)=target_i(:)
	381	req%target_j(1:req%max_size)=target_j(:)
[146]	382	req%target_sign(1:req%max_size)=target_sign(:)
[963]	383
[26]	384	req%max_size=req%max_size*2
[963]	385
[26]	386	DEALLOCATE(src_domain)
	387	DEALLOCATE(src_ind)
	388	DEALLOCATE(target_ind)
	389	DEALLOCATE(src_i)
	390	DEALLOCATE(src_j)
	391	DEALLOCATE(target_i)
	392	DEALLOCATE(target_j)
[146]	393	DEALLOCATE(target_sign)
[26]	394
	395	END SUBROUTINE reallocate_request
	396
[963]	397
[26]	398	SUBROUTINE request_add_point(ind,i,j,request,pos)
	399	USE domain_mod
	400	USE field_mod
	401	IMPLICIT NONE
	402	INTEGER,INTENT(IN) :: ind
	403	INTEGER,INTENT(IN) :: i
	404	INTEGER,INTENT(IN) :: j
	405	TYPE(t_request),POINTER :: request(:)
	406	INTEGER,INTENT(IN),OPTIONAL :: pos
[963]	407
[26]	408	INTEGER :: src_domain
	409	INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta
	410	TYPE(t_request),POINTER :: req
	411	TYPE(t_domain),POINTER :: d
[963]	412
[26]	413	req=>request(ind)
	414	d=>domain(ind)
[963]	415
[26]	416	IF (req%max_size==req%size) CALL reallocate_request(req)
	417	req%size=req%size+1
	418	IF (req%type_field==field_t) THEN
	419	src_domain=domain(ind)%assign_domain(i,j)
	420	src_iim=domain_glo(src_domain)%iim
	421	src_i=domain(ind)%assign_i(i,j)
	422	src_j=domain(ind)%assign_j(i,j)
	423
	424	req%target_ind(req%size)=(j-1)*d%iim+i
[146]	425	req%target_sign(req%size)=1
[26]	426	req%src_domain(req%size)=src_domain
	427	req%src_ind(req%size)=(src_j-1)*src_iim+src_i
	428	ELSE IF (req%type_field==field_u) THEN
	429	IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
	430
	431	src_domain=domain(ind)%edge_assign_domain(pos-1,i,j)
	432	src_iim=domain_glo(src_domain)%iim
	433	src_i=domain(ind)%edge_assign_i(pos-1,i,j)
	434	src_j=domain(ind)%edge_assign_j(pos-1,i,j)
	435	src_n=(src_j-1)*src_iim+src_i
	436	src_delta=domain(ind)%delta(i,j)
	437	src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1
[963]	438
[26]	439	req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos)
[146]	440
	441	req%target_sign(req%size)= 1
	442	IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j)
	443
[26]	444	req%src_domain(req%size)=src_domain
	445	req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos)
	446
	447	ELSE IF (req%type_field==field_z) THEN
	448	IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
	449
[711]	450	src_domain=domain(ind)%vertex_assign_domain(pos-1,i,j)
[26]	451	src_iim=domain_glo(src_domain)%iim
[711]	452	src_i=domain(ind)%vertex_assign_i(pos-1,i,j)
	453	src_j=domain(ind)%vertex_assign_j(pos-1,i,j)
[26]	454	src_n=(src_j-1)*src_iim+src_i
	455	src_delta=domain(ind)%delta(i,j)
[711]	456	src_pos=domain(ind)%vertex_assign_pos(pos-1,i,j)+1
	457
[963]	458
[26]	459	req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos)
[146]	460	req%target_sign(req%size)=1
[26]	461	req%src_domain(req%size)=src_domain
	462	req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos)
	463	ENDIF
	464	END SUBROUTINE request_add_point
[963]	465
	466
[26]	467	SUBROUTINE Finalize_request(request)
	468	USE mpipara
	469	USE domain_mod
	470	USE mpi_mod
	471	IMPLICIT NONE
	472	TYPE(t_request),POINTER :: request(:)
[176]	473	TYPE(t_request),POINTER :: req, req_src
[26]	474	INTEGER :: nb_domain_recv(0:mpi_size-1)
	475	INTEGER :: nb_domain_send(0:mpi_size-1)
[186]	476	INTEGER :: tag_rank(0:mpi_size-1)
[26]	477	INTEGER :: nb_data_domain_recv(ndomain_glo)
	478	INTEGER :: list_domain_recv(ndomain_glo)
	479	INTEGER,ALLOCATABLE :: list_domain_send(:)
	480	INTEGER :: list_domain(ndomain)
	481
[186]	482	INTEGER :: rank,i,j,pos
[899]	483	INTEGER :: size_,ind_glo,ind_loc
[186]	484	INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv
[26]	485	INTEGER, ALLOCATABLE :: mpi_req(:)
	486	INTEGER, ALLOCATABLE :: status(:,:)
[186]	487	INTEGER, ALLOCATABLE :: rank_list(:)
	488	INTEGER, ALLOCATABLE :: offset(:)
	489	LOGICAL,PARAMETER :: debug = .FALSE.
	490
[963]	491
[26]	492	IF (.NOT. using_mpi) RETURN
[963]	493
[26]	494	DO ind_loc=1,ndomain
	495	req=>request(ind_loc)
[963]	496
[26]	497	nb_data_domain_recv(:) = 0
	498	nb_domain_recv(:) = 0
[186]	499	tag_rank(:)=0
[963]	500
[26]	501	DO i=1,req%size
	502	ind_glo=req%src_domain(i)
	503	nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1
	504	ENDDO
[963]	505
[26]	506	DO ind_glo=1,ndomain_glo
	507	IF ( nb_data_domain_recv(ind_glo) > 0 ) nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1
	508	ENDDO
	509
	510	req%nrecv=sum(nb_domain_recv(:))
	511	ALLOCATE(req%recv(req%nrecv))
	512
	513	irecv=0
	514	DO ind_glo=1,ndomain_glo
	515	IF (nb_data_domain_recv(ind_glo)>0) THEN
	516	irecv=irecv+1
	517	list_domain_recv(ind_glo)=irecv
	518	req%recv(irecv)%rank=domglo_rank(ind_glo)
	519	req%recv(irecv)%size=nb_data_domain_recv(ind_glo)
	520	req%recv(irecv)%domain=domglo_loc_ind(ind_glo)
	521	ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size))
[146]	522	ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size))
[26]	523	ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size))
	524	ENDIF
	525	ENDDO
[963]	526
[26]	527	req%recv(:)%size=0
	528	irecv=0
	529	DO i=1,req%size
	530	irecv=list_domain_recv(req%src_domain(i))
	531	req%recv(irecv)%size=req%recv(irecv)%size+1
[176]	532	size_=req%recv(irecv)%size
	533	req%recv(irecv)%value(size_)=req%src_ind(i)
	534	req%recv(irecv)%buffer(size_)=req%target_ind(i)
	535	req%recv(irecv)%sign(size_)=req%target_sign(i)
[26]	536	ENDDO
	537	ENDDO
	538
[963]	539	nb_domain_recv(:) = 0
[26]	540	DO ind_loc=1,ndomain
	541	req=>request(ind_loc)
[963]	542
[26]	543	DO irecv=1,req%nrecv
	544	rank=req%recv(irecv)%rank
	545	nb_domain_recv(rank)=nb_domain_recv(rank)+1
	546	ENDDO
	547	ENDDO
	548
[963]	549	CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)
	550
	551
[26]	552	ALLOCATE(list_domain_send(sum(nb_domain_send)))
[963]	553
[26]	554	nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:))
	555	ALLOCATE(mpi_req(nreq))
	556	ALLOCATE(status(MPI_STATUS_SIZE,nreq))
[186]	557
[963]	558
[26]	559	ireq=0
	560	DO ind_loc=1,ndomain
	561	req=>request(ind_loc)
	562	DO irecv=1,req%nrecv
	563	ireq=ireq+1
	564	CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr)
[186]	565	IF (debug) PRINT *,"Isend ",req%recv(irecv)%domain, "from ", mpi_rank, "to ",req%recv(irecv)%rank, "tag ",0
[26]	566	ENDDO
	567	ENDDO
[186]	568
[963]	569	IF (debug) PRINT *,"------------"
[26]	570	j=0
	571	DO rank=0,mpi_size-1
	572	DO i=1,nb_domain_send(rank)
	573	j=j+1
	574	ireq=ireq+1
	575	CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr)
[186]	576	IF (debug) PRINT *,"IRecv ",list_domain_send(j), "from ", rank, "to ",mpi_rank, "tag ",0
[26]	577	ENDDO
	578	ENDDO
[963]	579	IF (debug) PRINT *,"------------"
	580
[26]	581	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
[963]	582
[26]	583	list_domain(:)=0
	584	DO i=1,sum(nb_domain_send)
	585	ind_loc=list_domain_send(i)
	586	list_domain(ind_loc)=list_domain(ind_loc)+1
	587	ENDDO
[963]	588
[26]	589	DO ind_loc=1,ndomain
	590	req=>request(ind_loc)
	591	req%nsend=list_domain(ind_loc)
	592	ALLOCATE(req%send(req%nsend))
	593	ENDDO
[186]	594
[963]	595	IF (debug) PRINT *,"------------"
	596
	597	ireq=0
[26]	598	DO ind_loc=1,ndomain
	599	req=>request(ind_loc)
[963]	600
[26]	601	DO irecv=1,req%nrecv
	602	ireq=ireq+1
	603	CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
[186]	604	IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
[26]	605	ENDDO
[963]	606	IF (debug) PRINT *,"------------"
	607
[26]	608	DO isend=1,req%nsend
	609	ireq=ireq+1
	610	CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr)
[186]	611	IF (debug) PRINT *,"IRecv ",req%send(isend)%rank, "from ", "xxx", "to ",mpi_rank, "tag ",ind_loc
[26]	612	ENDDO
	613	ENDDO
	614
[963]	615	IF (debug) PRINT *,"------------"
[186]	616
[26]	617	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
	618	CALL MPI_BARRIER(comm_icosa,ierr)
	619
[963]	620	IF (debug) PRINT *,"------------"
[186]	621
[963]	622	ireq=0
[26]	623	DO ind_loc=1,ndomain
	624	req=>request(ind_loc)
[963]	625
[26]	626	DO irecv=1,req%nrecv
	627	ireq=ireq+1
[176]	628	CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
[186]	629	IF (debug) PRINT *,"Isend ",ind_loc, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
[176]	630	ENDDO
[186]	631
[963]	632	IF (debug) PRINT *,"------------"
	633
[176]	634	DO isend=1,req%nsend
	635	ireq=ireq+1
	636	CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
[186]	637	IF (debug) PRINT *,"IRecv ",req%send(isend)%domain, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
[176]	638	ENDDO
	639	ENDDO
[963]	640	IF (debug) PRINT *,"------------"
	641
[176]	642	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
	643	CALL MPI_BARRIER(comm_icosa,ierr)
[963]	644	IF (debug) PRINT *,"------------"
[176]	645
[186]	646	ireq=0
	647	DO ind_loc=1,ndomain
	648	req=>request(ind_loc)
[963]	649
[186]	650	DO irecv=1,req%nrecv
	651	ireq=ireq+1
	652	req%recv(irecv)%tag=tag_rank(req%recv(irecv)%rank)
	653	tag_rank(req%recv(irecv)%rank)=tag_rank(req%recv(irecv)%rank)+1
	654	CALL MPI_ISEND(req%recv(irecv)%tag,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
	655	IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
	656	ENDDO
[963]	657	IF (debug) PRINT *,"------------"
	658
[186]	659	DO isend=1,req%nsend
	660	ireq=ireq+1
	661	CALL MPI_IRECV(req%send(isend)%tag,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
	662	IF (debug) PRINT *,"IRecv ",req%send(isend)%tag, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
	663	ENDDO
	664	ENDDO
[963]	665	IF (debug) PRINT *,"------------"
	666
[186]	667	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
	668	CALL MPI_BARRIER(comm_icosa,ierr)
	669
	670
[963]	671	IF (debug) PRINT *,"------------"
[186]	672
[963]	673	ireq=0
[176]	674	DO ind_loc=1,ndomain
	675	req=>request(ind_loc)
[963]	676
[176]	677	DO irecv=1,req%nrecv
	678	ireq=ireq+1
[186]	679	CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
	680	IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
[26]	681	ENDDO
[963]	682	IF (debug) PRINT *,"------------"
	683
[26]	684	DO isend=1,req%nsend
	685	ireq=ireq+1
[186]	686	CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
	687	IF (debug) PRINT *,"IRecv ",req%send(isend)%size, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
[26]	688	ENDDO
	689	ENDDO
	690
	691	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
	692
[963]	693	ireq=0
[26]	694	DO ind_loc=1,ndomain
	695	req=>request(ind_loc)
[963]	696
[26]	697	DO irecv=1,req%nrecv
	698	ireq=ireq+1
[44]	699	CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,&
[186]	700	req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
[26]	701	ENDDO
[963]	702
[26]	703	DO isend=1,req%nsend
	704	ireq=ireq+1
	705	ALLOCATE(req%send(isend)%value(req%send(isend)%size))
[44]	706	CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,&
[186]	707	req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
[26]	708	ENDDO
	709	ENDDO
	710
	711	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
	712
	713	DO ind_loc=1,ndomain
	714	req=>request(ind_loc)
[963]	715
[26]	716	DO irecv=1,req%nrecv
	717	req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:)
[146]	718	req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:)
[26]	719	DEALLOCATE(req%recv(irecv)%buffer)
	720	ENDDO
[963]	721	ENDDO
[176]	722
[963]	723
[186]	724	! domain is on the same mpi process => copie memory to memory
[963]	725
[176]	726	DO ind_loc=1,ndomain
	727	req=>request(ind_loc)
[963]	728
[176]	729	DO irecv=1,req%nrecv
[963]	730
[176]	731	IF (req%recv(irecv)%rank==mpi_rank) THEN
	732	req_src=>request(req%recv(irecv)%domain)
	733	DO isend=1,req_src%nsend
[186]	734	IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN
[176]	735	req%recv(irecv)%src_value => req_src%send(isend)%value
	736	IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN
[186]	737	PRINT *,ind_loc, irecv, isend, size(req%recv(irecv)%value), size(req_src%send(isend)%value)
[176]	738	STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value"
	739	ENDIF
	740	ENDIF
	741	ENDDO
	742	ENDIF
[963]	743
[176]	744	ENDDO
	745	ENDDO
[963]	746
[176]	747	! true number of mpi request
[186]	748
	749	request(:)%nreq_mpi=0
	750	request(:)%nreq_send=0
	751	request(:)%nreq_recv=0
	752	ALLOCATE(rank_list(sum(request(:)%nsend)))
	753	ALLOCATE(offset(sum(request(:)%nsend)))
	754	offset(:)=0
[963]	755
[186]	756	nsend=0
[176]	757	DO ind_loc=1,ndomain
	758	req=>request(ind_loc)
	759
	760	DO isend=1,req%nsend
[186]	761	IF (req%send(isend)%rank/=mpi_rank) THEN
	762	pos=0
	763	DO i=1,nsend
	764	IF (req%send(isend)%rank==rank_list(i)) EXIT
	765	pos=pos+1
	766	ENDDO
[963]	767
[186]	768	IF (pos==nsend) THEN
	769	nsend=nsend+1
	770	req%nreq_mpi=req%nreq_mpi+1
	771	req%nreq_send=req%nreq_send+1
[193]	772	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
[186]	773	rank_list(nsend)=req%send(isend)%rank
	774	ELSE
	775	rank_list(nsend)=-1
	776	ENDIF
	777	ENDIF
[963]	778
[186]	779	pos=pos+1
	780	req%send(isend)%ireq=pos
	781	req%send(isend)%offset=offset(pos)
	782	offset(pos)=offset(pos)+req%send(isend)%size
	783	ENDIF
[176]	784	ENDDO
[186]	785	ENDDO
	786
	787	DEALLOCATE(rank_list)
	788	DEALLOCATE(offset)
[963]	789
[186]	790	ALLOCATE(rank_list(sum(request(:)%nrecv)))
	791	ALLOCATE(offset(sum(request(:)%nrecv)))
	792	offset(:)=0
[963]	793
[186]	794	nrecv=0
	795	DO ind_loc=1,ndomain
	796	req=>request(ind_loc)
	797
[176]	798	DO irecv=1,req%nrecv
[186]	799	IF (req%recv(irecv)%rank/=mpi_rank) THEN
	800	pos=0
	801	DO i=1,nrecv
	802	IF (req%recv(irecv)%rank==rank_list(i)) EXIT
	803	pos=pos+1
	804	ENDDO
[963]	805
[186]	806	IF (pos==nrecv) THEN
	807	nrecv=nrecv+1
	808	req%nreq_mpi=req%nreq_mpi+1
	809	req%nreq_recv=req%nreq_recv+1
[193]	810	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
[186]	811	rank_list(nrecv)=req%recv(irecv)%rank
	812	ELSE
	813	rank_list(nrecv)=-1
	814	ENDIF
	815	ENDIF
[963]	816
[186]	817	pos=pos+1
	818	req%recv(irecv)%ireq=nsend+pos
	819	req%recv(irecv)%offset=offset(pos)
	820	offset(pos)=offset(pos)+req%recv(irecv)%size
	821	ENDIF
[176]	822	ENDDO
[963]	823	ENDDO
[186]	824
[963]	825	! get the offsets
[186]	826
[963]	827	ireq=0
[186]	828	DO ind_loc=1,ndomain
	829	req=>request(ind_loc)
[963]	830
[186]	831	DO irecv=1,req%nrecv
	832	ireq=ireq+1
	833	CALL MPI_ISEND(req%recv(irecv)%offset,1,MPI_INTEGER,&
	834	req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
	835	ENDDO
[963]	836
[186]	837	DO isend=1,req%nsend
	838	ireq=ireq+1
	839	CALL MPI_IRECV(req%send(isend)%offset,1,MPI_INTEGER,&
	840	req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
	841	ENDDO
	842	ENDDO
	843
	844	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
[26]	845
	846
[963]	847	END SUBROUTINE Finalize_request
	848
	849
[364]	850	SUBROUTINE init_message_seq(field, request, message, name)
[151]	851	USE field_mod
	852	USE domain_mod
	853	USE mpi_mod
	854	USE mpipara
	855	USE mpi_mod
	856	IMPLICIT NONE
	857	TYPE(t_field),POINTER :: field(:)
	858	TYPE(t_request),POINTER :: request(:)
	859	TYPE(t_message) :: message
[364]	860	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name
[963]	861	!$OMP MASTER
[151]	862	message%request=>request
[364]	863	IF(PRESENT(name)) THEN
	864	message%name = TRIM(name)
	865	ELSE
	866	message%name = 'unknown'
	867	END IF
[963]	868	!$OMP END MASTER
	869	!$OMP BARRIER
[151]	870
	871	END SUBROUTINE init_message_seq
	872
	873	SUBROUTINE send_message_seq(field,message)
	874	USE field_mod
	875	USE domain_mod
	876	USE mpi_mod
	877	USE mpipara
	878	USE omp_para
	879	USE trace
	880	IMPLICIT NONE
	881	TYPE(t_field),POINTER :: field(:)
	882	TYPE(t_message) :: message
	883
	884	CALL transfert_request_seq(field,message%request)
[963]	885
[151]	886	END SUBROUTINE send_message_seq
[963]	887
[151]	888	SUBROUTINE test_message_seq(message)
	889	IMPLICIT NONE
	890	TYPE(t_message) :: message
	891	END SUBROUTINE test_message_seq
[963]	892
	893
[151]	894	SUBROUTINE wait_message_seq(message)
	895	IMPLICIT NONE
	896	TYPE(t_message) :: message
	897
[963]	898	END SUBROUTINE wait_message_seq
[151]	899
[364]	900	SUBROUTINE init_message_mpi(field,request, message, name)
[151]	901	USE field_mod
	902	USE domain_mod
	903	USE mpi_mod
	904	USE mpipara
	905	USE mpi_mod
	906	IMPLICIT NONE
[963]	907
[151]	908	TYPE(t_field),POINTER :: field(:)
	909	TYPE(t_request),POINTER :: request(:)
	910	TYPE(t_message) :: message
[364]	911	CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: name
[151]	912
	913	TYPE(t_request),POINTER :: req
	914	INTEGER :: irecv,isend
[899]	915	INTEGER :: ireq,nreq
[151]	916	INTEGER :: ind
	917	INTEGER :: dim3,dim4
[188]	918	INTEGER,SAVE :: message_number=0
[186]	919	! TYPE(t_reorder),POINTER :: reorder(:)
	920	! TYPE(t_reorder) :: reorder_swap
[151]	921
[186]	922	!$OMP BARRIER
[151]	923	!$OMP MASTER
[953]	924	!init off-device
	925	message%ondevice=.false.
	926
[364]	927	IF(PRESENT(name)) THEN
	928	message%name = TRIM(name)
	929	ELSE
	930	message%name = 'unknown'
	931	END IF
[176]	932	message%number=message_number
	933	message_number=message_number+1
	934	IF (message_number==100) message_number=0
[186]	935
[963]	936
[151]	937	message%request=>request
[176]	938	message%nreq=sum(message%request(:)%nreq_mpi)
[186]	939	message%nreq_send=sum(message%request(:)%nreq_send)
	940	message%nreq_recv=sum(message%request(:)%nreq_recv)
	941	nreq=message%nreq
	942
[151]	943	ALLOCATE(message%mpi_req(nreq))
	944	ALLOCATE(message%buffers(nreq))
	945	ALLOCATE(message%status(MPI_STATUS_SIZE,nreq))
[186]	946	message%buffers(:)%size=0
[151]	947	message%pending=.FALSE.
	948	message%completed=.FALSE.
[364]	949	message%open=.FALSE.
	950
[186]	951	DO ind=1,ndomain
	952	req=>request(ind)
	953	DO isend=1,req%nsend
	954	IF (req%send(isend)%rank/=mpi_rank) THEN
[963]	955	ireq=req%send(isend)%ireq
[186]	956	message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size
	957	message%buffers(ireq)%rank=req%send(isend)%rank
	958	ENDIF
	959	ENDDO
	960	DO irecv=1,req%nrecv
	961	IF (req%recv(irecv)%rank/=mpi_rank) THEN
[963]	962	ireq=req%recv(irecv)%ireq
[186]	963	message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size
	964	message%buffers(ireq)%rank=req%recv(irecv)%rank
	965	ENDIF
	966	ENDDO
	967	ENDDO
	968
	969
[151]	970	IF (field(1)%data_type==type_real) THEN
	971
	972	IF (field(1)%ndim==2) THEN
[963]	973
[186]	974	DO ireq=1,message%nreq
	975	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
	976	ENDDO
[963]	977
[186]	978	ELSE IF (field(1)%ndim==3) THEN
[963]	979
[186]	980	dim3=size(field(1)%rval3d,2)
	981	DO ireq=1,message%nreq
	982	message%buffers(ireq)%size=message%buffers(ireq)%size*dim3
	983	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
[151]	984	ENDDO
[963]	985
[186]	986	ELSE IF (field(1)%ndim==4) THEN
	987	dim3=size(field(1)%rval4d,2)
	988	dim4=size(field(1)%rval4d,3)
	989	DO ireq=1,message%nreq
	990	message%buffers(ireq)%size=message%buffers(ireq)%sizedim3dim4
	991	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
	992	ENDDO
[963]	993	ENDIF
[186]	994	ENDIF
[963]	995
	996
	997
[186]	998	! ! Reorder the request, so recv request are done in the same order than send request
	999
[963]	1000	! nreq_send=sum(request(:)%nsend)
[186]	1001	! message%nreq_send=nreq_send
	1002	! ALLOCATE(message%reorder(nreq_send))
	1003	! reorder=>message%reorder
	1004	! ireq=0
	1005	! DO ind=1,ndomain
	1006	! req=>request(ind)
	1007	! DO isend=1,req%nsend
	1008	! ireq=ireq+1
	1009	! reorder(ireq)%ind=ind
	1010	! reorder(ireq)%isend=isend
	1011	! reorder(ireq)%tag=req%send(isend)%tag
	1012	! ENDDO
	1013	! ENDDO
	1014
	1015	! ! do a very very bad sort
	1016	! DO i=1,nreq_send-1
	1017	! DO j=i+1,nreq_send
	1018	! IF (reorder(i)%tag > reorder(j)%tag) THEN
	1019	! reorder_swap=reorder(i)
	1020	! reorder(i)=reorder(j)
	1021	! reorder(j)=reorder_swap
	1022	! ENDIF
	1023	! ENDDO
	1024	! ENDDO
	1025	! PRINT *,"reorder ",reorder(:)%tag
[963]	1026
	1027
[186]	1028	!$OMP END MASTER
[963]	1029	!$OMP BARRIER
[151]	1030
[186]	1031	END SUBROUTINE init_message_mpi
[963]	1032
	1033	SUBROUTINE Finalize_message_mpi(message)
[186]	1034	USE field_mod
	1035	USE domain_mod
	1036	USE mpi_mod
	1037	USE mpipara
	1038	USE mpi_mod
	1039	IMPLICIT NONE
	1040	TYPE(t_message) :: message
	1041
[953]	1042	INTEGER :: ireq, ibuff
[186]	1043
	1044	!$OMP BARRIER
	1045	!$OMP MASTER
	1046
	1047
[962]	1048	IF (message%field(1)%data_type==type_real) THEN
	1049	DO ireq=1,message%nreq
	1050	CALL free_mpi_buffer(message%buffers(ireq)%r)
[963]	1051	ENDDO
[151]	1052	ENDIF
[953]	1053
	1054	!deallocate device data if ondevice
	1055	if(message%ondevice) then
	1056	do ireq=1, ndomain
	1057	do ibuff=1,message%request(ireq)%nsend
	1058	!$acc exit data delete(message%request(ireq)%send(ibuff)%buffer(:))
	1059	!$acc exit data delete(message%request(ireq)%send(ibuff)%buffer_r(:))
	1060	!$acc exit data delete(message%request(ireq)%send(ibuff)%sign(:))
	1061	!$acc exit data delete(message%request(ireq)%send(ibuff)%src_value(:))
	1062	!$acc exit data delete(message%request(ireq)%send(ibuff)%value(:))
	1063	end do
	1064	do ibuff=1,message%request(ireq)%nrecv
	1065	!$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer(:))
	1066	!$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer_r(:))
	1067	!$acc exit data delete(message%request(ireq)%recv(ibuff)%sign(:))
	1068	!$acc exit data delete(message%request(ireq)%recv(ibuff)%src_value(:))
	1069	!$acc exit data delete(message%request(ireq)%recv(ibuff)%value(:))
	1070	end do
	1071	end do
	1072	DO ireq=1,message%nreq
	1073	!$acc exit data delete(message%buffers(ireq)%r)
	1074	ENDDO
	1075	message%ondevice=.false.
	1076	end if
	1077
[364]	1078	DEALLOCATE(message%mpi_req)
	1079	DEALLOCATE(message%buffers)
	1080	DEALLOCATE(message%status)
[186]	1081
[151]	1082	!$OMP END MASTER
[186]	1083	!$OMP BARRIER
	1084
[963]	1085
[186]	1086	END SUBROUTINE Finalize_message_mpi
	1087
	1088
[953]	1089	!!!Update buffers on device for 'message'
	1090	!!! does create_device_message when not already ondevice
	1091	SUBROUTINE update_device_message_mpi(message)
	1092	USE domain_mod
	1093	IMPLICIT NONE
	1094	TYPE(t_message), intent(inout) :: message
	1095	INTEGER :: ireq, ibuff
	1096
	1097	!if(.not. message%ondevice) call create_device_message_mpi(message)
	1098
	1099	do ireq=1, ndomain
	1100	do ibuff=1,message%request(ireq)%nsend
	1101	!device buffers updated even if pointers not attached :
	1102	!non allocated buffers in 'message' must be set to NULL()
	1103	!$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer(:)) async
	1104	!$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer_r(:)) async
	1105	!$acc enter data copyin(message%request(ireq)%send(ibuff)%sign(:)) async
	1106	!$acc enter data copyin(message%request(ireq)%send(ibuff)%src_value(:)) async
	1107	!$acc enter data copyin(message%request(ireq)%send(ibuff)%value(:)) async
	1108	end do
	1109	do ibuff=1,message%request(ireq)%nrecv
	1110	!$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer(:)) async
	1111	!$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer_r(:)) async
	1112	!$acc enter data copyin(message%request(ireq)%recv(ibuff)%sign(:)) async
	1113	!$acc enter data copyin(message%request(ireq)%recv(ibuff)%src_value(:)) async
	1114	!$acc enter data copyin(message%request(ireq)%recv(ibuff)%value(:)) async
	1115	end do
	1116	end do
	1117	DO ireq=1,message%nreq
	1118	!$acc enter data copyin(message%buffers(ireq)%r) async
	1119	ENDDO
	1120	message%ondevice=.true.
	1121	END SUBROUTINE
	1122
	1123	!TODO : add openacc with multiple process
[151]	1124	SUBROUTINE send_message_mpi(field,message)
[901]	1125	USE abort_mod
[667]	1126	USE profiling_mod
[151]	1127	USE field_mod
	1128	USE domain_mod
	1129	USE mpi_mod
	1130	USE mpipara
	1131	USE omp_para
	1132	USE trace
[953]	1133	USE abort_mod
[151]	1134	IMPLICIT NONE
	1135	TYPE(t_field),POINTER :: field(:)
	1136	TYPE(t_message) :: message
[963]	1137	REAL(rstd),POINTER :: rval2d(:), src_rval2d(:)
	1138	REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:)
	1139	REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:)
	1140	REAL(rstd),POINTER :: buffer_r(:)
	1141	INTEGER,POINTER :: value(:)
	1142	INTEGER,POINTER :: sgn(:)
	1143	TYPE(ARRAY),POINTER :: recv,send
[151]	1144	TYPE(t_request),POINTER :: req
	1145	INTEGER :: irecv,isend
[899]	1146	INTEGER :: ireq
	1147	INTEGER :: ind,n
[186]	1148	INTEGER :: dim3,dim4,d3,d4
[176]	1149	INTEGER,POINTER :: src_value(:)
[953]	1150	INTEGER :: offset,msize,moffset,rank
[327]	1151	INTEGER :: lbegin, lend
[478]	1152	INTEGER :: max_req
[151]	1153
[327]	1154	! CALL trace_start("send_message_mpi")
[186]	1155
[667]	1156	CALL enter_profile(id_mpi)
	1157
[953]	1158	!Prepare 'message' for on-device copies if field is on device
	1159	if( field(1)%ondevice .AND. .NOT. message%ondevice ) call update_device_message_mpi(message)
	1160
[962]	1161	CALL enter_profile(profile_mpi_omp_barrier)
[151]	1162	!$OMP BARRIER
[962]	1163	CALL exit_profile(profile_mpi_omp_barrier)
[151]	1164
	1165
[186]	1166	!$OMP MASTER
[364]	1167	IF(message%open) THEN
	1168	PRINT *, 'send_message_mpi : message ' // TRIM(message%name) // &
	1169	' is still open, no call to wait_message_mpi after last send_message_mpi'
[901]	1170	CALL dynamico_abort( "send_message_mpi : message still open" )
[364]	1171	END IF
	1172	message%open=.TRUE. ! will be set to .FALSE. by wait_message_mpi
	1173
[151]	1174	message%field=>field
	1175
[176]	1176	IF (message%nreq>0) THEN
	1177	message%completed=.FALSE.
	1178	message%pending=.TRUE.
	1179	ELSE
	1180	message%completed=.TRUE.
	1181	message%pending=.FALSE.
	1182	ENDIF
[151]	1183	!$OMP END MASTER
[962]	1184	CALL enter_profile(profile_mpi_omp_barrier)
[186]	1185	!$OMP BARRIER
[962]	1186	CALL exit_profile(profile_mpi_omp_barrier)
[186]	1187
[151]	1188	IF (field(1)%data_type==type_real) THEN
	1189	IF (field(1)%ndim==2) THEN
	1190
	1191	DO ind=1,ndomain
[295]	1192	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[963]	1193
[151]	1194	rval2d=>field(ind)%rval2d
[963]	1195
[151]	1196	req=>message%request(ind)
	1197	DO isend=1,req%nsend
	1198	send=>req%send(isend)
	1199	value=>send%value
	1200
[963]	1201
[186]	1202	IF (send%rank/=mpi_rank) THEN
	1203	ireq=send%ireq
[151]	1204
[186]	1205	buffer_r=>message%buffers(ireq)%r
	1206	offset=send%offset
[953]	1207	msize=send%size
[962]	1208	call enter_profile(profile_mpi_copies)
[953]	1209	!$acc parallel loop default(present) async if (field(ind)%ondevice)
	1210	DO n=1,msize
[186]	1211	buffer_r(offset+n)=rval2d(value(n))
[176]	1212	ENDDO
[962]	1213	call exit_profile(profile_mpi_copies)
[151]	1214
[186]	1215	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1216	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[963]	1217	!$OMP CRITICAL
[358]	1218	CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, &
	1219	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[186]	1220	!$OMP END CRITICAL
	1221	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1222	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1223	CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, &
	1224	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[186]	1225	ENDIF
[963]	1226
[186]	1227	ENDIF
[151]	1228	ENDDO
[186]	1229	ENDDO
[963]	1230
[186]	1231	DO ind=1,ndomain
[295]	1232	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[186]	1233	rval2d=>field(ind)%rval2d
[963]	1234	req=>message%request(ind)
[186]	1235
[151]	1236	DO irecv=1,req%nrecv
	1237	recv=>req%recv(irecv)
[176]	1238
[186]	1239	IF (recv%rank==mpi_rank) THEN
	1240
[176]	1241	value=>recv%value
	1242	src_value => recv%src_value
	1243	src_rval2d=>field(recv%domain)%rval2d
	1244	sgn=>recv%sign
[953]	1245	msize=recv%size
[962]	1246	call enter_profile(profile_mpi_copies)
[953]	1247	!$acc parallel loop default(present) async if (field(ind)%ondevice)
	1248	DO n=1,msize
[176]	1249	rval2d(value(n))=src_rval2d(src_value(n))*sgn(n)
	1250	ENDDO
[962]	1251	call exit_profile(profile_mpi_copies)
[186]	1252
	1253	ELSE
[963]	1254
[186]	1255	ireq=recv%ireq
	1256	buffer_r=>message%buffers(ireq)%r
	1257	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1258	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[963]	1259	!$OMP CRITICAL
[358]	1260	CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, &
	1261	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[186]	1262	!$OMP END CRITICAL
	1263	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1264	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1265	CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, &
	1266	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[186]	1267	ENDIF
[963]	1268
[176]	1269	ENDIF
[151]	1270	ENDDO
[963]	1271
[151]	1272	ENDDO
[963]	1273
	1274
[151]	1275	ELSE IF (field(1)%ndim==3) THEN
[478]	1276	max_req=0
[151]	1277	DO ind=1,ndomain
[478]	1278	req=>message%request(ind)
	1279	IF (req%nsend>max_req) max_req=req%nsend
	1280	ENDDO
[963]	1281
[478]	1282	DO ind=1,ndomain
[327]	1283	IF (.NOT. assigned_domain(ind) ) CYCLE
[186]	1284
[151]	1285	dim3=size(field(ind)%rval3d,2)
[604]	1286	CALL distrib_level(1,dim3, lbegin,lend)
[327]	1287
[151]	1288	rval3d=>field(ind)%rval3d
	1289	req=>message%request(ind)
[963]	1290
[151]	1291	DO isend=1,req%nsend
	1292	send=>req%send(isend)
	1293	value=>send%value
	1294
[186]	1295	IF (send%rank/=mpi_rank) THEN
	1296	ireq=send%ireq
	1297	buffer_r=>message%buffers(ireq)%r
	1298
[953]	1299	msize=send%size
	1300	moffset=send%offset
[962]	1301	call enter_profile(profile_mpi_copies)
[327]	1302
[953]	1303	!$acc parallel loop default(present) async if (field(ind)%ondevice)
[327]	1304	DO d3=lbegin,lend
[953]	1305	offset=moffsetdim3 + (d3-1)msize
	1306	!$acc loop
	1307	DO n=1,msize
[186]	1308	buffer_r(n+offset)=rval3d(value(n),d3)
[176]	1309	ENDDO
[186]	1310	ENDDO
[962]	1311	call exit_profile(profile_mpi_copies)
[151]	1312
[478]	1313	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
[962]	1314	CALL enter_profile(profile_mpi_omp_barrier)
	1315	!$OMP BARRIER
	1316	CALL exit_profile(profile_mpi_omp_barrier)
	1317
[478]	1318	ENDIF
[963]	1319
[327]	1320	IF (is_omp_level_master) THEN
	1321	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1322	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[963]	1323	!$OMP CRITICAL
[358]	1324	CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, &
	1325	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1326	!$OMP END CRITICAL
	1327	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1328	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1329	CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, &
	1330	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1331	ENDIF
[186]	1332	ENDIF
[478]	1333	ELSE
	1334	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
[962]	1335	CALL enter_profile(profile_mpi_omp_barrier)
	1336	!$OMP BARRIER
	1337	CALL exit_profile(profile_mpi_omp_barrier)
	1338
[478]	1339	ENDIF
[186]	1340	ENDIF
	1341	ENDDO
[478]	1342
	1343	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
	1344	DO isend=req%nsend+1,max_req
[962]	1345	CALL enter_profile(profile_mpi_omp_barrier)
	1346	!$OMP BARRIER
	1347	CALL exit_profile(profile_mpi_omp_barrier)
	1348
[478]	1349	ENDDO
	1350	ENDIF
	1351
[186]	1352	ENDDO
[963]	1353
[186]	1354	DO ind=1,ndomain
[327]	1355	IF (.NOT. assigned_domain(ind) ) CYCLE
[186]	1356	dim3=size(field(ind)%rval3d,2)
[604]	1357	CALL distrib_level(1,dim3, lbegin,lend)
[186]	1358	rval3d=>field(ind)%rval3d
	1359	req=>message%request(ind)
[151]	1360
	1361	DO irecv=1,req%nrecv
	1362	recv=>req%recv(irecv)
[176]	1363
[186]	1364	IF (recv%rank==mpi_rank) THEN
[176]	1365	value=>recv%value
	1366	src_value => recv%src_value
	1367	src_rval3d=>field(recv%domain)%rval3d
	1368	sgn=>recv%sign
[953]	1369	msize=recv%size
[186]	1370
[962]	1371	call enter_profile(profile_mpi_copies)
[327]	1372	CALL trace_start("copy_data")
[953]	1373	!$acc parallel loop collapse(2) default(present) async if (field(ind)%ondevice)
[327]	1374	DO d3=lbegin,lend
[953]	1375	DO n=1,msize
[327]	1376	rval3d(value(n),d3)=src_rval3d(src_value(n),d3)*sgn(n)
	1377	ENDDO
[176]	1378	ENDDO
[962]	1379	call exit_profile(profile_mpi_copies)
[327]	1380	CALL trace_end("copy_data")
[186]	1381
[176]	1382	ELSE
[186]	1383	ireq=recv%ireq
	1384	buffer_r=>message%buffers(ireq)%r
[963]	1385
[327]	1386	IF (is_omp_level_master) THEN
	1387	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1388	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[327]	1389	!$OMP CRITICAL
[358]	1390	CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, &
	1391	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1392	!$OMP END CRITICAL
	1393	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1394	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1395	CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, &
	1396	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1397	ENDIF
[186]	1398	ENDIF
[963]	1399	ENDIF
[151]	1400	ENDDO
[963]	1401
[151]	1402	ENDDO
	1403
	1404	ELSE IF (field(1)%ndim==4) THEN
[478]	1405
	1406	max_req=0
	1407	DO ind=1,ndomain
	1408	req=>message%request(ind)
	1409	IF (req%nsend>max_req) max_req=req%nsend
	1410	ENDDO
[963]	1411
[151]	1412	DO ind=1,ndomain
[327]	1413	IF (.NOT. assigned_domain(ind) ) CYCLE
[186]	1414
[151]	1415	dim3=size(field(ind)%rval4d,2)
[604]	1416	CALL distrib_level(1,dim3, lbegin,lend)
[151]	1417	dim4=size(field(ind)%rval4d,3)
	1418	rval4d=>field(ind)%rval4d
	1419	req=>message%request(ind)
	1420
	1421	DO isend=1,req%nsend
	1422	send=>req%send(isend)
	1423	value=>send%value
	1424
[186]	1425	IF (send%rank/=mpi_rank) THEN
[151]	1426
[186]	1427	ireq=send%ireq
	1428	buffer_r=>message%buffers(ireq)%r
[953]	1429	msize=send%size
	1430	moffset=send%offset
[186]	1431
[962]	1432	call enter_profile(profile_mpi_copies)
[327]	1433	CALL trace_start("copy_to_buffer")
[953]	1434	!$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice)
[186]	1435	DO d4=1,dim4
[327]	1436	DO d3=lbegin,lend
[953]	1437	offset=moffsetdim3dim4 + dim3msize(d4-1) + &
	1438	(d3-1)*msize
	1439	!$acc loop
	1440	DO n=1,msize
[186]	1441	buffer_r(n+offset)=rval4d(value(n),d3,d4)
	1442	ENDDO
	1443	ENDDO
[176]	1444	ENDDO
[327]	1445	CALL trace_end("copy_to_buffer")
[962]	1446	call exit_profile(profile_mpi_copies)
[151]	1447
[478]	1448	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
[962]	1449	CALL enter_profile(profile_mpi_omp_barrier)
	1450	!$OMP BARRIER
	1451	CALL exit_profile(profile_mpi_omp_barrier)
	1452
[478]	1453	ENDIF
	1454
[327]	1455	IF (is_omp_level_master) THEN
	1456	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1457	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[327]	1458	!$OMP CRITICAL
[358]	1459	CALL MPI_ISEND(buffer_r,send%sizedim3dim4,MPI_REAL8,send%rank, &
	1460	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1461	!$OMP END CRITICAL
	1462	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1463	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1464	CALL MPI_ISEND(buffer_r,send%sizedim3dim4,MPI_REAL8,send%rank, &
	1465	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1466	ENDIF
[186]	1467	ENDIF
[478]	1468	ELSE
	1469	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
[962]	1470	CALL enter_profile(profile_mpi_omp_barrier)
	1471	!$OMP BARRIER
	1472	CALL exit_profile(profile_mpi_omp_barrier)
	1473
[478]	1474	ENDIF
[176]	1475	ENDIF
[151]	1476	ENDDO
[963]	1477
[478]	1478	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN
	1479	DO isend=req%nsend+1,max_req
[962]	1480	CALL enter_profile(profile_mpi_omp_barrier)
	1481	!$OMP BARRIER
	1482	CALL exit_profile(profile_mpi_omp_barrier)
	1483
[478]	1484	ENDDO
	1485	ENDIF
	1486
[186]	1487	ENDDO
[963]	1488
[186]	1489	DO ind=1,ndomain
[327]	1490	IF (.NOT. assigned_domain(ind) ) CYCLE
[963]	1491
[186]	1492	dim3=size(field(ind)%rval4d,2)
[604]	1493	CALL distrib_level(1,dim3, lbegin,lend)
[186]	1494	dim4=size(field(ind)%rval4d,3)
	1495	rval4d=>field(ind)%rval4d
	1496	req=>message%request(ind)
[962]	1497
[151]	1498	DO irecv=1,req%nrecv
	1499	recv=>req%recv(irecv)
[186]	1500	IF (recv%rank==mpi_rank) THEN
[176]	1501	value=>recv%value
	1502	src_value => recv%src_value
	1503	src_rval4d=>field(recv%domain)%rval4d
	1504	sgn=>recv%sign
[953]	1505	msize=recv%size
[962]	1506	call enter_profile(profile_mpi_copies)
[953]	1507	CALL trace_start("copy_data")
	1508	!$acc parallel loop collapse(3) default(present) async if (field(ind)%ondevice)
[327]	1509	DO d4=1,dim4
	1510	DO d3=lbegin,lend
[953]	1511	DO n=1,msize
[327]	1512	rval4d(value(n),d3,d4)=src_rval4d(src_value(n),d3,d4)*sgn(n)
	1513	ENDDO
	1514	ENDDO
[176]	1515	ENDDO
[962]	1516	call exit_profile(profile_mpi_copies)
[327]	1517	CALL trace_end("copy_data")
[963]	1518
[176]	1519	ELSE
[186]	1520
	1521	ireq=recv%ireq
	1522	buffer_r=>message%buffers(ireq)%r
[327]	1523	IF (is_omp_level_master) THEN
	1524	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
[953]	1525	CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED")
[963]	1526	!$OMP CRITICAL
[358]	1527	CALL MPI_IRECV(buffer_r,recv%sizedim3dim4,MPI_REAL8,recv%rank, &
[963]	1528	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1529	!$OMP END CRITICAL
	1530	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
[953]	1531	CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE")
[358]	1532	CALL MPI_IRECV(buffer_r,recv%sizedim3dim4,MPI_REAL8,recv%rank, &
[963]	1533	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
[327]	1534	ENDIF
[186]	1535	ENDIF
[176]	1536	ENDIF
[151]	1537	ENDDO
	1538	ENDDO
[186]	1539
[963]	1540	ENDIF
[186]	1541
[193]	1542	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
[962]	1543	CALL enter_profile(profile_mpi_omp_barrier)
[953]	1544	!$acc wait
[186]	1545	!$OMP BARRIER
[962]	1546	CALL exit_profile(profile_mpi_omp_barrier)
[186]	1547	!$OMP MASTER
	1548
	1549	DO ireq=1,message%nreq_send
	1550	buffer_r=>message%buffers(ireq)%r
	1551	msize=message%buffers(ireq)%size
	1552	rank=message%buffers(ireq)%rank
[953]	1553	! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation
	1554	IF (message%ondevice) THEN
	1555	!$acc host_data use_device(buffer_r) ! if (message%ondevice)
	1556	CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
	1557	comm_icosa, message%mpi_req(ireq),ierr)
	1558	!$acc end host_data
	1559	ELSE
	1560	CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
	1561	comm_icosa, message%mpi_req(ireq),ierr)
	1562	ENDIF
[186]	1563	ENDDO
	1564
	1565	DO ireq=message%nreq_send+1,message%nreq_send+message%nreq_recv
	1566	buffer_r=>message%buffers(ireq)%r
	1567	msize=message%buffers(ireq)%size
	1568	rank=message%buffers(ireq)%rank
[953]	1569	! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation
	1570	IF (message%ondevice) THEN
	1571	!$acc host_data use_device(buffer_r) ! if (message%ondevice)
	1572	CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
	1573	comm_icosa, message%mpi_req(ireq),ierr)
	1574	!$acc end host_data
	1575	ELSE
	1576	CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
	1577	comm_icosa, message%mpi_req(ireq),ierr)
	1578	ENDIF
[186]	1579	ENDDO
	1580
	1581	!$OMP END MASTER
[963]	1582	ENDIF
[151]	1583	ENDIF
[962]	1584	CALL enter_profile(profile_mpi_omp_barrier)
[186]	1585	!$OMP BARRIER
[962]	1586	CALL exit_profile(profile_mpi_omp_barrier)
	1587
[327]	1588	! CALL trace_end("send_message_mpi")
[667]	1589
	1590	CALL exit_profile(id_mpi)
[963]	1591
[151]	1592	END SUBROUTINE send_message_mpi
[963]	1593
[151]	1594	SUBROUTINE test_message_mpi(message)
	1595	IMPLICIT NONE
	1596	TYPE(t_message) :: message
[963]	1597
[151]	1598	INTEGER :: ierr
	1599
	1600	!$OMP MASTER
[358]	1601	IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,&
	1602	message%mpi_req,message%completed,message%status,ierr)
[151]	1603	!$OMP END MASTER
	1604	END SUBROUTINE test_message_mpi
[963]	1605
	1606
[151]	1607	SUBROUTINE wait_message_mpi(message)
[667]	1608	USE profiling_mod
[151]	1609	USE field_mod
	1610	USE domain_mod
	1611	USE mpi_mod
	1612	USE mpipara
	1613	USE omp_para
	1614	USE trace
	1615	IMPLICIT NONE
	1616	TYPE(t_message) :: message
	1617
	1618	TYPE(t_field),POINTER :: field(:)
[963]	1619	REAL(rstd),POINTER :: rval2d(:)
	1620	REAL(rstd),POINTER :: rval3d(:,:)
	1621	REAL(rstd),POINTER :: rval4d(:,:,:)
	1622	REAL(rstd),POINTER :: buffer_r(:)
	1623	INTEGER,POINTER :: value(:)
	1624	INTEGER,POINTER :: sgn(:)
	1625	TYPE(ARRAY),POINTER :: recv
[151]	1626	TYPE(t_request),POINTER :: req
[899]	1627	INTEGER :: irecv
[151]	1628	INTEGER :: ireq,nreq
[899]	1629	INTEGER :: ind,n
[327]	1630	INTEGER :: dim3,dim4,d3,d4,lbegin,lend
[953]	1631	INTEGER :: offset, msize, moffset
[151]	1632
[364]	1633	message%open=.FALSE.
[186]	1634	IF (.NOT. message%pending) RETURN
[151]	1635
[667]	1636	CALL enter_profile(id_mpi)
	1637
[327]	1638	! CALL trace_start("wait_message_mpi")
[151]	1639
	1640	field=>message%field
	1641	nreq=message%nreq
[963]	1642
[151]	1643	IF (field(1)%data_type==type_real) THEN
	1644	IF (field(1)%ndim==2) THEN
	1645
[962]	1646	call enter_profile(profile_mpi_waitall)
	1647	!$OMP MASTER
	1648	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
[358]	1649	message%status,ierr)
[151]	1650	!$OMP END MASTER
	1651	!$OMP BARRIER
[962]	1652	call exit_profile(profile_mpi_waitall)
	1653	call enter_profile(profile_mpi_copies)
[151]	1654	DO ind=1,ndomain
[295]	1655	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[963]	1656
[151]	1657	rval2d=>field(ind)%rval2d
	1658	req=>message%request(ind)
	1659	DO irecv=1,req%nrecv
	1660	recv=>req%recv(irecv)
[186]	1661	IF (recv%rank/=mpi_rank) THEN
	1662	ireq=recv%ireq
	1663	buffer_r=>message%buffers(ireq)%r
[176]	1664	value=>recv%value
	1665	sgn=>recv%sign
[186]	1666	offset=recv%offset
[953]	1667	msize=recv%size
	1668	!$acc parallel loop default(present) async if (field(ind)%ondevice)
	1669	DO n=1,msize
[963]	1670	rval2d(value(n))=buffer_r(n+offset)*sgn(n)
[186]	1671	ENDDO
[151]	1672
[176]	1673	ENDIF
[151]	1674	ENDDO
[963]	1675
[151]	1676	ENDDO
[962]	1677	call exit_profile(profile_mpi_copies)
[151]	1678
	1679
	1680	ELSE IF (field(1)%ndim==3) THEN
[962]	1681	call enter_profile(profile_mpi_waitall)
[151]	1682	!$OMP MASTER
[962]	1683	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
	1684	message%status,ierr)
[151]	1685	!$OMP END MASTER
	1686	!$OMP BARRIER
[962]	1687	call exit_profile(profile_mpi_waitall)
[151]	1688
[963]	1689
[151]	1690	DO ind=1,ndomain
[327]	1691	IF (.NOT. assigned_domain(ind) ) CYCLE
[186]	1692
[151]	1693	rval3d=>field(ind)%rval3d
	1694	req=>message%request(ind)
	1695	DO irecv=1,req%nrecv
	1696	recv=>req%recv(irecv)
[186]	1697	IF (recv%rank/=mpi_rank) THEN
	1698	ireq=recv%ireq
	1699	buffer_r=>message%buffers(ireq)%r
[176]	1700	value=>recv%value
	1701	sgn=>recv%sign
[963]	1702
[186]	1703	dim3=size(rval3d,2)
[963]	1704
[604]	1705	CALL distrib_level(1,dim3, lbegin,lend)
[953]	1706	msize=recv%size
	1707	moffset=recv%offset
[962]	1708	call enter_profile(profile_mpi_copies)
[327]	1709	CALL trace_start("copy_from_buffer")
[963]	1710
[327]	1711	IF (req%vector) THEN
[953]	1712	!$acc parallel loop default(present) async if (field(ind)%ondevice)
[327]	1713	DO d3=lbegin,lend
[953]	1714	offset=moffsetdim3 + (d3-1)msize
	1715	!$acc loop
	1716	DO n=1,msize
[963]	1717	rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)
[327]	1718	ENDDO
[186]	1719	ENDDO
[327]	1720	ELSE
[953]	1721	!$acc parallel loop default(present) async if (field(ind)%ondevice)
[327]	1722	DO d3=lbegin,lend
[953]	1723	offset=moffsetdim3 + (d3-1)msize
	1724	!$acc loop
	1725	DO n=1,msize
[963]	1726	rval3d(value(n),d3)=buffer_r(n+offset)
[327]	1727	ENDDO
	1728	ENDDO
	1729	ENDIF
[963]	1730
[327]	1731	CALL trace_end("copy_from_buffer")
[962]	1732	call exit_profile(profile_mpi_copies)
[176]	1733	ENDIF
[151]	1734	ENDDO
[963]	1735
[151]	1736	ENDDO
	1737
	1738	ELSE IF (field(1)%ndim==4) THEN
[962]	1739	call enter_profile(profile_mpi_waitall)
[151]	1740	!$OMP MASTER
[358]	1741	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
	1742	message%status,ierr)
[151]	1743	!$OMP END MASTER
	1744	!$OMP BARRIER
[962]	1745	call exit_profile(profile_mpi_waitall)
[151]	1746
[963]	1747
[151]	1748	DO ind=1,ndomain
[327]	1749	IF (.NOT. assigned_domain(ind) ) CYCLE
[186]	1750
[151]	1751	rval4d=>field(ind)%rval4d
	1752	req=>message%request(ind)
	1753	DO irecv=1,req%nrecv
	1754	recv=>req%recv(irecv)
[186]	1755	IF (recv%rank/=mpi_rank) THEN
	1756	ireq=recv%ireq
	1757	buffer_r=>message%buffers(ireq)%r
[176]	1758	value=>recv%value
	1759	sgn=>recv%sign
[151]	1760
[186]	1761	dim3=size(rval4d,2)
[604]	1762	CALL distrib_level(1,dim3, lbegin,lend)
[186]	1763	dim4=size(rval4d,3)
[953]	1764	msize=recv%size
	1765	moffset=recv%offset
[962]	1766	call enter_profile(profile_mpi_copies)
[327]	1767	CALL trace_start("copy_from_buffer")
[953]	1768	!$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice)
[186]	1769	DO d4=1,dim4
[327]	1770	DO d3=lbegin,lend
[953]	1771	offset=moffsetdim3dim4 + dim3msize(d4-1) + &
	1772	(d3-1)*msize
	1773	!$acc loop
	1774	DO n=1,msize
[963]	1775	rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n)
[186]	1776	ENDDO
	1777	ENDDO
[176]	1778	ENDDO
[327]	1779	CALL trace_end("copy_from_buffer")
[962]	1780	call exit_profile(profile_mpi_copies)
[176]	1781	ENDIF
[151]	1782	ENDDO
[963]	1783
[151]	1784	ENDDO
[963]	1785
	1786	ENDIF
	1787
[151]	1788	ENDIF
	1789
	1790	!$OMP MASTER
	1791	message%pending=.FALSE.
	1792	!$OMP END MASTER
	1793
[327]	1794	! CALL trace_end("wait_message_mpi")
[151]	1795	!$OMP BARRIER
[963]	1796
[667]	1797	CALL exit_profile(id_mpi)
	1798
[151]	1799	END SUBROUTINE wait_message_mpi
	1800
[26]	1801
[151]	1802	SUBROUTINE transfert_request_seq(field,request)
[26]	1803	USE field_mod
	1804	USE domain_mod
	1805	IMPLICIT NONE
	1806	TYPE(t_field),POINTER :: field(:)
	1807	TYPE(t_request),POINTER :: request(:)
[963]	1808	REAL(rstd),POINTER :: rval2d(:)
	1809	REAL(rstd),POINTER :: rval3d(:,:)
	1810	REAL(rstd),POINTER :: rval4d(:,:,:)
[26]	1811	INTEGER :: ind
	1812	TYPE(t_request),POINTER :: req
	1813	INTEGER :: n
[963]	1814
[26]	1815	DO ind=1,ndomain
	1816	req=>request(ind)
	1817	rval2d=>field(ind)%rval2d
	1818	rval3d=>field(ind)%rval3d
	1819	rval4d=>field(ind)%rval4d
[963]	1820
[26]	1821	IF (field(ind)%data_type==type_real) THEN
	1822	IF (field(ind)%ndim==2) THEN
	1823	DO n=1,req%size
[358]	1824	rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*&
	1825	req%target_sign(n)
[26]	1826	ENDDO
	1827	ELSE IF (field(ind)%ndim==3) THEN
	1828	DO n=1,req%size
[358]	1829	rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*&
	1830	req%target_sign(n)
[26]	1831	ENDDO
	1832	ELSE IF (field(ind)%ndim==4) THEN
	1833	DO n=1,req%size
[358]	1834	rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*&
	1835	req%target_sign(n)
[26]	1836	ENDDO
	1837	ENDIF
[963]	1838	ENDIF
[26]	1839
	1840	ENDDO
[963]	1841
[151]	1842	END SUBROUTINE transfert_request_seq
[26]	1843
	1844
[963]	1845	END MODULE transfert_mpi_legacy_mod
[26]	1846
	1847
[151]	1848
[266]	1849
[392]	1850

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: codes/icosagcm/trunk/src/parallel/transfert_mpi_legacy.f90

Download in other formats: