Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Swarm-message, a convenient data-container for with build-in serialization.
10 : !> \author Ole Schuett
11 : ! **************************************************************************************************
12 : MODULE swarm_message
13 :
14 : USE cp_parser_methods, ONLY: parser_get_next_line
15 : USE cp_parser_types, ONLY: cp_parser_type
16 : USE kinds, ONLY: default_string_length, &
17 : dp, &
18 : int_4, &
19 : int_8, &
20 : real_4, &
21 : real_8
22 : USE message_passing, ONLY: mp_comm_type
23 : #include "../base/base_uses.f90"
24 :
25 : IMPLICIT NONE
26 : PRIVATE
27 :
28 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'swarm_message'
29 :
30 : TYPE swarm_message_type
31 : PRIVATE
32 : TYPE(message_entry_type), POINTER :: root => Null()
33 : END TYPE swarm_message_type
34 :
35 : INTEGER, PARAMETER :: key_length = 20
36 :
37 : TYPE message_entry_type
38 : CHARACTER(LEN=key_length) :: key = ""
39 : TYPE(message_entry_type), POINTER :: next => Null()
40 : CHARACTER(LEN=default_string_length), POINTER :: value_str => Null()
41 : INTEGER(KIND=int_4), POINTER :: value_i4 => Null()
42 : INTEGER(KIND=int_8), POINTER :: value_i8 => Null()
43 : REAL(KIND=real_4), POINTER :: value_r4 => Null()
44 : REAL(KIND=real_8), POINTER :: value_r8 => Null()
45 : INTEGER(KIND=int_4), DIMENSION(:), POINTER :: value_1d_i4 => Null()
46 : INTEGER(KIND=int_8), DIMENSION(:), POINTER :: value_1d_i8 => Null()
47 : REAL(KIND=real_4), DIMENSION(:), POINTER :: value_1d_r4 => Null()
48 : REAL(KIND=real_8), DIMENSION(:), POINTER :: value_1d_r8 => Null()
49 : END TYPE message_entry_type
50 :
51 : ! **************************************************************************************************
52 : !> \brief Adds an entry from a swarm-message.
53 : !> \author Ole Schuett
54 : ! **************************************************************************************************
55 : INTERFACE swarm_message_add
56 : MODULE PROCEDURE swarm_message_add_str
57 : MODULE PROCEDURE swarm_message_add_i4, swarm_message_add_i8
58 : MODULE PROCEDURE swarm_message_add_r4, swarm_message_add_r8
59 : MODULE PROCEDURE swarm_message_add_1d_i4, swarm_message_add_1d_i8
60 : MODULE PROCEDURE swarm_message_add_1d_r4, swarm_message_add_1d_r8
61 : END INTERFACE swarm_message_add
62 :
63 : ! **************************************************************************************************
64 : !> \brief Returns an entry from a swarm-message.
65 : !> \author Ole Schuett
66 : ! **************************************************************************************************
67 : INTERFACE swarm_message_get
68 : MODULE PROCEDURE swarm_message_get_str
69 : MODULE PROCEDURE swarm_message_get_i4, swarm_message_get_i8
70 : MODULE PROCEDURE swarm_message_get_r4, swarm_message_get_r8
71 : MODULE PROCEDURE swarm_message_get_1d_i4, swarm_message_get_1d_i8
72 : MODULE PROCEDURE swarm_message_get_1d_r4, swarm_message_get_1d_r8
73 : END INTERFACE swarm_message_get
74 :
75 : PUBLIC :: swarm_message_type, swarm_message_add, swarm_message_get
76 : PUBLIC :: swarm_message_mpi_send, swarm_message_mpi_recv, swarm_message_mpi_bcast
77 : PUBLIC :: swarm_message_file_write, swarm_message_file_read
78 : PUBLIC :: swarm_message_haskey, swarm_message_equal
79 : PUBLIC :: swarm_message_free
80 :
81 : CONTAINS
82 :
83 : ! **************************************************************************************************
84 : !> \brief Returns the number of entries contained in a swarm-message.
85 : !> \param msg ...
86 : !> \return ...
87 : !> \author Ole Schuett
88 : ! **************************************************************************************************
89 162 : FUNCTION swarm_message_length(msg) RESULT(l)
90 : TYPE(swarm_message_type), INTENT(IN) :: msg
91 : INTEGER :: l
92 :
93 : TYPE(message_entry_type), POINTER :: curr_entry
94 :
95 162 : l = 0
96 162 : curr_entry => msg%root
97 547 : DO WHILE (ASSOCIATED(curr_entry))
98 385 : l = l + 1
99 385 : curr_entry => curr_entry%next
100 : END DO
101 162 : END FUNCTION swarm_message_length
102 :
103 : ! **************************************************************************************************
104 : !> \brief Checks if a swarm-message contains an entry with the given key.
105 : !> \param msg ...
106 : !> \param key ...
107 : !> \return ...
108 : !> \author Ole Schuett
109 : ! **************************************************************************************************
110 215 : FUNCTION swarm_message_haskey(msg, key) RESULT(res)
111 : TYPE(swarm_message_type), INTENT(IN) :: msg
112 : CHARACTER(LEN=*), INTENT(IN) :: key
113 : LOGICAL :: res
114 :
115 : TYPE(message_entry_type), POINTER :: curr_entry
116 :
117 215 : res = .FALSE.
118 215 : curr_entry => msg%root
119 748 : DO WHILE (ASSOCIATED(curr_entry))
120 533 : IF (TRIM(curr_entry%key) == TRIM(key)) THEN
121 : res = .TRUE.
122 : EXIT
123 : END IF
124 533 : curr_entry => curr_entry%next
125 : END DO
126 215 : END FUNCTION swarm_message_haskey
127 :
128 : ! **************************************************************************************************
129 : !> \brief Deallocates all entries contained in a swarm-message.
130 : !> \param msg ...
131 : !> \author Ole Schuett
132 : ! **************************************************************************************************
133 86 : SUBROUTINE swarm_message_free(msg)
134 : TYPE(swarm_message_type), INTENT(INOUT) :: msg
135 :
136 : TYPE(message_entry_type), POINTER :: ENTRY, old_entry
137 :
138 86 : ENTRY => msg%root
139 502 : DO WHILE (ASSOCIATED(ENTRY))
140 416 : IF (ASSOCIATED(entry%value_str)) DEALLOCATE (entry%value_str)
141 416 : IF (ASSOCIATED(entry%value_i4)) DEALLOCATE (entry%value_i4)
142 416 : IF (ASSOCIATED(entry%value_i8)) DEALLOCATE (entry%value_i8)
143 416 : IF (ASSOCIATED(entry%value_r4)) DEALLOCATE (entry%value_r4)
144 416 : IF (ASSOCIATED(entry%value_r8)) DEALLOCATE (entry%value_r8)
145 416 : IF (ASSOCIATED(entry%value_1d_i4)) DEALLOCATE (entry%value_1d_i4)
146 416 : IF (ASSOCIATED(entry%value_1d_i8)) DEALLOCATE (entry%value_1d_i8)
147 416 : IF (ASSOCIATED(entry%value_1d_r4)) DEALLOCATE (entry%value_1d_r4)
148 416 : IF (ASSOCIATED(entry%value_1d_r8)) DEALLOCATE (entry%value_1d_r8)
149 416 : old_entry => ENTRY
150 416 : ENTRY => entry%next
151 502 : DEALLOCATE (old_entry)
152 : END DO
153 :
154 86 : NULLIFY (msg%root)
155 :
156 86 : CPASSERT(swarm_message_length(msg) == 0)
157 86 : END SUBROUTINE swarm_message_free
158 :
159 : ! **************************************************************************************************
160 : !> \brief Checks if two swarm-messages are equal
161 : !> \param msg1 ...
162 : !> \param msg2 ...
163 : !> \return ...
164 : !> \author Ole Schuett
165 : ! **************************************************************************************************
166 4 : FUNCTION swarm_message_equal(msg1, msg2) RESULT(res)
167 : TYPE(swarm_message_type), INTENT(IN) :: msg1, msg2
168 : LOGICAL :: res
169 :
170 : res = swarm_message_equal_oneway(msg1, msg2) .AND. &
171 4 : swarm_message_equal_oneway(msg2, msg1)
172 :
173 4 : END FUNCTION swarm_message_equal
174 :
175 : ! **************************************************************************************************
176 : !> \brief Sends a swarm message via MPI.
177 : !> \param msg ...
178 : !> \param group ...
179 : !> \param dest ...
180 : !> \param tag ...
181 : !> \author Ole Schuett
182 : ! **************************************************************************************************
183 32 : SUBROUTINE swarm_message_mpi_send(msg, group, dest, tag)
184 : TYPE(swarm_message_type), INTENT(IN) :: msg
185 : CLASS(mp_comm_type), INTENT(IN) :: group
186 : INTEGER, INTENT(IN) :: dest, tag
187 :
188 : TYPE(message_entry_type), POINTER :: curr_entry
189 :
190 32 : CALL group%send(swarm_message_length(msg), dest, tag)
191 32 : curr_entry => msg%root
192 198 : DO WHILE (ASSOCIATED(curr_entry))
193 166 : CALL swarm_message_entry_mpi_send(curr_entry, group, dest, tag)
194 166 : curr_entry => curr_entry%next
195 : END DO
196 32 : END SUBROUTINE swarm_message_mpi_send
197 :
198 : ! **************************************************************************************************
199 : !> \brief Receives a swarm message via MPI.
200 : !> \param msg ...
201 : !> \param group ...
202 : !> \param src ...
203 : !> \param tag ...
204 : !> \author Ole Schuett
205 : ! **************************************************************************************************
206 32 : SUBROUTINE swarm_message_mpi_recv(msg, group, src, tag)
207 : TYPE(swarm_message_type), INTENT(INOUT) :: msg
208 : CLASS(mp_comm_type), INTENT(IN) :: group
209 : INTEGER, INTENT(INOUT) :: src, tag
210 :
211 : INTEGER :: i, length
212 : TYPE(message_entry_type), POINTER :: new_entry
213 :
214 32 : IF (ASSOCIATED(msg%root)) CPABORT("message not empty")
215 32 : CALL group%recv(length, src, tag)
216 198 : DO i = 1, length
217 166 : ALLOCATE (new_entry)
218 166 : CALL swarm_message_entry_mpi_recv(new_entry, group, src, tag)
219 166 : new_entry%next => msg%root
220 198 : msg%root => new_entry
221 : END DO
222 :
223 32 : END SUBROUTINE swarm_message_mpi_recv
224 :
225 : ! **************************************************************************************************
226 : !> \brief Broadcasts a swarm message via MPI.
227 : !> \param msg ...
228 : !> \param src ...
229 : !> \param group ...
230 : !> \author Ole Schuett
231 : ! **************************************************************************************************
232 16 : SUBROUTINE swarm_message_mpi_bcast(msg, src, group)
233 : TYPE(swarm_message_type), INTENT(INOUT) :: msg
234 : INTEGER, INTENT(IN) :: src
235 : CLASS(mp_comm_type), INTENT(IN) :: group
236 :
237 : INTEGER :: i, length
238 : TYPE(message_entry_type), POINTER :: curr_entry
239 :
240 : ASSOCIATE (mepos => group%mepos)
241 :
242 0 : IF (mepos /= src .AND. ASSOCIATED(msg%root)) CPABORT("message not empty")
243 16 : length = swarm_message_length(msg)
244 16 : CALL group%bcast(length, src)
245 :
246 16 : IF (mepos == src) curr_entry => msg%root
247 :
248 101 : DO i = 1, length
249 69 : IF (mepos /= src) ALLOCATE (curr_entry)
250 :
251 69 : CALL swarm_message_entry_mpi_bcast(curr_entry, src, group, mepos)
252 :
253 85 : IF (mepos == src) THEN
254 69 : curr_entry => curr_entry%next
255 : ELSE
256 0 : curr_entry%next => msg%root
257 0 : msg%root => curr_entry
258 : END IF
259 : END DO
260 : END ASSOCIATE
261 :
262 16 : END SUBROUTINE swarm_message_mpi_bcast
263 :
264 : ! **************************************************************************************************
265 : !> \brief Write a swarm-message to a given file / unit.
266 : !> \param msg ...
267 : !> \param unit ...
268 : !> \author Ole Schuett
269 : ! **************************************************************************************************
270 68 : SUBROUTINE swarm_message_file_write(msg, unit)
271 : TYPE(swarm_message_type), INTENT(IN) :: msg
272 : INTEGER, INTENT(IN) :: unit
273 :
274 : INTEGER :: handle
275 : TYPE(message_entry_type), POINTER :: curr_entry
276 :
277 40 : IF (unit <= 0) RETURN
278 :
279 28 : CALL timeset("swarm_message_file_write", handle)
280 28 : WRITE (unit, "(A)") "BEGIN SWARM_MESSAGE"
281 28 : WRITE (unit, "(A,I10)") "msg_length: ", swarm_message_length(msg)
282 :
283 28 : curr_entry => msg%root
284 178 : DO WHILE (ASSOCIATED(curr_entry))
285 150 : CALL swarm_message_entry_file_write(curr_entry, unit)
286 150 : curr_entry => curr_entry%next
287 : END DO
288 :
289 28 : WRITE (unit, "(A)") "END SWARM_MESSAGE"
290 28 : WRITE (unit, "()")
291 28 : CALL timestop(handle)
292 : END SUBROUTINE swarm_message_file_write
293 :
294 : ! **************************************************************************************************
295 : !> \brief Reads a swarm-message from a given file / unit.
296 : !> \param msg ...
297 : !> \param parser ...
298 : !> \param at_end ...
299 : !> \author Ole Schuett
300 : ! **************************************************************************************************
301 22 : SUBROUTINE swarm_message_file_read(msg, parser, at_end)
302 : TYPE(swarm_message_type), INTENT(OUT) :: msg
303 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
304 : LOGICAL, INTENT(INOUT) :: at_end
305 :
306 : INTEGER :: handle
307 :
308 11 : CALL timeset("swarm_message_file_read", handle)
309 11 : CALL swarm_message_file_read_low(msg, parser, at_end)
310 11 : CALL timestop(handle)
311 11 : END SUBROUTINE swarm_message_file_read
312 :
313 : ! **************************************************************************************************
314 : !> \brief Helper routine, does the actual work of swarm_message_file_read().
315 : !> \param msg ...
316 : !> \param parser ...
317 : !> \param at_end ...
318 : !> \author Ole Schuett
319 : ! **************************************************************************************************
320 11 : SUBROUTINE swarm_message_file_read_low(msg, parser, at_end)
321 : TYPE(swarm_message_type), INTENT(OUT) :: msg
322 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
323 : LOGICAL, INTENT(INOUT) :: at_end
324 :
325 : CHARACTER(LEN=20) :: label
326 : INTEGER :: i, length
327 : TYPE(message_entry_type), POINTER :: new_entry
328 :
329 11 : CALL parser_get_next_line(parser, 1, at_end)
330 11 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
331 11 : IF (at_end) RETURN
332 10 : CPASSERT(TRIM(parser%input_line(1:20)) == "BEGIN SWARM_MESSAGE")
333 :
334 10 : CALL parser_get_next_line(parser, 1, at_end)
335 10 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
336 10 : IF (at_end) RETURN
337 10 : READ (parser%input_line(1:40), *) label, length
338 10 : CPASSERT(TRIM(label) == "msg_length:")
339 :
340 61 : DO i = 1, length
341 51 : ALLOCATE (new_entry)
342 51 : CALL swarm_message_entry_file_read(new_entry, parser, at_end)
343 51 : new_entry%next => msg%root
344 61 : msg%root => new_entry
345 : END DO
346 :
347 10 : CALL parser_get_next_line(parser, 1, at_end)
348 10 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
349 10 : IF (at_end) RETURN
350 10 : CPASSERT(TRIM(parser%input_line(1:20)) == "END SWARM_MESSAGE")
351 :
352 : END SUBROUTINE swarm_message_file_read_low
353 :
354 : ! **************************************************************************************************
355 : !> \brief Helper routine for swarm_message_equal
356 : !> \param msg1 ...
357 : !> \param msg2 ...
358 : !> \return ...
359 : !> \author Ole Schuett
360 : ! **************************************************************************************************
361 8 : FUNCTION swarm_message_equal_oneway(msg1, msg2) RESULT(res)
362 : TYPE(swarm_message_type), INTENT(IN) :: msg1, msg2
363 : LOGICAL :: res
364 :
365 : REAL(KIND=dp), PARAMETER :: eps_r4 = 1.0E-05_dp, &
366 : eps_r8 = 1.0E-10_dp
367 :
368 : LOGICAL :: found
369 : TYPE(message_entry_type), POINTER :: entry1, entry2
370 :
371 8 : res = .FALSE.
372 :
373 : !loop over entries of msg1
374 8 : entry1 => msg1%root
375 46 : DO WHILE (ASSOCIATED(entry1))
376 :
377 : ! finding matching entry in msg2
378 38 : entry2 => msg2%root
379 38 : found = .FALSE.
380 110 : DO WHILE (ASSOCIATED(entry2))
381 110 : IF (TRIM(entry2%key) == TRIM(entry1%key)) THEN
382 : found = .TRUE.
383 : EXIT
384 : END IF
385 72 : entry2 => entry2%next
386 : END DO
387 38 : IF (.NOT. found) RETURN
388 :
389 : !compare the two entries
390 38 : IF (ASSOCIATED(entry1%value_str)) THEN
391 8 : IF (.NOT. ASSOCIATED(entry2%value_str)) RETURN
392 8 : IF (TRIM(entry1%value_str) /= TRIM(entry2%value_str)) RETURN
393 :
394 30 : ELSE IF (ASSOCIATED(entry1%value_i4)) THEN
395 16 : IF (.NOT. ASSOCIATED(entry2%value_i4)) RETURN
396 16 : IF (entry1%value_i4 /= entry2%value_i4) RETURN
397 :
398 14 : ELSE IF (ASSOCIATED(entry1%value_i8)) THEN
399 0 : IF (.NOT. ASSOCIATED(entry2%value_i8)) RETURN
400 0 : IF (entry1%value_i8 /= entry2%value_i8) RETURN
401 :
402 14 : ELSE IF (ASSOCIATED(entry1%value_r4)) THEN
403 0 : IF (.NOT. ASSOCIATED(entry2%value_r4)) RETURN
404 0 : IF (ABS(entry1%value_r4 - entry2%value_r4) > eps_r4) RETURN
405 :
406 14 : ELSE IF (ASSOCIATED(entry1%value_r8)) THEN
407 8 : IF (.NOT. ASSOCIATED(entry2%value_r8)) RETURN
408 8 : IF (ABS(entry1%value_r8 - entry2%value_r8) > eps_r8) RETURN
409 :
410 6 : ELSE IF (ASSOCIATED(entry1%value_1d_i4)) THEN
411 0 : IF (.NOT. ASSOCIATED(entry2%value_1d_i4)) RETURN
412 0 : IF (ANY(entry1%value_1d_i4 /= entry2%value_1d_i4)) RETURN
413 :
414 6 : ELSE IF (ASSOCIATED(entry1%value_1d_i8)) THEN
415 0 : IF (.NOT. ASSOCIATED(entry2%value_1d_i8)) RETURN
416 0 : IF (ANY(entry1%value_1d_i8 /= entry2%value_1d_i8)) RETURN
417 :
418 6 : ELSE IF (ASSOCIATED(entry1%value_1d_r4)) THEN
419 0 : IF (.NOT. ASSOCIATED(entry2%value_1d_r4)) RETURN
420 0 : IF (ANY(ABS(entry1%value_1d_r4 - entry2%value_1d_r4) > eps_r4)) RETURN
421 :
422 6 : ELSE IF (ASSOCIATED(entry1%value_1d_r8)) THEN
423 6 : IF (.NOT. ASSOCIATED(entry2%value_1d_r8)) RETURN
424 186 : IF (ANY(ABS(entry1%value_1d_r8 - entry2%value_1d_r8) > eps_r8)) RETURN
425 : ELSE
426 0 : CPABORT("no value ASSOCIATED")
427 : END IF
428 :
429 38 : entry1 => entry1%next
430 : END DO
431 :
432 : ! if we reach this point no differences were found
433 8 : res = .TRUE.
434 : END FUNCTION swarm_message_equal_oneway
435 :
436 : ! **************************************************************************************************
437 : !> \brief Helper routine for swarm_message_mpi_send.
438 : !> \param ENTRY ...
439 : !> \param group ...
440 : !> \param dest ...
441 : !> \param tag ...
442 : !> \author Ole Schuett
443 : ! **************************************************************************************************
444 166 : SUBROUTINE swarm_message_entry_mpi_send(ENTRY, group, dest, tag)
445 : TYPE(message_entry_type), INTENT(IN) :: ENTRY
446 : CLASS(mp_comm_type), INTENT(IN) :: group
447 : INTEGER, INTENT(IN) :: dest, tag
448 :
449 : INTEGER, DIMENSION(default_string_length) :: value_str_arr
450 : INTEGER, DIMENSION(key_length) :: key_arr
451 :
452 166 : key_arr = str2iarr(entry%key)
453 166 : CALL group%send(key_arr, dest, tag)
454 :
455 166 : IF (ASSOCIATED(entry%value_i4)) THEN
456 84 : CALL group%send(1, dest, tag)
457 84 : CALL group%send(entry%value_i4, dest, tag)
458 :
459 82 : ELSE IF (ASSOCIATED(entry%value_i8)) THEN
460 0 : CALL group%send(2, dest, tag)
461 0 : CALL group%send(entry%value_i8, dest, tag)
462 :
463 82 : ELSE IF (ASSOCIATED(entry%value_r4)) THEN
464 0 : CALL group%send(3, dest, tag)
465 0 : CALL group%send(entry%value_r4, dest, tag)
466 :
467 82 : ELSE IF (ASSOCIATED(entry%value_r8)) THEN
468 26 : CALL group%send(4, dest, tag)
469 26 : CALL group%send(entry%value_r8, dest, tag)
470 :
471 56 : ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
472 0 : CALL group%send(5, dest, tag)
473 0 : CALL group%send(SIZE(entry%value_1d_i4), dest, tag)
474 0 : CALL group%send(entry%value_1d_i4, dest, tag)
475 :
476 56 : ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
477 0 : CALL group%send(6, dest, tag)
478 0 : CALL group%send(SIZE(entry%value_1d_i8), dest, tag)
479 0 : CALL group%send(entry%value_1d_i8, dest, tag)
480 :
481 56 : ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
482 0 : CALL group%send(7, dest, tag)
483 0 : CALL group%send(SIZE(entry%value_1d_r4), dest, tag)
484 0 : CALL group%send(entry%value_1d_r4, dest, tag)
485 :
486 56 : ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
487 24 : CALL group%send(8, dest, tag)
488 24 : CALL group%send(SIZE(entry%value_1d_r8), dest, tag)
489 744 : CALL group%send(entry%value_1d_r8, dest, tag)
490 :
491 32 : ELSE IF (ASSOCIATED(entry%value_str)) THEN
492 32 : CALL group%send(9, dest, tag)
493 32 : value_str_arr = str2iarr(entry%value_str)
494 32 : CALL group%send(value_str_arr, dest, tag)
495 : ELSE
496 0 : CPABORT("no value ASSOCIATED")
497 : END IF
498 166 : END SUBROUTINE swarm_message_entry_mpi_send
499 :
500 : ! **************************************************************************************************
501 : !> \brief Helper routine for swarm_message_mpi_recv.
502 : !> \param ENTRY ...
503 : !> \param group ...
504 : !> \param src ...
505 : !> \param tag ...
506 : !> \author Ole Schuett
507 : ! **************************************************************************************************
508 166 : SUBROUTINE swarm_message_entry_mpi_recv(ENTRY, group, src, tag)
509 : TYPE(message_entry_type), INTENT(INOUT) :: ENTRY
510 : CLASS(mp_comm_type), INTENT(IN) :: group
511 : INTEGER, INTENT(INOUT) :: src, tag
512 :
513 : INTEGER :: datatype, s
514 : INTEGER, DIMENSION(default_string_length) :: value_str_arr
515 : INTEGER, DIMENSION(key_length) :: key_arr
516 :
517 166 : CALL group%recv(key_arr, src, tag)
518 166 : entry%key = iarr2str(key_arr)
519 :
520 166 : CALL group%recv(datatype, src, tag)
521 :
522 84 : SELECT CASE (datatype)
523 : CASE (1)
524 84 : ALLOCATE (entry%value_i4)
525 84 : CALL group%recv(entry%value_i4, src, tag)
526 : CASE (2)
527 0 : ALLOCATE (entry%value_i8)
528 0 : CALL group%recv(entry%value_i8, src, tag)
529 : CASE (3)
530 0 : ALLOCATE (entry%value_r4)
531 0 : CALL group%recv(entry%value_r4, src, tag)
532 : CASE (4)
533 26 : ALLOCATE (entry%value_r8)
534 26 : CALL group%recv(entry%value_r8, src, tag)
535 : CASE (5)
536 0 : CALL group%recv(s, src, tag)
537 0 : ALLOCATE (entry%value_1d_i4(s))
538 0 : CALL group%recv(entry%value_1d_i4, src, tag)
539 : CASE (6)
540 0 : CALL group%recv(s, src, tag)
541 0 : ALLOCATE (entry%value_1d_i8(s))
542 0 : CALL group%recv(entry%value_1d_i8, src, tag)
543 : CASE (7)
544 0 : CALL group%recv(s, src, tag)
545 0 : ALLOCATE (entry%value_1d_r4(s))
546 0 : CALL group%recv(entry%value_1d_r4, src, tag)
547 : CASE (8)
548 24 : CALL group%recv(s, src, tag)
549 72 : ALLOCATE (entry%value_1d_r8(s))
550 1464 : CALL group%recv(entry%value_1d_r8, src, tag)
551 : CASE (9)
552 32 : ALLOCATE (entry%value_str)
553 32 : CALL group%recv(value_str_arr, src, tag)
554 32 : entry%value_str = iarr2str(value_str_arr)
555 : CASE DEFAULT
556 166 : CPABORT("unknown datatype")
557 : END SELECT
558 166 : END SUBROUTINE swarm_message_entry_mpi_recv
559 :
560 : ! **************************************************************************************************
561 : !> \brief Helper routine for swarm_message_mpi_bcast.
562 : !> \param ENTRY ...
563 : !> \param src ...
564 : !> \param group ...
565 : !> \param mepos ...
566 : !> \author Ole Schuett
567 : ! **************************************************************************************************
568 69 : SUBROUTINE swarm_message_entry_mpi_bcast(ENTRY, src, group, mepos)
569 : TYPE(message_entry_type), INTENT(INOUT) :: ENTRY
570 : INTEGER, INTENT(IN) :: src, mepos
571 : CLASS(mp_comm_type), INTENT(IN) :: group
572 :
573 : INTEGER :: datasize, datatype
574 : INTEGER, DIMENSION(default_string_length) :: value_str_arr
575 : INTEGER, DIMENSION(key_length) :: key_arr
576 :
577 69 : IF (src == mepos) key_arr = str2iarr(entry%key)
578 69 : CALL group%bcast(key_arr, src)
579 69 : IF (src /= mepos) entry%key = iarr2str(key_arr)
580 :
581 69 : IF (src == mepos) THEN
582 69 : datasize = 1
583 69 : IF (ASSOCIATED(entry%value_i4)) THEN
584 29 : datatype = 1
585 40 : ELSE IF (ASSOCIATED(entry%value_i8)) THEN
586 0 : datatype = 2
587 40 : ELSE IF (ASSOCIATED(entry%value_r4)) THEN
588 0 : datatype = 3
589 40 : ELSE IF (ASSOCIATED(entry%value_r8)) THEN
590 13 : datatype = 4
591 27 : ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
592 0 : datatype = 5
593 0 : datasize = SIZE(entry%value_1d_i4)
594 27 : ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
595 0 : datatype = 6
596 0 : datasize = SIZE(entry%value_1d_i8)
597 27 : ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
598 0 : datatype = 7
599 0 : datasize = SIZE(entry%value_1d_r4)
600 27 : ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
601 11 : datatype = 8
602 11 : datasize = SIZE(entry%value_1d_r8)
603 16 : ELSE IF (ASSOCIATED(entry%value_str)) THEN
604 16 : datatype = 9
605 : ELSE
606 0 : CPABORT("no value ASSOCIATED")
607 : END IF
608 : END IF
609 69 : CALL group%bcast(datatype, src)
610 69 : CALL group%bcast(datasize, src)
611 :
612 29 : SELECT CASE (datatype)
613 : CASE (1)
614 29 : IF (src /= mepos) ALLOCATE (entry%value_i4)
615 29 : CALL group%bcast(entry%value_i4, src)
616 : CASE (2)
617 0 : IF (src /= mepos) ALLOCATE (entry%value_i8)
618 0 : CALL group%bcast(entry%value_i8, src)
619 : CASE (3)
620 0 : IF (src /= mepos) ALLOCATE (entry%value_r4)
621 0 : CALL group%bcast(entry%value_r4, src)
622 : CASE (4)
623 13 : IF (src /= mepos) ALLOCATE (entry%value_r8)
624 13 : CALL group%bcast(entry%value_r8, src)
625 : CASE (5)
626 0 : IF (src /= mepos) ALLOCATE (entry%value_1d_i4(datasize))
627 0 : CALL group%bcast(entry%value_1d_i4, src)
628 : CASE (6)
629 0 : IF (src /= mepos) ALLOCATE (entry%value_1d_i8(datasize))
630 0 : CALL group%bcast(entry%value_1d_i8, src)
631 : CASE (7)
632 0 : IF (src /= mepos) ALLOCATE (entry%value_1d_r4(datasize))
633 0 : CALL group%bcast(entry%value_1d_r4, src)
634 : CASE (8)
635 11 : IF (src /= mepos) ALLOCATE (entry%value_1d_r8(datasize))
636 671 : CALL group%bcast(entry%value_1d_r8, src)
637 : CASE (9)
638 16 : IF (src == mepos) value_str_arr = str2iarr(entry%value_str)
639 16 : CALL group%bcast(value_str_arr, src)
640 16 : IF (src /= mepos) THEN
641 0 : ALLOCATE (entry%value_str)
642 0 : entry%value_str = iarr2str(value_str_arr)
643 : END IF
644 : CASE DEFAULT
645 69 : CPABORT("unknown datatype")
646 : END SELECT
647 :
648 69 : END SUBROUTINE swarm_message_entry_mpi_bcast
649 :
650 : ! **************************************************************************************************
651 : !> \brief Helper routine for swarm_message_file_write.
652 : !> \param ENTRY ...
653 : !> \param unit ...
654 : !> \author Ole Schuett
655 : ! **************************************************************************************************
656 150 : SUBROUTINE swarm_message_entry_file_write(ENTRY, unit)
657 : TYPE(message_entry_type), INTENT(IN) :: ENTRY
658 : INTEGER, INTENT(IN) :: unit
659 :
660 : INTEGER :: i
661 :
662 150 : WRITE (unit, "(A,A)") "key: ", entry%key
663 150 : IF (ASSOCIATED(entry%value_i4)) THEN
664 76 : WRITE (unit, "(A)") "datatype: i4"
665 76 : WRITE (unit, "(A,I10)") "value: ", entry%value_i4
666 :
667 74 : ELSE IF (ASSOCIATED(entry%value_i8)) THEN
668 0 : WRITE (unit, "(A)") "datatype: i8"
669 0 : WRITE (unit, "(A,I20)") "value: ", entry%value_i8
670 :
671 74 : ELSE IF (ASSOCIATED(entry%value_r4)) THEN
672 0 : WRITE (unit, "(A)") "datatype: r4"
673 0 : WRITE (unit, "(A,E30.20)") "value: ", entry%value_r4
674 :
675 74 : ELSE IF (ASSOCIATED(entry%value_r8)) THEN
676 24 : WRITE (unit, "(A)") "datatype: r8"
677 24 : WRITE (unit, "(A,E30.20)") "value: ", entry%value_r8
678 :
679 50 : ELSE IF (ASSOCIATED(entry%value_str)) THEN
680 28 : WRITE (unit, "(A)") "datatype: str"
681 28 : WRITE (unit, "(A,A)") "value: ", entry%value_str
682 :
683 22 : ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
684 0 : WRITE (unit, "(A)") "datatype: 1d_i4"
685 0 : WRITE (unit, "(A,I10)") "size: ", SIZE(entry%value_1d_i4)
686 0 : DO i = 1, SIZE(entry%value_1d_i4)
687 0 : WRITE (unit, *) entry%value_1d_i4(i)
688 : END DO
689 :
690 22 : ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
691 0 : WRITE (unit, "(A)") "datatype: 1d_i8"
692 0 : WRITE (unit, "(A,I20)") "size: ", SIZE(entry%value_1d_i8)
693 0 : DO i = 1, SIZE(entry%value_1d_i8)
694 0 : WRITE (unit, *) entry%value_1d_i8(i)
695 : END DO
696 :
697 22 : ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
698 0 : WRITE (unit, "(A)") "datatype: 1d_r4"
699 0 : WRITE (unit, "(A,I8)") "size: ", SIZE(entry%value_1d_r4)
700 0 : DO i = 1, SIZE(entry%value_1d_r4)
701 0 : WRITE (unit, "(1X,E30.20)") entry%value_1d_r4(i)
702 : END DO
703 :
704 22 : ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
705 22 : WRITE (unit, "(A)") "datatype: 1d_r8"
706 22 : WRITE (unit, "(A,I8)") "size: ", SIZE(entry%value_1d_r8)
707 682 : DO i = 1, SIZE(entry%value_1d_r8)
708 682 : WRITE (unit, "(1X,E30.20)") entry%value_1d_r8(i)
709 : END DO
710 :
711 : ELSE
712 0 : CPABORT("no value ASSOCIATED")
713 : END IF
714 150 : END SUBROUTINE swarm_message_entry_file_write
715 :
716 : ! **************************************************************************************************
717 : !> \brief Helper routine for swarm_message_file_read.
718 : !> \param ENTRY ...
719 : !> \param parser ...
720 : !> \param at_end ...
721 : !> \author Ole Schuett
722 : ! **************************************************************************************************
723 51 : SUBROUTINE swarm_message_entry_file_read(ENTRY, parser, at_end)
724 : TYPE(message_entry_type), INTENT(INOUT) :: ENTRY
725 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
726 : LOGICAL, INTENT(INOUT) :: at_end
727 :
728 : CHARACTER(LEN=15) :: datatype, label
729 : INTEGER :: arr_size, i
730 : LOGICAL :: is_scalar
731 :
732 51 : CALL parser_get_next_line(parser, 1, at_end)
733 51 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
734 95 : IF (at_end) RETURN
735 51 : READ (parser%input_line(1:key_length + 10), *) label, entry%key
736 51 : CPASSERT(TRIM(label) == "key:")
737 :
738 51 : CALL parser_get_next_line(parser, 1, at_end)
739 51 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
740 51 : IF (at_end) RETURN
741 51 : READ (parser%input_line(1:30), *) label, datatype
742 51 : CPASSERT(TRIM(label) == "datatype:")
743 :
744 51 : CALL parser_get_next_line(parser, 1, at_end)
745 51 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
746 51 : IF (at_end) RETURN
747 :
748 51 : is_scalar = .TRUE.
749 77 : SELECT CASE (TRIM(datatype))
750 : CASE ("i4")
751 26 : ALLOCATE (entry%value_i4)
752 26 : READ (parser%input_line(1:40), *) label, entry%value_i4
753 : CASE ("i8")
754 0 : ALLOCATE (entry%value_i8)
755 0 : READ (parser%input_line(1:40), *) label, entry%value_i8
756 : CASE ("r4")
757 0 : ALLOCATE (entry%value_r4)
758 0 : READ (parser%input_line(1:40), *) label, entry%value_r4
759 : CASE ("r8")
760 8 : ALLOCATE (entry%value_r8)
761 8 : READ (parser%input_line(1:40), *) label, entry%value_r8
762 : CASE ("str")
763 10 : ALLOCATE (entry%value_str)
764 10 : READ (parser%input_line(1:40), *) label, entry%value_str
765 : CASE DEFAULT
766 51 : is_scalar = .FALSE.
767 : END SELECT
768 :
769 : IF (is_scalar) THEN
770 44 : CPASSERT(TRIM(label) == "value:")
771 44 : RETURN
772 : END IF
773 :
774 : ! musst be an array-datatype
775 7 : READ (parser%input_line(1:30), *) label, arr_size
776 7 : CPASSERT(TRIM(label) == "size:")
777 :
778 7 : SELECT CASE (TRIM(datatype))
779 : CASE ("1d_i4")
780 0 : ALLOCATE (entry%value_1d_i4(arr_size))
781 : CASE ("1d_i8")
782 0 : ALLOCATE (entry%value_1d_i8(arr_size))
783 : CASE ("1d_r4")
784 0 : ALLOCATE (entry%value_1d_r4(arr_size))
785 : CASE ("1d_r8")
786 21 : ALLOCATE (entry%value_1d_r8(arr_size))
787 : CASE DEFAULT
788 7 : CPABORT("unknown datatype")
789 : END SELECT
790 :
791 217 : DO i = 1, arr_size
792 210 : CALL parser_get_next_line(parser, 1, at_end)
793 210 : at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10)) == 0
794 210 : IF (at_end) RETURN
795 :
796 : !Numbers were written with at most 31 characters.
797 7 : SELECT CASE (TRIM(datatype))
798 : CASE ("1d_i4")
799 0 : READ (parser%input_line(1:31), *) entry%value_1d_i4(i)
800 : CASE ("1d_i8")
801 0 : READ (parser%input_line(1:31), *) entry%value_1d_i8(i)
802 : CASE ("1d_r4")
803 0 : READ (parser%input_line(1:31), *) entry%value_1d_r4(i)
804 : CASE ("1d_r8")
805 210 : READ (parser%input_line(1:31), *) entry%value_1d_r8(i)
806 : CASE DEFAULT
807 210 : CPABORT("swarm_message_entry_file_read: unknown datatype")
808 : END SELECT
809 : END DO
810 :
811 : END SUBROUTINE swarm_message_entry_file_read
812 :
813 : ! **************************************************************************************************
814 : !> \brief Helper routine, converts a string into an integer-array
815 : !> \param str ...
816 : !> \return ...
817 : !> \author Ole Schuett
818 : ! **************************************************************************************************
819 283 : PURE FUNCTION str2iarr(str) RESULT(arr)
820 : CHARACTER(LEN=*), INTENT(IN) :: str
821 : INTEGER, DIMENSION(LEN(str)) :: arr
822 :
823 : INTEGER :: i
824 :
825 8823 : DO i = 1, LEN(str)
826 8823 : arr(i) = ICHAR(str(i:i))
827 : END DO
828 283 : END FUNCTION str2iarr
829 :
830 : ! **************************************************************************************************
831 : !> \brief Helper routine, converts an integer-array into a string
832 : !> \param arr ...
833 : !> \return ...
834 : !> \author Ole Schuett
835 : ! **************************************************************************************************
836 198 : PURE FUNCTION iarr2str(arr) RESULT(str)
837 : INTEGER, DIMENSION(:), INTENT(IN) :: arr
838 : CHARACTER(LEN=SIZE(arr)) :: str
839 :
840 : INTEGER :: i
841 :
842 6078 : DO i = 1, SIZE(arr)
843 6078 : str(i:i) = CHAR(arr(i))
844 : END DO
845 198 : END FUNCTION iarr2str
846 :
847 : #:set instances = {'str' : 'CHARACTER(LEN=*)', &
848 : 'i4' : 'INTEGER(KIND=int_4)', &
849 : 'i8' : 'INTEGER(KIND=int_8)', &
850 : 'r4' : 'REAL(KIND=real_4)', &
851 : 'r8' : 'REAL(KIND=real_8)', &
852 : '1d_i4' : 'INTEGER(KIND=int_4), DIMENSION(:)', &
853 : '1d_i8' : 'INTEGER(KIND=int_8), DIMENSION(:)', &
854 : '1d_r4' : 'REAL(KIND=real_4), DIMENSION(:)', &
855 : '1d_r8' : 'REAL(KIND=real_8), DIMENSION(:)' }
856 :
857 : #:for label, type in instances.items()
858 :
859 : ! **************************************************************************************************
860 : !> \brief Addes an entry from a swarm-message.
861 : !> \param msg ...
862 : !> \param key ...
863 : !> \param value ...
864 : !> \author Ole Schuett
865 : ! **************************************************************************************************
866 228 : SUBROUTINE swarm_message_add_${label}$ (msg, key, value)
867 : TYPE(swarm_message_type), INTENT(INOUT) :: msg
868 : CHARACTER(LEN=*), INTENT(IN) :: key
869 : ${type}$, INTENT(IN) :: value
870 :
871 : TYPE(message_entry_type), POINTER :: new_entry
872 :
873 199 : IF (swarm_message_haskey(msg, key)) THEN
874 0 : CPABORT("swarm_message_add_${label}$: key already exists: "//TRIM(key))
875 : END IF
876 :
877 199 : ALLOCATE (new_entry)
878 199 : new_entry%key = key
879 :
880 : #:if label.startswith("1d_")
881 87 : ALLOCATE (new_entry%value_${label}$ (SIZE(value)))
882 : #:else
883 170 : ALLOCATE (new_entry%value_${label}$)
884 : #:endif
885 :
886 1069 : new_entry%value_${label}$ = value
887 :
888 : !WRITE (*,*) "swarm_message_add_${label}$: key=",key, " value=",new_entry%value_${label}$
889 :
890 199 : IF (.NOT. ASSOCIATED(msg%root)) THEN
891 41 : msg%root => new_entry
892 : ELSE
893 158 : new_entry%next => msg%root
894 158 : msg%root => new_entry
895 : END IF
896 :
897 199 : END SUBROUTINE swarm_message_add_${label}$
898 :
899 : ! **************************************************************************************************
900 : !> \brief Returns an entry from a swarm-message.
901 : !> \param msg ...
902 : !> \param key ...
903 : !> \param value ...
904 : !> \author Ole Schuett
905 : ! **************************************************************************************************
906 385 : SUBROUTINE swarm_message_get_${label}$ (msg, key, value)
907 : TYPE(swarm_message_type), INTENT(IN) :: msg
908 : CHARACTER(LEN=*), INTENT(IN) :: key
909 :
910 : #:if label=="str"
911 : CHARACTER(LEN=default_string_length) :: value
912 : #:elif label.startswith("1d_")
913 : ${type}$, POINTER :: value
914 : #:else
915 : ${type}$, INTENT(OUT) :: value
916 : #:endif
917 :
918 : TYPE(message_entry_type), POINTER :: curr_entry
919 : !WRITE (*,*) "swarm_message_get_${label}$: key=",key
920 :
921 : #:if label.startswith("1d_")
922 40 : IF (ASSOCIATED(value)) CPABORT("swarm_message_get_${label}$: value already associated")
923 : #:endif
924 :
925 385 : curr_entry => msg%root
926 1248 : DO WHILE (ASSOCIATED(curr_entry))
927 1248 : IF (TRIM(curr_entry%key) == TRIM(key)) THEN
928 385 : IF (.NOT. ASSOCIATED(curr_entry%value_${label}$)) THEN
929 0 : CPABORT("swarm_message_get_${label}$: value not associated key: "//TRIM(key))
930 : END IF
931 : #:if label.startswith("1d_")
932 120 : ALLOCATE (value(SIZE(curr_entry%value_${label}$)))
933 : #:endif
934 2785 : value = curr_entry%value_${label}$
935 : !WRITE (*,*) "swarm_message_get_${label}$: value=",value
936 385 : RETURN
937 : END IF
938 863 : curr_entry => curr_entry%next
939 : END DO
940 0 : CPABORT("swarm_message_get: key not found: "//TRIM(key))
941 : END SUBROUTINE swarm_message_get_${label}$
942 :
943 : #:endfor
944 :
945 0 : END MODULE swarm_message
946 :
|
