1 | MODULE transfer_unstructured_mod |
---|
2 | USE data_unstructured_mod |
---|
3 | IMPLICIT NONE |
---|
4 | SAVE |
---|
5 | PRIVATE |
---|
6 | |
---|
7 | INCLUDE 'mpif.h' |
---|
8 | |
---|
9 | LOGICAL :: transfer_initialized=.FALSE. |
---|
10 | PUBLIC :: update_halo |
---|
11 | |
---|
12 | CONTAINS |
---|
13 | |
---|
14 | SUBROUTINE init_halo_transfer(halo, rank, num, cells) |
---|
15 | TYPE(Halo_transfer) :: halo |
---|
16 | INTEGER :: ranks, total, rank(:), num(:), cells(:) |
---|
17 | ranks=SIZE(rank) |
---|
18 | total=SIZE(cells) |
---|
19 | IF(total /= SUM(num) ) STOP 'init_halo_transfer : SIZE(cells)<>SUM(num)' |
---|
20 | halo%ranks = ranks |
---|
21 | ALLOCATE(halo%rank(ranks)) |
---|
22 | ALLOCATE(halo%num(ranks)) |
---|
23 | ALLOCATE(halo%cells(total)) |
---|
24 | ALLOCATE(halo%buf2(llm+1,total)) |
---|
25 | halo%rank=rank |
---|
26 | halo%num=num |
---|
27 | halo%cells=cells |
---|
28 | END SUBROUTINE init_halo_transfer |
---|
29 | |
---|
30 | SUBROUTINE init_transfer(index, & |
---|
31 | send_num, send_size, send_rank, send_len, send_list, & |
---|
32 | recv_num, recv_size, recv_rank, recv_len, recv_list) & |
---|
33 | BIND(C, name='dynamico_init_transfer') |
---|
34 | INTEGER(C_INT), VALUE :: index, send_num, send_size, recv_num, recv_size |
---|
35 | INTEGER(C_INT) :: send_rank(send_num), send_len(send_num), send_list(send_size), & |
---|
36 | recv_rank(recv_num), recv_len(recv_num), recv_list(recv_size) |
---|
37 | PRINT *, 'init_transfer', index, & |
---|
38 | send_num, send_size, '/', send_rank, '/', send_len, '/', & |
---|
39 | recv_num, recv_size, '/', recv_rank, '/', recv_len, '/' |
---|
40 | CALL init_halo_transfer(send_info(index), send_rank, send_len, send_list) |
---|
41 | CALL init_halo_transfer(recv_info(index), recv_rank, recv_len, recv_list) |
---|
42 | transfer_initialized=.TRUE. |
---|
43 | END SUBROUTINE init_transfer |
---|
44 | |
---|
45 | !-------------------------------------------------------------------------------------------------! |
---|
46 | |
---|
47 | SUBROUTINE copy_in(lldata, ndata, llbuf, nbuf, cells, data, buf) |
---|
48 | INTEGER :: ndata, lldata, nbuf, llbuf, cells(nbuf), i |
---|
49 | REAL(C_DOUBLE) :: data(lldata,ndata), buf(llbuf,nbuf) |
---|
50 | !$OMP DO |
---|
51 | DO i=1,nbuf |
---|
52 | buf(1:lldata,i) = data(1:lldata, cells(i)) |
---|
53 | END DO |
---|
54 | !$OMP END DO |
---|
55 | END SUBROUTINE copy_in |
---|
56 | |
---|
57 | SUBROUTINE copy_out(lldata, ndata, llbuf, nbuf, cells, data, buf) |
---|
58 | INTEGER :: ndata, lldata, nbuf, llbuf, cells(nbuf), i |
---|
59 | REAL(C_DOUBLE) :: data(lldata,ndata), buf(llbuf,nbuf) |
---|
60 | !$OMP DO SCHEDULE(STATIC) |
---|
61 | DO i=1,nbuf |
---|
62 | data(1:lldata, cells(i)) = buf(1:lldata,i) |
---|
63 | END DO |
---|
64 | !$OMP END DO |
---|
65 | END SUBROUTINE copy_out |
---|
66 | |
---|
67 | SUBROUTINE update_halo(index, data) |
---|
68 | INTEGER :: index ! transfer_XXX, cf data_unstructured.F90 |
---|
69 | REAL(C_DOUBLE) :: data(:,:) |
---|
70 | TYPE(Halo_transfer), POINTER :: halo |
---|
71 | REAL(C_DOUBLE), POINTER :: buf(:,:) |
---|
72 | INTEGER :: req(send_info(index)%ranks+recv_info(index)%ranks), & |
---|
73 | status(MPI_STATUS_SIZE, send_info(index)%ranks+recv_info(index)%ranks) |
---|
74 | INTEGER :: llbuf, num, i, istart, ireq, ierr |
---|
75 | IF(.NOT. transfer_initialized) RETURN |
---|
76 | halo => send_info(index) |
---|
77 | buf => halo%buf2 |
---|
78 | llbuf = SIZE(buf,1) |
---|
79 | CALL copy_in(SIZE(data,1), SIZE(data,2), llbuf, SIZE(buf,2), halo%cells, data, buf) |
---|
80 | |
---|
81 | !$OMP MASTER |
---|
82 | ireq=0 |
---|
83 | istart=1 |
---|
84 | DO i = 1,halo%ranks |
---|
85 | num = halo%num(i) |
---|
86 | ireq = ireq+1 |
---|
87 | call MPI_ISEND(buf(1,istart), llbuf*num, MPI_REAL8, halo%rank(i), & |
---|
88 | 42, MPI_COMM_WORLD, req(ireq), ierr) |
---|
89 | istart = istart+num |
---|
90 | END DO |
---|
91 | !$OMP END MASTER |
---|
92 | halo => recv_info(index) |
---|
93 | buf => halo%buf2 |
---|
94 | llbuf = SIZE(buf,1) |
---|
95 | !$OMP MASTER |
---|
96 | istart=1 |
---|
97 | DO i = 1,halo%ranks |
---|
98 | num = halo%num(i) |
---|
99 | ireq = ireq+1 |
---|
100 | call MPI_IRECV(buf(1,istart), llbuf*num, MPI_REAL8, halo%rank(i), & |
---|
101 | 42, MPI_COMM_WORLD, req(ireq), ierr) |
---|
102 | istart = istart+num |
---|
103 | END DO |
---|
104 | CALL MPI_WAITALL(ireq, req, status, ierr) |
---|
105 | !$OMP END MASTER |
---|
106 | !$OMP BARRIER |
---|
107 | |
---|
108 | CALL copy_out(SIZE(data,1), SIZE(data,2), SIZE(buf,1), SIZE(buf,2), halo%cells, data, buf) |
---|
109 | END SUBROUTINE update_halo |
---|
110 | |
---|
111 | SUBROUTINE update_halo_c(index, lldata, ndata, data) BIND(C, name='dynamico_update_halo') |
---|
112 | INTEGER, VALUE :: index, lldata, ndata |
---|
113 | REAL(C_DOUBLE) :: data(lldata, ndata) |
---|
114 | CALL update_halo(index, data) |
---|
115 | END SUBROUTINE update_halo_c |
---|
116 | |
---|
117 | END MODULE transfer_unstructured_mod |
---|