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