(git:e7e05ae)
swarm_message.F
Go to the documentation of this file.
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  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  l = 0
95  curr_entry => msg%root
96  DO WHILE (ASSOCIATED(curr_entry))
97  l = l + 1
98  curr_entry => curr_entry%next
99  END DO
100  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  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  res = .false.
117  curr_entry => msg%root
118  DO WHILE (ASSOCIATED(curr_entry))
119  IF (trim(curr_entry%key) == trim(key)) THEN
120  res = .true.
121  EXIT
122  END IF
123  curr_entry => curr_entry%next
124  END DO
125  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  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  entry => msg%root
138  DO WHILE (ASSOCIATED(entry))
139  IF (ASSOCIATED(entry%value_str)) DEALLOCATE (entry%value_str)
140  IF (ASSOCIATED(entry%value_i4)) DEALLOCATE (entry%value_i4)
141  IF (ASSOCIATED(entry%value_i8)) DEALLOCATE (entry%value_i8)
142  IF (ASSOCIATED(entry%value_r4)) DEALLOCATE (entry%value_r4)
143  IF (ASSOCIATED(entry%value_r8)) DEALLOCATE (entry%value_r8)
144  IF (ASSOCIATED(entry%value_1d_i4)) DEALLOCATE (entry%value_1d_i4)
145  IF (ASSOCIATED(entry%value_1d_i8)) DEALLOCATE (entry%value_1d_i8)
146  IF (ASSOCIATED(entry%value_1d_r4)) DEALLOCATE (entry%value_1d_r4)
147  IF (ASSOCIATED(entry%value_1d_r8)) DEALLOCATE (entry%value_1d_r8)
148  old_entry => entry
149  entry => entry%next
150  DEALLOCATE (old_entry)
151  END DO
152 
153  NULLIFY (msg%root)
154 
155  cpassert(swarm_message_length(msg) == 0)
156  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  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  swarm_message_equal_oneway(msg2, msg1)
171 
172  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  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  CALL group%send(swarm_message_length(msg), dest, tag)
190  curr_entry => msg%root
191  DO WHILE (ASSOCIATED(curr_entry))
192  CALL swarm_message_entry_mpi_send(curr_entry, group, dest, tag)
193  curr_entry => curr_entry%next
194  END DO
195  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  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  IF (ASSOCIATED(msg%root)) cpabort("message not empty")
214  CALL group%recv(length, src, tag)
215  DO i = 1, length
216  ALLOCATE (new_entry)
217  CALL swarm_message_entry_mpi_recv(new_entry, group, src, tag)
218  new_entry%next => msg%root
219  msg%root => new_entry
220  END DO
221 
222  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  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  IF (mepos /= src .AND. ASSOCIATED(msg%root)) cpabort("message not empty")
242  length = swarm_message_length(msg)
243  CALL group%bcast(length, src)
244 
245  IF (mepos == src) curr_entry => msg%root
246 
247  DO i = 1, length
248  IF (mepos /= src) ALLOCATE (curr_entry)
249 
250  CALL swarm_message_entry_mpi_bcast(curr_entry, src, group, mepos)
251 
252  IF (mepos == src) THEN
253  curr_entry => curr_entry%next
254  ELSE
255  curr_entry%next => msg%root
256  msg%root => curr_entry
257  END IF
258  END DO
259  END associate
260 
261  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  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  IF (unit <= 0) RETURN
277 
278  CALL timeset("swarm_message_file_write", handle)
279  WRITE (unit, "(A)") "BEGIN SWARM_MESSAGE"
280  WRITE (unit, "(A,I10)") "msg_length: ", swarm_message_length(msg)
281 
282  curr_entry => msg%root
283  DO WHILE (ASSOCIATED(curr_entry))
284  CALL swarm_message_entry_file_write(curr_entry, unit)
285  curr_entry => curr_entry%next
286  END DO
287 
288  WRITE (unit, "(A)") "END SWARM_MESSAGE"
289  WRITE (unit, "()")
290  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  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  CALL timeset("swarm_message_file_read", handle)
308  CALL swarm_message_file_read_low(msg, parser, at_end)
309  CALL timestop(handle)
310  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  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  CALL parser_get_next_line(parser, 1, at_end)
329  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
330  IF (at_end) RETURN
331  cpassert(trim(parser%input_line(1:20)) == "BEGIN SWARM_MESSAGE")
332 
333  CALL parser_get_next_line(parser, 1, at_end)
334  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
335  IF (at_end) RETURN
336  READ (parser%input_line(1:40), *) label, length
337  cpassert(trim(label) == "msg_length:")
338 
339  DO i = 1, length
340  ALLOCATE (new_entry)
341  CALL swarm_message_entry_file_read(new_entry, parser, at_end)
342  new_entry%next => msg%root
343  msg%root => new_entry
344  END DO
345 
346  CALL parser_get_next_line(parser, 1, at_end)
347  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
348  IF (at_end) RETURN
349  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  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  res = .false.
368 
369  !loop over entries of msg1
370  entry1 => msg1%root
371  DO WHILE (ASSOCIATED(entry1))
372 
373  ! finding matching entry in msg2
374  entry2 => msg2%root
375  found = .false.
376  DO WHILE (ASSOCIATED(entry2))
377  IF (trim(entry2%key) == trim(entry1%key)) THEN
378  found = .true.
379  EXIT
380  END IF
381  entry2 => entry2%next
382  END DO
383  IF (.NOT. found) RETURN
384 
385  !compare the two entries
386  IF (ASSOCIATED(entry1%value_str)) THEN
387  IF (.NOT. ASSOCIATED(entry2%value_str)) RETURN
388  IF (trim(entry1%value_str) /= trim(entry2%value_str)) RETURN
389 
390  ELSE IF (ASSOCIATED(entry1%value_i4)) THEN
391  IF (.NOT. ASSOCIATED(entry2%value_i4)) RETURN
392  IF (entry1%value_i4 /= entry2%value_i4) RETURN
393 
394  ELSE IF (ASSOCIATED(entry1%value_i8)) THEN
395  IF (.NOT. ASSOCIATED(entry2%value_i8)) RETURN
396  IF (entry1%value_i8 /= entry2%value_i8) RETURN
397 
398  ELSE IF (ASSOCIATED(entry1%value_r4)) THEN
399  IF (.NOT. ASSOCIATED(entry2%value_r4)) RETURN
400  IF (abs(entry1%value_r4 - entry2%value_r4) > 1e-5) RETURN
401 
402  ELSE IF (ASSOCIATED(entry1%value_r8)) THEN
403  IF (.NOT. ASSOCIATED(entry2%value_r8)) RETURN
404  IF (abs(entry1%value_r8 - entry2%value_r8) > 1e-10) RETURN
405 
406  ELSE IF (ASSOCIATED(entry1%value_1d_i4)) THEN
407  IF (.NOT. ASSOCIATED(entry2%value_1d_i4)) RETURN
408  IF (any(entry1%value_1d_i4 /= entry2%value_1d_i4)) RETURN
409 
410  ELSE IF (ASSOCIATED(entry1%value_1d_i8)) THEN
411  IF (.NOT. ASSOCIATED(entry2%value_1d_i8)) RETURN
412  IF (any(entry1%value_1d_i8 /= entry2%value_1d_i8)) RETURN
413 
414  ELSE IF (ASSOCIATED(entry1%value_1d_r4)) THEN
415  IF (.NOT. ASSOCIATED(entry2%value_1d_r4)) RETURN
416  IF (any(abs(entry1%value_1d_r4 - entry2%value_1d_r4) > 1e-5)) RETURN
417 
418  ELSE IF (ASSOCIATED(entry1%value_1d_r8)) THEN
419  IF (.NOT. ASSOCIATED(entry2%value_1d_r8)) RETURN
420  IF (any(abs(entry1%value_1d_r8 - entry2%value_1d_r8) > 1e-10)) RETURN
421  ELSE
422  cpabort("no value ASSOCIATED")
423  END IF
424 
425  entry1 => entry1%next
426  END DO
427 
428  ! if we reach this point no differences were found
429  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  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  key_arr = str2iarr(entry%key)
449  CALL group%send(key_arr, dest, tag)
450 
451  IF (ASSOCIATED(entry%value_i4)) THEN
452  CALL group%send(1, dest, tag)
453  CALL group%send(entry%value_i4, dest, tag)
454 
455  ELSE IF (ASSOCIATED(entry%value_i8)) THEN
456  CALL group%send(2, dest, tag)
457  CALL group%send(entry%value_i8, dest, tag)
458 
459  ELSE IF (ASSOCIATED(entry%value_r4)) THEN
460  CALL group%send(3, dest, tag)
461  CALL group%send(entry%value_r4, dest, tag)
462 
463  ELSE IF (ASSOCIATED(entry%value_r8)) THEN
464  CALL group%send(4, dest, tag)
465  CALL group%send(entry%value_r8, dest, tag)
466 
467  ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
468  CALL group%send(5, dest, tag)
469  CALL group%send(SIZE(entry%value_1d_i4), dest, tag)
470  CALL group%send(entry%value_1d_i4, dest, tag)
471 
472  ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
473  CALL group%send(6, dest, tag)
474  CALL group%send(SIZE(entry%value_1d_i8), dest, tag)
475  CALL group%send(entry%value_1d_i8, dest, tag)
476 
477  ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
478  CALL group%send(7, dest, tag)
479  CALL group%send(SIZE(entry%value_1d_r4), dest, tag)
480  CALL group%send(entry%value_1d_r4, dest, tag)
481 
482  ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
483  CALL group%send(8, dest, tag)
484  CALL group%send(SIZE(entry%value_1d_r8), dest, tag)
485  CALL group%send(entry%value_1d_r8, dest, tag)
486 
487  ELSE IF (ASSOCIATED(entry%value_str)) THEN
488  CALL group%send(9, dest, tag)
489  value_str_arr = str2iarr(entry%value_str)
490  CALL group%send(value_str_arr, dest, tag)
491  ELSE
492  cpabort("no value ASSOCIATED")
493  END IF
494  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  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  CALL group%recv(key_arr, src, tag)
514  entry%key = iarr2str(key_arr)
515 
516  CALL group%recv(datatype, src, tag)
517 
518  SELECT CASE (datatype)
519  CASE (1)
520  ALLOCATE (entry%value_i4)
521  CALL group%recv(entry%value_i4, src, tag)
522  CASE (2)
523  ALLOCATE (entry%value_i8)
524  CALL group%recv(entry%value_i8, src, tag)
525  CASE (3)
526  ALLOCATE (entry%value_r4)
527  CALL group%recv(entry%value_r4, src, tag)
528  CASE (4)
529  ALLOCATE (entry%value_r8)
530  CALL group%recv(entry%value_r8, src, tag)
531  CASE (5)
532  CALL group%recv(s, src, tag)
533  ALLOCATE (entry%value_1d_i4(s))
534  CALL group%recv(entry%value_1d_i4, src, tag)
535  CASE (6)
536  CALL group%recv(s, src, tag)
537  ALLOCATE (entry%value_1d_i8(s))
538  CALL group%recv(entry%value_1d_i8, src, tag)
539  CASE (7)
540  CALL group%recv(s, src, tag)
541  ALLOCATE (entry%value_1d_r4(s))
542  CALL group%recv(entry%value_1d_r4, src, tag)
543  CASE (8)
544  CALL group%recv(s, src, tag)
545  ALLOCATE (entry%value_1d_r8(s))
546  CALL group%recv(entry%value_1d_r8, src, tag)
547  CASE (9)
548  ALLOCATE (entry%value_str)
549  CALL group%recv(value_str_arr, src, tag)
550  entry%value_str = iarr2str(value_str_arr)
551  CASE DEFAULT
552  cpabort("unknown datatype")
553  END SELECT
554  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  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  IF (src == mepos) key_arr = str2iarr(entry%key)
574  CALL group%bcast(key_arr, src)
575  IF (src /= mepos) entry%key = iarr2str(key_arr)
576 
577  IF (src == mepos) THEN
578  datasize = 1
579  IF (ASSOCIATED(entry%value_i4)) THEN
580  datatype = 1
581  ELSE IF (ASSOCIATED(entry%value_i8)) THEN
582  datatype = 2
583  ELSE IF (ASSOCIATED(entry%value_r4)) THEN
584  datatype = 3
585  ELSE IF (ASSOCIATED(entry%value_r8)) THEN
586  datatype = 4
587  ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
588  datatype = 5
589  datasize = SIZE(entry%value_1d_i4)
590  ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
591  datatype = 6
592  datasize = SIZE(entry%value_1d_i8)
593  ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
594  datatype = 7
595  datasize = SIZE(entry%value_1d_r4)
596  ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
597  datatype = 8
598  datasize = SIZE(entry%value_1d_r8)
599  ELSE IF (ASSOCIATED(entry%value_str)) THEN
600  datatype = 9
601  ELSE
602  cpabort("no value ASSOCIATED")
603  END IF
604  END IF
605  CALL group%bcast(datatype, src)
606  CALL group%bcast(datasize, src)
607 
608  SELECT CASE (datatype)
609  CASE (1)
610  IF (src /= mepos) ALLOCATE (entry%value_i4)
611  CALL group%bcast(entry%value_i4, src)
612  CASE (2)
613  IF (src /= mepos) ALLOCATE (entry%value_i8)
614  CALL group%bcast(entry%value_i8, src)
615  CASE (3)
616  IF (src /= mepos) ALLOCATE (entry%value_r4)
617  CALL group%bcast(entry%value_r4, src)
618  CASE (4)
619  IF (src /= mepos) ALLOCATE (entry%value_r8)
620  CALL group%bcast(entry%value_r8, src)
621  CASE (5)
622  IF (src /= mepos) ALLOCATE (entry%value_1d_i4(datasize))
623  CALL group%bcast(entry%value_1d_i4, src)
624  CASE (6)
625  IF (src /= mepos) ALLOCATE (entry%value_1d_i8(datasize))
626  CALL group%bcast(entry%value_1d_i8, src)
627  CASE (7)
628  IF (src /= mepos) ALLOCATE (entry%value_1d_r4(datasize))
629  CALL group%bcast(entry%value_1d_r4, src)
630  CASE (8)
631  IF (src /= mepos) ALLOCATE (entry%value_1d_r8(datasize))
632  CALL group%bcast(entry%value_1d_r8, src)
633  CASE (9)
634  IF (src == mepos) value_str_arr = str2iarr(entry%value_str)
635  CALL group%bcast(value_str_arr, src)
636  IF (src /= mepos) THEN
637  ALLOCATE (entry%value_str)
638  entry%value_str = iarr2str(value_str_arr)
639  END IF
640  CASE DEFAULT
641  cpabort("unknown datatype")
642  END SELECT
643 
644  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  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  WRITE (unit, "(A,A)") "key: ", entry%key
659  IF (ASSOCIATED(entry%value_i4)) THEN
660  WRITE (unit, "(A)") "datatype: i4"
661  WRITE (unit, "(A,I10)") "value: ", entry%value_i4
662 
663  ELSE IF (ASSOCIATED(entry%value_i8)) THEN
664  WRITE (unit, "(A)") "datatype: i8"
665  WRITE (unit, "(A,I20)") "value: ", entry%value_i8
666 
667  ELSE IF (ASSOCIATED(entry%value_r4)) THEN
668  WRITE (unit, "(A)") "datatype: r4"
669  WRITE (unit, "(A,E30.20)") "value: ", entry%value_r4
670 
671  ELSE IF (ASSOCIATED(entry%value_r8)) THEN
672  WRITE (unit, "(A)") "datatype: r8"
673  WRITE (unit, "(A,E30.20)") "value: ", entry%value_r8
674 
675  ELSE IF (ASSOCIATED(entry%value_str)) THEN
676  WRITE (unit, "(A)") "datatype: str"
677  WRITE (unit, "(A,A)") "value: ", entry%value_str
678 
679  ELSE IF (ASSOCIATED(entry%value_1d_i4)) THEN
680  WRITE (unit, "(A)") "datatype: 1d_i4"
681  WRITE (unit, "(A,I10)") "size: ", SIZE(entry%value_1d_i4)
682  DO i = 1, SIZE(entry%value_1d_i4)
683  WRITE (unit, *) entry%value_1d_i4(i)
684  END DO
685 
686  ELSE IF (ASSOCIATED(entry%value_1d_i8)) THEN
687  WRITE (unit, "(A)") "datatype: 1d_i8"
688  WRITE (unit, "(A,I20)") "size: ", SIZE(entry%value_1d_i8)
689  DO i = 1, SIZE(entry%value_1d_i8)
690  WRITE (unit, *) entry%value_1d_i8(i)
691  END DO
692 
693  ELSE IF (ASSOCIATED(entry%value_1d_r4)) THEN
694  WRITE (unit, "(A)") "datatype: 1d_r4"
695  WRITE (unit, "(A,I8)") "size: ", SIZE(entry%value_1d_r4)
696  DO i = 1, SIZE(entry%value_1d_r4)
697  WRITE (unit, "(1X,E30.20)") entry%value_1d_r4(i)
698  END DO
699 
700  ELSE IF (ASSOCIATED(entry%value_1d_r8)) THEN
701  WRITE (unit, "(A)") "datatype: 1d_r8"
702  WRITE (unit, "(A,I8)") "size: ", SIZE(entry%value_1d_r8)
703  DO i = 1, SIZE(entry%value_1d_r8)
704  WRITE (unit, "(1X,E30.20)") entry%value_1d_r8(i)
705  END DO
706 
707  ELSE
708  cpabort("no value ASSOCIATED")
709  END IF
710  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  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  CALL parser_get_next_line(parser, 1, at_end)
729  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
730  IF (at_end) RETURN
731  READ (parser%input_line(1:key_length + 10), *) label, entry%key
732  cpassert(trim(label) == "key:")
733 
734  CALL parser_get_next_line(parser, 1, at_end)
735  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
736  IF (at_end) RETURN
737  READ (parser%input_line(1:30), *) label, datatype
738  cpassert(trim(label) == "datatype:")
739 
740  CALL parser_get_next_line(parser, 1, at_end)
741  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
742  IF (at_end) RETURN
743 
744  is_scalar = .true.
745  SELECT CASE (trim(datatype))
746  CASE ("i4")
747  ALLOCATE (entry%value_i4)
748  READ (parser%input_line(1:40), *) label, entry%value_i4
749  CASE ("i8")
750  ALLOCATE (entry%value_i8)
751  READ (parser%input_line(1:40), *) label, entry%value_i8
752  CASE ("r4")
753  ALLOCATE (entry%value_r4)
754  READ (parser%input_line(1:40), *) label, entry%value_r4
755  CASE ("r8")
756  ALLOCATE (entry%value_r8)
757  READ (parser%input_line(1:40), *) label, entry%value_r8
758  CASE ("str")
759  ALLOCATE (entry%value_str)
760  READ (parser%input_line(1:40), *) label, entry%value_str
761  CASE DEFAULT
762  is_scalar = .false.
763  END SELECT
764 
765  IF (is_scalar) THEN
766  cpassert(trim(label) == "value:")
767  RETURN
768  END IF
769 
770  ! musst be an array-datatype
771  READ (parser%input_line(1:30), *) label, arr_size
772  cpassert(trim(label) == "size:")
773 
774  SELECT CASE (trim(datatype))
775  CASE ("1d_i4")
776  ALLOCATE (entry%value_1d_i4(arr_size))
777  CASE ("1d_i8")
778  ALLOCATE (entry%value_1d_i8(arr_size))
779  CASE ("1d_r4")
780  ALLOCATE (entry%value_1d_r4(arr_size))
781  CASE ("1d_r8")
782  ALLOCATE (entry%value_1d_r8(arr_size))
783  CASE DEFAULT
784  cpabort("unknown datatype")
785  END SELECT
786 
787  DO i = 1, arr_size
788  CALL parser_get_next_line(parser, 1, at_end)
789  at_end = at_end .OR. len_trim(parser%input_line(1:10)) == 0
790  IF (at_end) RETURN
791 
792  !Numbers were written with at most 31 characters.
793  SELECT CASE (trim(datatype))
794  CASE ("1d_i4")
795  READ (parser%input_line(1:31), *) entry%value_1d_i4(i)
796  CASE ("1d_i8")
797  READ (parser%input_line(1:31), *) entry%value_1d_i8(i)
798  CASE ("1d_r4")
799  READ (parser%input_line(1:31), *) entry%value_1d_r4(i)
800  CASE ("1d_r8")
801  READ (parser%input_line(1:31), *) entry%value_1d_r8(i)
802  CASE DEFAULT
803  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  PURE FUNCTION str2iarr(str) RESULT(arr)
816  CHARACTER(LEN=*), INTENT(IN) :: str
817  INTEGER, DIMENSION(LEN(str)) :: arr
818 
819  INTEGER :: i
820 
821  DO i = 1, len(str)
822  arr(i) = ichar(str(i:i))
823  END DO
824  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  PURE FUNCTION iarr2str(arr) RESULT(str)
833  INTEGER, DIMENSION(:), INTENT(IN) :: arr
834  CHARACTER(LEN=SIZE(arr)) :: str
835 
836  INTEGER :: i
837 
838  DO i = 1, SIZE(arr)
839  str(i:i) = char(arr(i))
840  END DO
841  END FUNCTION iarr2str
842 
843 
844 
845 ! **************************************************************************************************
846 !> \brief Addes an entry from a swarm-message.
847 !> \param msg ...
848 !> \param key ...
849 !> \param value ...
850 !> \author Ole Schuett
851 ! **************************************************************************************************
852  SUBROUTINE swarm_message_add_str (msg, key, value)
853  TYPE(swarm_message_type), INTENT(INOUT) :: msg
854  CHARACTER(LEN=*), INTENT(IN) :: key
855  CHARACTER(LEN=*), INTENT(IN) :: value
856 
857  TYPE(message_entry_type), POINTER :: new_entry
858 
859  IF (swarm_message_haskey(msg, key)) &
860  cpabort("swarm_message_add_str: key already exists: "//trim(key))
861 
862  ALLOCATE (new_entry)
863  new_entry%key = key
864 
865  ALLOCATE (new_entry%value_str)
866 
867  new_entry%value_str = value
868 
869  !WRITE (*,*) "swarm_message_add_str: key=",key, " value=",new_entry%value_str
870 
871  IF (.NOT. ASSOCIATED(msg%root)) THEN
872  msg%root => new_entry
873  ELSE
874  new_entry%next => msg%root
875  msg%root => new_entry
876  END IF
877 
878  END SUBROUTINE swarm_message_add_str
879 
880 ! **************************************************************************************************
881 !> \brief Returns an entry from a swarm-message.
882 !> \param msg ...
883 !> \param key ...
884 !> \param value ...
885 !> \author Ole Schuett
886 ! **************************************************************************************************
887  SUBROUTINE swarm_message_get_str (msg, key, value)
888  TYPE(swarm_message_type), INTENT(IN) :: msg
889  CHARACTER(LEN=*), INTENT(IN) :: key
890 
891  CHARACTER(LEN=default_string_length) :: value
892 
893  TYPE(message_entry_type), POINTER :: curr_entry
894  !WRITE (*,*) "swarm_message_get_str: key=",key
895 
896 
897  curr_entry => msg%root
898  DO WHILE (ASSOCIATED(curr_entry))
899  IF (trim(curr_entry%key) == trim(key)) THEN
900  IF (.NOT. ASSOCIATED(curr_entry%value_str)) &
901  cpabort("swarm_message_get_str: value not associated key: "//trim(key))
902  value = curr_entry%value_str
903  !WRITE (*,*) "swarm_message_get_str: value=",value
904  RETURN
905  END IF
906  curr_entry => curr_entry%next
907  END DO
908  cpabort("swarm_message_get: key not found: "//trim(key))
909  END SUBROUTINE swarm_message_get_str
910 
911 
912 ! **************************************************************************************************
913 !> \brief Addes an entry from a swarm-message.
914 !> \param msg ...
915 !> \param key ...
916 !> \param value ...
917 !> \author Ole Schuett
918 ! **************************************************************************************************
919  SUBROUTINE swarm_message_add_i4 (msg, key, value)
920  TYPE(swarm_message_type), INTENT(INOUT) :: msg
921  CHARACTER(LEN=*), INTENT(IN) :: key
922  INTEGER(KIND=int_4), INTENT(IN) :: value
923 
924  TYPE(message_entry_type), POINTER :: new_entry
925 
926  IF (swarm_message_haskey(msg, key)) &
927  cpabort("swarm_message_add_i4: key already exists: "//trim(key))
928 
929  ALLOCATE (new_entry)
930  new_entry%key = key
931 
932  ALLOCATE (new_entry%value_i4)
933 
934  new_entry%value_i4 = value
935 
936  !WRITE (*,*) "swarm_message_add_i4: key=",key, " value=",new_entry%value_i4
937 
938  IF (.NOT. ASSOCIATED(msg%root)) THEN
939  msg%root => new_entry
940  ELSE
941  new_entry%next => msg%root
942  msg%root => new_entry
943  END IF
944 
945  END SUBROUTINE swarm_message_add_i4
946 
947 ! **************************************************************************************************
948 !> \brief Returns an entry from a swarm-message.
949 !> \param msg ...
950 !> \param key ...
951 !> \param value ...
952 !> \author Ole Schuett
953 ! **************************************************************************************************
954  SUBROUTINE swarm_message_get_i4 (msg, key, value)
955  TYPE(swarm_message_type), INTENT(IN) :: msg
956  CHARACTER(LEN=*), INTENT(IN) :: key
957 
958  INTEGER(KIND=int_4), INTENT(OUT) :: value
959 
960  TYPE(message_entry_type), POINTER :: curr_entry
961  !WRITE (*,*) "swarm_message_get_i4: key=",key
962 
963 
964  curr_entry => msg%root
965  DO WHILE (ASSOCIATED(curr_entry))
966  IF (trim(curr_entry%key) == trim(key)) THEN
967  IF (.NOT. ASSOCIATED(curr_entry%value_i4)) &
968  cpabort("swarm_message_get_i4: value not associated key: "//trim(key))
969  value = curr_entry%value_i4
970  !WRITE (*,*) "swarm_message_get_i4: value=",value
971  RETURN
972  END IF
973  curr_entry => curr_entry%next
974  END DO
975  cpabort("swarm_message_get: key not found: "//trim(key))
976  END SUBROUTINE swarm_message_get_i4
977 
978 
979 ! **************************************************************************************************
980 !> \brief Addes an entry from a swarm-message.
981 !> \param msg ...
982 !> \param key ...
983 !> \param value ...
984 !> \author Ole Schuett
985 ! **************************************************************************************************
986  SUBROUTINE swarm_message_add_i8 (msg, key, value)
987  TYPE(swarm_message_type), INTENT(INOUT) :: msg
988  CHARACTER(LEN=*), INTENT(IN) :: key
989  INTEGER(KIND=int_8), INTENT(IN) :: value
990 
991  TYPE(message_entry_type), POINTER :: new_entry
992 
993  IF (swarm_message_haskey(msg, key)) &
994  cpabort("swarm_message_add_i8: key already exists: "//trim(key))
995 
996  ALLOCATE (new_entry)
997  new_entry%key = key
998 
999  ALLOCATE (new_entry%value_i8)
1000 
1001  new_entry%value_i8 = value
1002 
1003  !WRITE (*,*) "swarm_message_add_i8: key=",key, " value=",new_entry%value_i8
1004 
1005  IF (.NOT. ASSOCIATED(msg%root)) THEN
1006  msg%root => new_entry
1007  ELSE
1008  new_entry%next => msg%root
1009  msg%root => new_entry
1010  END IF
1011 
1012  END SUBROUTINE swarm_message_add_i8
1013 
1014 ! **************************************************************************************************
1015 !> \brief Returns an entry from a swarm-message.
1016 !> \param msg ...
1017 !> \param key ...
1018 !> \param value ...
1019 !> \author Ole Schuett
1020 ! **************************************************************************************************
1021  SUBROUTINE swarm_message_get_i8 (msg, key, value)
1022  TYPE(swarm_message_type), INTENT(IN) :: msg
1023  CHARACTER(LEN=*), INTENT(IN) :: key
1024 
1025  INTEGER(KIND=int_8), INTENT(OUT) :: value
1026 
1027  TYPE(message_entry_type), POINTER :: curr_entry
1028  !WRITE (*,*) "swarm_message_get_i8: key=",key
1029 
1030 
1031  curr_entry => msg%root
1032  DO WHILE (ASSOCIATED(curr_entry))
1033  IF (trim(curr_entry%key) == trim(key)) THEN
1034  IF (.NOT. ASSOCIATED(curr_entry%value_i8)) &
1035  cpabort("swarm_message_get_i8: value not associated key: "//trim(key))
1036  value = curr_entry%value_i8
1037  !WRITE (*,*) "swarm_message_get_i8: value=",value
1038  RETURN
1039  END IF
1040  curr_entry => curr_entry%next
1041  END DO
1042  cpabort("swarm_message_get: key not found: "//trim(key))
1043  END SUBROUTINE swarm_message_get_i8
1044 
1045 
1046 ! **************************************************************************************************
1047 !> \brief Addes an entry from a swarm-message.
1048 !> \param msg ...
1049 !> \param key ...
1050 !> \param value ...
1051 !> \author Ole Schuett
1052 ! **************************************************************************************************
1053  SUBROUTINE swarm_message_add_r4 (msg, key, value)
1054  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1055  CHARACTER(LEN=*), INTENT(IN) :: key
1056  REAL(kind=real_4), INTENT(IN) :: value
1057 
1058  TYPE(message_entry_type), POINTER :: new_entry
1059 
1060  IF (swarm_message_haskey(msg, key)) &
1061  cpabort("swarm_message_add_r4: key already exists: "//trim(key))
1062 
1063  ALLOCATE (new_entry)
1064  new_entry%key = key
1065 
1066  ALLOCATE (new_entry%value_r4)
1067 
1068  new_entry%value_r4 = value
1069 
1070  !WRITE (*,*) "swarm_message_add_r4: key=",key, " value=",new_entry%value_r4
1071 
1072  IF (.NOT. ASSOCIATED(msg%root)) THEN
1073  msg%root => new_entry
1074  ELSE
1075  new_entry%next => msg%root
1076  msg%root => new_entry
1077  END IF
1078 
1079  END SUBROUTINE swarm_message_add_r4
1080 
1081 ! **************************************************************************************************
1082 !> \brief Returns an entry from a swarm-message.
1083 !> \param msg ...
1084 !> \param key ...
1085 !> \param value ...
1086 !> \author Ole Schuett
1087 ! **************************************************************************************************
1088  SUBROUTINE swarm_message_get_r4 (msg, key, value)
1089  TYPE(swarm_message_type), INTENT(IN) :: msg
1090  CHARACTER(LEN=*), INTENT(IN) :: key
1091 
1092  REAL(kind=real_4), INTENT(OUT) :: value
1093 
1094  TYPE(message_entry_type), POINTER :: curr_entry
1095  !WRITE (*,*) "swarm_message_get_r4: key=",key
1096 
1097 
1098  curr_entry => msg%root
1099  DO WHILE (ASSOCIATED(curr_entry))
1100  IF (trim(curr_entry%key) == trim(key)) THEN
1101  IF (.NOT. ASSOCIATED(curr_entry%value_r4)) &
1102  cpabort("swarm_message_get_r4: value not associated key: "//trim(key))
1103  value = curr_entry%value_r4
1104  !WRITE (*,*) "swarm_message_get_r4: value=",value
1105  RETURN
1106  END IF
1107  curr_entry => curr_entry%next
1108  END DO
1109  cpabort("swarm_message_get: key not found: "//trim(key))
1110  END SUBROUTINE swarm_message_get_r4
1111 
1112 
1113 ! **************************************************************************************************
1114 !> \brief Addes an entry from a swarm-message.
1115 !> \param msg ...
1116 !> \param key ...
1117 !> \param value ...
1118 !> \author Ole Schuett
1119 ! **************************************************************************************************
1120  SUBROUTINE swarm_message_add_r8 (msg, key, value)
1121  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1122  CHARACTER(LEN=*), INTENT(IN) :: key
1123  REAL(kind=real_8), INTENT(IN) :: value
1124 
1125  TYPE(message_entry_type), POINTER :: new_entry
1126 
1127  IF (swarm_message_haskey(msg, key)) &
1128  cpabort("swarm_message_add_r8: key already exists: "//trim(key))
1129 
1130  ALLOCATE (new_entry)
1131  new_entry%key = key
1132 
1133  ALLOCATE (new_entry%value_r8)
1134 
1135  new_entry%value_r8 = value
1136 
1137  !WRITE (*,*) "swarm_message_add_r8: key=",key, " value=",new_entry%value_r8
1138 
1139  IF (.NOT. ASSOCIATED(msg%root)) THEN
1140  msg%root => new_entry
1141  ELSE
1142  new_entry%next => msg%root
1143  msg%root => new_entry
1144  END IF
1145 
1146  END SUBROUTINE swarm_message_add_r8
1147 
1148 ! **************************************************************************************************
1149 !> \brief Returns an entry from a swarm-message.
1150 !> \param msg ...
1151 !> \param key ...
1152 !> \param value ...
1153 !> \author Ole Schuett
1154 ! **************************************************************************************************
1155  SUBROUTINE swarm_message_get_r8 (msg, key, value)
1156  TYPE(swarm_message_type), INTENT(IN) :: msg
1157  CHARACTER(LEN=*), INTENT(IN) :: key
1158 
1159  REAL(kind=real_8), INTENT(OUT) :: value
1160 
1161  TYPE(message_entry_type), POINTER :: curr_entry
1162  !WRITE (*,*) "swarm_message_get_r8: key=",key
1163 
1164 
1165  curr_entry => msg%root
1166  DO WHILE (ASSOCIATED(curr_entry))
1167  IF (trim(curr_entry%key) == trim(key)) THEN
1168  IF (.NOT. ASSOCIATED(curr_entry%value_r8)) &
1169  cpabort("swarm_message_get_r8: value not associated key: "//trim(key))
1170  value = curr_entry%value_r8
1171  !WRITE (*,*) "swarm_message_get_r8: value=",value
1172  RETURN
1173  END IF
1174  curr_entry => curr_entry%next
1175  END DO
1176  cpabort("swarm_message_get: key not found: "//trim(key))
1177  END SUBROUTINE swarm_message_get_r8
1178 
1179 
1180 ! **************************************************************************************************
1181 !> \brief Addes an entry from a swarm-message.
1182 !> \param msg ...
1183 !> \param key ...
1184 !> \param value ...
1185 !> \author Ole Schuett
1186 ! **************************************************************************************************
1187  SUBROUTINE swarm_message_add_1d_i4 (msg, key, value)
1188  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1189  CHARACTER(LEN=*), INTENT(IN) :: key
1190  INTEGER(KIND=int_4), DIMENSION(:), INTENT(IN) :: value
1191 
1192  TYPE(message_entry_type), POINTER :: new_entry
1193 
1194  IF (swarm_message_haskey(msg, key)) &
1195  cpabort("swarm_message_add_1d_i4: key already exists: "//trim(key))
1196 
1197  ALLOCATE (new_entry)
1198  new_entry%key = key
1199 
1200  ALLOCATE (new_entry%value_1d_i4 (SIZE(value)))
1201 
1202  new_entry%value_1d_i4 = value
1203 
1204  !WRITE (*,*) "swarm_message_add_1d_i4: key=",key, " value=",new_entry%value_1d_i4
1205 
1206  IF (.NOT. ASSOCIATED(msg%root)) THEN
1207  msg%root => new_entry
1208  ELSE
1209  new_entry%next => msg%root
1210  msg%root => new_entry
1211  END IF
1212 
1213  END SUBROUTINE swarm_message_add_1d_i4
1214 
1215 ! **************************************************************************************************
1216 !> \brief Returns an entry from a swarm-message.
1217 !> \param msg ...
1218 !> \param key ...
1219 !> \param value ...
1220 !> \author Ole Schuett
1221 ! **************************************************************************************************
1222  SUBROUTINE swarm_message_get_1d_i4 (msg, key, value)
1223  TYPE(swarm_message_type), INTENT(IN) :: msg
1224  CHARACTER(LEN=*), INTENT(IN) :: key
1225 
1226  INTEGER(KIND=int_4), DIMENSION(:), POINTER :: value
1227 
1228  TYPE(message_entry_type), POINTER :: curr_entry
1229  !WRITE (*,*) "swarm_message_get_1d_i4: key=",key
1230 
1231  IF (ASSOCIATED(value)) cpabort("swarm_message_get_1d_i4: value already associated")
1232 
1233  curr_entry => msg%root
1234  DO WHILE (ASSOCIATED(curr_entry))
1235  IF (trim(curr_entry%key) == trim(key)) THEN
1236  IF (.NOT. ASSOCIATED(curr_entry%value_1d_i4)) &
1237  cpabort("swarm_message_get_1d_i4: value not associated key: "//trim(key))
1238  ALLOCATE (value(SIZE(curr_entry%value_1d_i4)))
1239  value = curr_entry%value_1d_i4
1240  !WRITE (*,*) "swarm_message_get_1d_i4: value=",value
1241  RETURN
1242  END IF
1243  curr_entry => curr_entry%next
1244  END DO
1245  cpabort("swarm_message_get: key not found: "//trim(key))
1246  END SUBROUTINE swarm_message_get_1d_i4
1247 
1248 
1249 ! **************************************************************************************************
1250 !> \brief Addes an entry from a swarm-message.
1251 !> \param msg ...
1252 !> \param key ...
1253 !> \param value ...
1254 !> \author Ole Schuett
1255 ! **************************************************************************************************
1256  SUBROUTINE swarm_message_add_1d_i8 (msg, key, value)
1257  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1258  CHARACTER(LEN=*), INTENT(IN) :: key
1259  INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN) :: value
1260 
1261  TYPE(message_entry_type), POINTER :: new_entry
1262 
1263  IF (swarm_message_haskey(msg, key)) &
1264  cpabort("swarm_message_add_1d_i8: key already exists: "//trim(key))
1265 
1266  ALLOCATE (new_entry)
1267  new_entry%key = key
1268 
1269  ALLOCATE (new_entry%value_1d_i8 (SIZE(value)))
1270 
1271  new_entry%value_1d_i8 = value
1272 
1273  !WRITE (*,*) "swarm_message_add_1d_i8: key=",key, " value=",new_entry%value_1d_i8
1274 
1275  IF (.NOT. ASSOCIATED(msg%root)) THEN
1276  msg%root => new_entry
1277  ELSE
1278  new_entry%next => msg%root
1279  msg%root => new_entry
1280  END IF
1281 
1282  END SUBROUTINE swarm_message_add_1d_i8
1283 
1284 ! **************************************************************************************************
1285 !> \brief Returns an entry from a swarm-message.
1286 !> \param msg ...
1287 !> \param key ...
1288 !> \param value ...
1289 !> \author Ole Schuett
1290 ! **************************************************************************************************
1291  SUBROUTINE swarm_message_get_1d_i8 (msg, key, value)
1292  TYPE(swarm_message_type), INTENT(IN) :: msg
1293  CHARACTER(LEN=*), INTENT(IN) :: key
1294 
1295  INTEGER(KIND=int_8), DIMENSION(:), POINTER :: value
1296 
1297  TYPE(message_entry_type), POINTER :: curr_entry
1298  !WRITE (*,*) "swarm_message_get_1d_i8: key=",key
1299 
1300  IF (ASSOCIATED(value)) cpabort("swarm_message_get_1d_i8: value already associated")
1301 
1302  curr_entry => msg%root
1303  DO WHILE (ASSOCIATED(curr_entry))
1304  IF (trim(curr_entry%key) == trim(key)) THEN
1305  IF (.NOT. ASSOCIATED(curr_entry%value_1d_i8)) &
1306  cpabort("swarm_message_get_1d_i8: value not associated key: "//trim(key))
1307  ALLOCATE (value(SIZE(curr_entry%value_1d_i8)))
1308  value = curr_entry%value_1d_i8
1309  !WRITE (*,*) "swarm_message_get_1d_i8: value=",value
1310  RETURN
1311  END IF
1312  curr_entry => curr_entry%next
1313  END DO
1314  cpabort("swarm_message_get: key not found: "//trim(key))
1315  END SUBROUTINE swarm_message_get_1d_i8
1316 
1317 
1318 ! **************************************************************************************************
1319 !> \brief Addes an entry from a swarm-message.
1320 !> \param msg ...
1321 !> \param key ...
1322 !> \param value ...
1323 !> \author Ole Schuett
1324 ! **************************************************************************************************
1325  SUBROUTINE swarm_message_add_1d_r4 (msg, key, value)
1326  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1327  CHARACTER(LEN=*), INTENT(IN) :: key
1328  REAL(kind=real_4), DIMENSION(:), INTENT(IN) :: value
1329 
1330  TYPE(message_entry_type), POINTER :: new_entry
1331 
1332  IF (swarm_message_haskey(msg, key)) &
1333  cpabort("swarm_message_add_1d_r4: key already exists: "//trim(key))
1334 
1335  ALLOCATE (new_entry)
1336  new_entry%key = key
1337 
1338  ALLOCATE (new_entry%value_1d_r4 (SIZE(value)))
1339 
1340  new_entry%value_1d_r4 = value
1341 
1342  !WRITE (*,*) "swarm_message_add_1d_r4: key=",key, " value=",new_entry%value_1d_r4
1343 
1344  IF (.NOT. ASSOCIATED(msg%root)) THEN
1345  msg%root => new_entry
1346  ELSE
1347  new_entry%next => msg%root
1348  msg%root => new_entry
1349  END IF
1350 
1351  END SUBROUTINE swarm_message_add_1d_r4
1352 
1353 ! **************************************************************************************************
1354 !> \brief Returns an entry from a swarm-message.
1355 !> \param msg ...
1356 !> \param key ...
1357 !> \param value ...
1358 !> \author Ole Schuett
1359 ! **************************************************************************************************
1360  SUBROUTINE swarm_message_get_1d_r4 (msg, key, value)
1361  TYPE(swarm_message_type), INTENT(IN) :: msg
1362  CHARACTER(LEN=*), INTENT(IN) :: key
1363 
1364  REAL(kind=real_4), DIMENSION(:), POINTER :: value
1365 
1366  TYPE(message_entry_type), POINTER :: curr_entry
1367  !WRITE (*,*) "swarm_message_get_1d_r4: key=",key
1368 
1369  IF (ASSOCIATED(value)) cpabort("swarm_message_get_1d_r4: value already associated")
1370 
1371  curr_entry => msg%root
1372  DO WHILE (ASSOCIATED(curr_entry))
1373  IF (trim(curr_entry%key) == trim(key)) THEN
1374  IF (.NOT. ASSOCIATED(curr_entry%value_1d_r4)) &
1375  cpabort("swarm_message_get_1d_r4: value not associated key: "//trim(key))
1376  ALLOCATE (value(SIZE(curr_entry%value_1d_r4)))
1377  value = curr_entry%value_1d_r4
1378  !WRITE (*,*) "swarm_message_get_1d_r4: value=",value
1379  RETURN
1380  END IF
1381  curr_entry => curr_entry%next
1382  END DO
1383  cpabort("swarm_message_get: key not found: "//trim(key))
1384  END SUBROUTINE swarm_message_get_1d_r4
1385 
1386 
1387 ! **************************************************************************************************
1388 !> \brief Addes an entry from a swarm-message.
1389 !> \param msg ...
1390 !> \param key ...
1391 !> \param value ...
1392 !> \author Ole Schuett
1393 ! **************************************************************************************************
1394  SUBROUTINE swarm_message_add_1d_r8 (msg, key, value)
1395  TYPE(swarm_message_type), INTENT(INOUT) :: msg
1396  CHARACTER(LEN=*), INTENT(IN) :: key
1397  REAL(kind=real_8), DIMENSION(:), INTENT(IN) :: value
1398 
1399  TYPE(message_entry_type), POINTER :: new_entry
1400 
1401  IF (swarm_message_haskey(msg, key)) &
1402  cpabort("swarm_message_add_1d_r8: key already exists: "//trim(key))
1403 
1404  ALLOCATE (new_entry)
1405  new_entry%key = key
1406 
1407  ALLOCATE (new_entry%value_1d_r8 (SIZE(value)))
1408 
1409  new_entry%value_1d_r8 = value
1410 
1411  !WRITE (*,*) "swarm_message_add_1d_r8: key=",key, " value=",new_entry%value_1d_r8
1412 
1413  IF (.NOT. ASSOCIATED(msg%root)) THEN
1414  msg%root => new_entry
1415  ELSE
1416  new_entry%next => msg%root
1417  msg%root => new_entry
1418  END IF
1419 
1420  END SUBROUTINE swarm_message_add_1d_r8
1421 
1422 ! **************************************************************************************************
1423 !> \brief Returns an entry from a swarm-message.
1424 !> \param msg ...
1425 !> \param key ...
1426 !> \param value ...
1427 !> \author Ole Schuett
1428 ! **************************************************************************************************
1429  SUBROUTINE swarm_message_get_1d_r8 (msg, key, value)
1430  TYPE(swarm_message_type), INTENT(IN) :: msg
1431  CHARACTER(LEN=*), INTENT(IN) :: key
1432 
1433  REAL(kind=real_8), DIMENSION(:), POINTER :: value
1434 
1435  TYPE(message_entry_type), POINTER :: curr_entry
1436  !WRITE (*,*) "swarm_message_get_1d_r8: key=",key
1437 
1438  IF (ASSOCIATED(value)) cpabort("swarm_message_get_1d_r8: value already associated")
1439 
1440  curr_entry => msg%root
1441  DO WHILE (ASSOCIATED(curr_entry))
1442  IF (trim(curr_entry%key) == trim(key)) THEN
1443  IF (.NOT. ASSOCIATED(curr_entry%value_1d_r8)) &
1444  cpabort("swarm_message_get_1d_r8: value not associated key: "//trim(key))
1445  ALLOCATE (value(SIZE(curr_entry%value_1d_r8)))
1446  value = curr_entry%value_1d_r8
1447  !WRITE (*,*) "swarm_message_get_1d_r8: value=",value
1448  RETURN
1449  END IF
1450  curr_entry => curr_entry%next
1451  END DO
1452  cpabort("swarm_message_get: key not found: "//trim(key))
1453  END SUBROUTINE swarm_message_get_1d_r8
1454 
1455 
1456 END MODULE swarm_message
1457 
cp_parser_methods
Utility routines to read data from files. Kept as close as possible to the old parser because.
Definition: cp_parser_methods.F:20
cp_parser_methods::parser_get_next_line
subroutine, public parser_get_next_line(parser, nline, at_end)
Read the next input line and broadcast the input information. Skip (nline-1) lines and skip also all ...
Definition: cp_parser_methods.F:421
cp_parser_types
Utility routines to read data from files. Kept as close as possible to the old parser because.
Definition: cp_parser_types.F:21
kinds
Defines the basic variable types.
Definition: kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition: kinds.F:54
kinds::default_string_length
integer, parameter, public default_string_length
Definition: kinds.F:57
kinds::real_4
integer, parameter, public real_4
Definition: kinds.F:40
kinds::real_8
integer, parameter, public real_8
Definition: kinds.F:41
kinds::int_4
integer, parameter, public int_4
Definition: kinds.F:51
message_passing
Interface to the message passing library MPI.
Definition: message_passing.F:23
swarm_message
Swarm-message, a convenient data-container for with build-in serialization.
Definition: swarm_message.F:12
swarm_message::swarm_message_mpi_send
subroutine, public swarm_message_mpi_send(msg, group, dest, tag)
Sends a swarm message via MPI.
Definition: swarm_message.F:183
swarm_message::swarm_message_mpi_bcast
subroutine, public swarm_message_mpi_bcast(msg, src, group)
Broadcasts a swarm message via MPI.
Definition: swarm_message.F:232
swarm_message::swarm_message_mpi_recv
subroutine, public swarm_message_mpi_recv(msg, group, src, tag)
Receives a swarm message via MPI.
Definition: swarm_message.F:206
swarm_message::swarm_message_file_write
subroutine, public swarm_message_file_write(msg, unit)
Write a swarm-message to a given file / unit.
Definition: swarm_message.F:270
swarm_message::swarm_message_equal
logical function, public swarm_message_equal(msg1, msg2)
Checks if two swarm-messages are equal.
Definition: swarm_message.F:166
swarm_message::swarm_message_haskey
logical function, public swarm_message_haskey(msg, key)
Checks if a swarm-message contains an entry with the given key.
Definition: swarm_message.F:110
swarm_message::swarm_message_free
subroutine, public swarm_message_free(msg)
Deallocates all entries contained in a swarm-message.
Definition: swarm_message.F:133
swarm_message::swarm_message_file_read
subroutine, public swarm_message_file_read(msg, parser, at_end)
Reads a swarm-message from a given file / unit.
Definition: swarm_message.F:301