DISPATCH
mpi_buffer_mod.f90
1 !===============================================================================
2 !===============================================================================
3 MODULE mpi_buffer_mod
4  !USE trace_mod
5  implicit none
6  private
7  type, public:: mpi_buffer_t
8  integer:: n
9  integer, allocatable:: buffer(:)
10  integer(8):: position
11  contains
12  procedure:: init
13  procedure:: reset
14  procedure, private:: append_c
15  procedure, private:: append_0
16  procedure, private:: append_1
17  procedure, private:: append_2
18  procedure, private:: append_3
19  generic, public:: append => append_c, append_1, append_2, append_3
20  procedure, private:: read_c
21  procedure, private:: read_0
22  procedure, private:: read_1
23  procedure, private:: read_2
24  procedure, private:: read_3
25  generic, public:: read => read_c, read_1, read_2, read_3
26  end type
27 CONTAINS
28 
29 !===============================================================================
30 !===============================================================================
31 SUBROUTINE init (self, n, label)
32  class(mpi_buffer_t):: self
33  integer:: n
34  character(len=*):: label
35  !-----------------------------------------------------------------------------
36  !call trace%begin ('mpi_buffer_t%init')
37  allocate (self%buffer(n))
38  self%position = 1
39  call self%append (label)
40  !call trace%end
41 END SUBROUTINE init
42 
43 !===============================================================================
44 !===============================================================================
45 SUBROUTINE reset (self)
46  class(mpi_buffer_t):: self
47  !-----------------------------------------------------------------------------
48  !call trace%begin ('mpi_buffer_t%reset')
49  self%position = 1
50  !call trace%end
51 END SUBROUTINE reset
52 
53 !===============================================================================
54 !===============================================================================
55 SUBROUTINE append_c (self, label)
56  class(mpi_buffer_t):: self
57  character(len=*):: label
58  character, allocatable:: text(:)
59  integer:: ni, nb
60  !-----------------------------------------------------------------------------
61  !call trace%begin ('mpi_buffer_t%append_c')
62  nb = len(label)
63  ni = 1 + (nb-1)/4
64  nb = ni*4
65  allocate (text(nb))
66  text = label
67  self%buffer(self%position) = ni
68  self%position = self%position + 1
69  call mpi_buffer_copy (text, ni, self%buffer, self%position)
70  self%position = self%position + ni
71  deallocate (text)
72  !call trace%end
73 END SUBROUTINE append_c
74 
75 !===============================================================================
76 !===============================================================================
77 SUBROUTINE append_0 (self, a)
78  class(mpi_buffer_t):: self
79  real:: a
80  integer:: na
81  !-----------------------------------------------------------------------------
82  !call trace%begin ('mpi_buffer_t%append_c')
83  self%buffer(self%position) = 1
84  self%position = self%position + 1
85  call mpi_buffer_copy (a, 1, 1, self%buffer, self%position)
86  self%position = self%position + 1
87  !call trace%end
88 END SUBROUTINE append_0
89 
90 !===============================================================================
91 !===============================================================================
92 SUBROUTINE append_1 (self, a)
93  class(mpi_buffer_t):: self
94  real:: a(:)
95  integer:: na
96  !-----------------------------------------------------------------------------
97  !call trace%begin ('mpi_buffer_t%append_c')
98  na = product(shape(a))
99  self%buffer(self%position) = na
100  self%position = self%position + 1
101  call mpi_buffer_copy (a, 1, 1, self%buffer, self%position)
102  self%position = self%position + na
103  !call trace%end
104 END SUBROUTINE append_1
105 
106 !===============================================================================
107 !===============================================================================
108 SUBROUTINE append_2 (self, a)
109  class(mpi_buffer_t):: self
110  real:: a(:,:)
111  integer:: na
112  !-----------------------------------------------------------------------------
113  !call trace%begin ('mpi_buffer_t%append_c')
114  na = product(shape(a))
115  self%buffer(self%position) = na
116  self%position = self%position + 1
117  call mpi_buffer_copy (a, 1, na, self%buffer, self%position)
118  self%position = self%position + na
119  !call trace%end
120 END SUBROUTINE append_2
121 
122 !===============================================================================
123 !===============================================================================
124 SUBROUTINE append_3 (self, a)
125  class(mpi_buffer_t):: self
126  real:: a(:,:,:)
127  integer:: na
128  !-----------------------------------------------------------------------------
129  !call trace%begin ('mpi_buffer_t%append_c')
130  na = product(shape(a))
131  self%buffer(self%position) = na
132  self%position = self%position + 1
133  call mpi_buffer_copy (a, 1, na, self%buffer, self%position)
134  self%position = self%position + na
135  !call trace%end
136 END SUBROUTINE append_3
137 
138 !===============================================================================
139 !===============================================================================
140 SUBROUTINE read_c (self, label)
141  class(mpi_buffer_t):: self
142  character(len=*):: label
143  integer:: ni, nb
144  !-----------------------------------------------------------------------------
145  !call trace%begin ('mpi_buffer_t%read_c')
146  nb = len(label)
147  ni = 1 + (nb-1)/4
148  nb = ni*4
149  !allocate (a(nb))
150  self%position = self%position + 1
151  !call mpi_buffer_copy (self%buffer, self%position, a, 1, ni)
152  self%position = self%position + ni
153  !deallocate (a)
154  !call trace%end
155 END SUBROUTINE read_c
156 
157 !===============================================================================
158 !===============================================================================
159 SUBROUTINE read_0 (self, a)
160  class(mpi_buffer_t):: self
161  real:: a
162  integer:: na
163  !-----------------------------------------------------------------------------
164  !call trace%begin ('mpi_buffer_t%read_c')
165  self%position = self%position + 1
166  call mpi_buffer_copy (self%buffer, self%position, a, 1, 1)
167  self%position = self%position + 1
168  !call trace%end
169 END SUBROUTINE read_0
170 
171 !===============================================================================
172 !===============================================================================
173 SUBROUTINE read_1 (self, a)
174  class(mpi_buffer_t):: self
175  real:: a(:)
176  integer:: na
177  !-----------------------------------------------------------------------------
178  !call trace%begin ('mpi_buffer_t%read_c')
179  na = product(shape(a))
180  self%position = self%position + 1
181  call mpi_buffer_copy (self%buffer, self%position, a, 1, na)
182  self%position = self%position + na
183  !call trace%end
184 END SUBROUTINE read_1
185 
186 !===============================================================================
187 !===============================================================================
188 SUBROUTINE read_2 (self, a)
189  class(mpi_buffer_t):: self
190  real:: a(:,:)
191  integer:: na
192  !-----------------------------------------------------------------------------
193  !call trace%begin ('mpi_buffer_t%read_c')
194  na = product(shape(a))
195  self%buffer(self%position) = na
196  self%position = self%position + 1
197  call mpi_buffer_copy (self%buffer, self%position, a, 1, na)
198  self%position = self%position + na
199  !call trace%end
200 END SUBROUTINE read_2
201 
202 !===============================================================================
203 !===============================================================================
204 SUBROUTINE read_3 (self, a)
205  class(mpi_buffer_t):: self
206  real:: a(:,:,:)
207  integer:: na
208  !-----------------------------------------------------------------------------
209  !call trace%begin ('mpi_buffer_t%read_c')
210  na = product(shape(a))
211  self%position = self%position + 1
212  call mpi_buffer_copy (self%buffer, self%position, a, 1, na)
213  self%position = self%position + na
214  !call trace%end
215 END SUBROUTINE read_3
216 
217 END MODULE mpi_buffer_mod
218 
219 !===============================================================================
220 !> Copy n words from a to b, starting at position o
221 !===============================================================================
222 SUBROUTINE mpi_buffer_copy (a, n, b, o)
223  integer:: a(:), n, b(:), o
224  !-----------------------------------------------------------------------------
225  b(o:o+n-1) = a(1:n)
226 END SUBROUTINE mpi_buffer_copy