source: palm/trunk/SOURCE/restart_data_mpi_io_mod.f90 @ 4539

Last change on this file since 4539 was 4539, checked in by raasch, 11 months ago

checks added, if index limits in header are exceeded (restart_data_mpi_io_mod), bugfix in rrd_mpi_io_int_2d, location and log_point names added/modified, cpu time per grid point and timestep does not included initialization and spinup any more (cpulog_mod)

  • Property svn:keywords set to Id
File size: 94.3 KB
Line 
1!> @file restart_data_mpi_io_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
6! Public License as published by the Free Software Foundation, either version 3 of the License, or
7! (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
10! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
11! Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with PALM. If not, see
14! <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2020 Leibniz Universitaet Hannover
17! -------------------------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21!
22!
23! Former revisions:
24! -----------------
25! $Id: restart_data_mpi_io_mod.f90 4539 2020-05-18 14:05:17Z raasch $
26! checks added, if index limits in header are exceeded
27! bugfix in rrd_mpi_io_int_2d
28!
29! 4536 2020-05-17 17:24:13Z raasch
30! messages and debug output converted to PALM routines
31!
32! 4534 2020-05-14 18:35:22Z raasch
33! I/O on reduced number of cores added (using shared memory MPI)
34!
35! 4500 2020-04-17 10:12:45Z suehring
36! Fix too long lines
37!
38! 4498 2020-04-15 14:26:31Z raasch
39! bugfix for creation of filetypes, argument removed from rd_mpi_io_open
40!
41! 4497 2020-04-15 10:20:51Z raasch
42! last bugfix deactivated because of compile problems
43!
44! 4496 2020-04-15 08:37:26Z raasch
45! problem with posix read arguments for surface data fixed
46!
47! 4495 2020-04-13 20:11:20Z raasch
48! Initial version (K. Ketelsen), adjusted to PALM formatting standards (s. Raasch)
49!
50!
51!
52! Description:
53! ------------
54!> Routines for restart data handling using MPI-IO.
55!--------------------------------------------------------------------------------------------------!
56 MODULE restart_data_mpi_io_mod
57
58#if defined( __parallel )
59#if defined( __mpifh )
60    INCLUDE "mpif.h"
61#else
62    USE MPI
63#endif
64#else
65    USE posix_interface,                                                                           &
66        ONLY:  posix_close, posix_lseek, posix_open, posix_read, posix_write
67#endif
68
69    USE, INTRINSIC ::  ISO_C_BINDING
70
71    USE control_parameters,                                                                        &
72        ONLY:  debug_output, debug_string, include_total_domain_boundaries, message_string,        &
73               restart_data_format_input, restart_data_format_output, restart_file_size
74
75    USE exchange_horiz_mod,                                                                        &
76        ONLY:  exchange_horiz, exchange_horiz_2d
77
78    USE indices,                                                                                   &
79        ONLY:  nbgp, nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, nzb, nzt
80
81    USE kinds
82
83    USE pegrid,                                                                                    &
84        ONLY:  comm1dx, comm1dy, comm2d, myid, myidx, myidy, npex, npey, numprocs, pdims
85
86    USE shared_memory_io_mod,                                                                      &
87        ONLY:  local_boundaries, sm_class
88
89
90    IMPLICIT NONE
91
92    CHARACTER(LEN=128) :: io_file_name  !> internal variable to communicate filename between
93                                        !> different subroutines
94
95#if defined( __parallel )
96    INTEGER(iwp)            ::  ierr                              !< error status of MPI-calls
97    INTEGER(iwp), PARAMETER ::  rd_offset_kind = MPI_OFFSET_KIND  !< Adress or Offset kind
98    INTEGER(iwp), PARAMETER ::  rd_status_size = MPI_STATUS_SIZE  !<
99#else
100    INTEGER(iwp), PARAMETER ::  rd_offset_kind = C_SIZE_T         !<
101    INTEGER(iwp), PARAMETER ::  rd_status_size = 1       !< Not required in sequential mode
102#endif
103
104    INTEGER(iwp)            ::  debug_level = 1 !< TODO: replace with standard debug output steering
105
106    INTEGER(iwp)            ::  comm_io       !< Communicator for MPI-IO
107    INTEGER(iwp)            ::  fh            !< MPI-IO file handle
108#if defined( __parallel )
109    INTEGER(iwp)            ::  fhs = -1      !< MPI-IO file handle to open file with comm2d always
110#endif
111    INTEGER(iwp)            ::  ft_surf = -1  !< MPI filetype surface data
112#if defined( __parallel )
113    INTEGER(iwp)            ::  ft_2di_nb     !< MPI filetype 2D array INTEGER no outer boundary
114    INTEGER(iwp)            ::  ft_2d         !< MPI filetype 2D array REAL with outer boundaries
115    INTEGER(iwp)            ::  ft_3d         !< MPI filetype 3D array REAL with outer boundaries
116    INTEGER(iwp)            ::  ft_3dsoil     !< MPI filetype for 3d-soil array
117#endif
118    INTEGER(iwp)            ::  glo_start     !< global start index on this PE
119#if defined( __parallel )
120    INTEGER(iwp)            ::  local_start   !<
121#endif
122    INTEGER(iwp)            ::  nr_iope       !<
123    INTEGER(iwp)            ::  nr_val        !< local number of values in x and y direction
124#if defined( __parallel )
125    INTEGER(iwp)            ::  win_2di
126    INTEGER(iwp)            ::  win_2dr
127    INTEGER(iwp)            ::  win_3dr
128    INTEGER(iwp)            ::  win_3ds
129    INTEGER(iwp)            ::  win_surf = -1
130#endif
131    INTEGER(iwp)            ::  total_number_of_surface_values    !< total number of values for one variable
132
133    INTEGER(KIND=rd_offset_kind) ::  array_position   !<
134    INTEGER(KIND=rd_offset_kind) ::  header_position  !<
135
136    INTEGER(iwp), DIMENSION(:,:), POINTER, CONTIGUOUS ::  array_2di  !<
137
138    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_end_index     !<
139    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_start_index   !<
140    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_global_start  !<
141
142    LOGICAL ::  all_pes_write                     !< all PEs have data to write
143    LOGICAL ::  filetypes_created                 !<
144    LOGICAL ::  io_on_limited_cores_per_node      !< switch to shared memory MPI-IO
145    LOGICAL ::  rd_flag                           !< file is opened for read
146    LOGICAL ::  wr_flag                           !< file is opened for write
147
148#if defined( __parallel )
149    REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS     ::  array_1d       !<
150#endif
151    REAL(wp), DIMENSION(:,:), POINTER, CONTIGUOUS   ::  array_2d       !<
152    REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS ::  array_3d       !<
153    REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS ::  array_3d_soil  !<
154
155!
156!-- Handling of outer boundaries
157    TYPE(local_boundaries) ::  lb  !<
158
159!
160!-- General Header (first 32 byte in restart file)
161    TYPE general_header
162       INTEGER(iwp) :: nr_int         !< number of INTEGER entries in header
163       INTEGER(iwp) :: nr_char        !< number of Text strings entries in header
164       INTEGER(iwp) :: nr_real        !< number of REAL entries in header
165       INTEGER(iwp) :: nr_arrays      !< number of arrays in restart files
166       INTEGER(iwp) :: total_nx       !< total number of points in x-direction
167       INTEGER(iwp) :: total_ny       !< total number of points in y-direction
168       INTEGER(iwp) :: i_outer_bound  !< if 1, outer boundaries are stored in restart file
169       INTEGER(iwp) :: endian         !< little endian (1) or big endian (2) internal format
170    END TYPE general_header
171
172    TYPE(general_header), TARGET ::  tgh
173
174    TYPE(sm_class)               ::  sm_io
175
176!
177!-- Declaration of varibales for file header section
178    INTEGER(KIND=rd_offset_kind)                ::  header_int_index
179    INTEGER, PARAMETER                          ::  max_nr_int=256
180    CHARACTER(LEN=32), DIMENSION(max_nr_int)    ::  int_names
181    INTEGER(KIND=iwp), DIMENSION(max_nr_int)    ::  int_values
182
183    INTEGER(KIND=rd_offset_kind)                ::  header_char_index
184    INTEGER, PARAMETER                          ::  max_nr_char=128
185    CHARACTER(LEN=128), DIMENSION(max_nr_char)  ::  text_lines
186
187    INTEGER(KIND=rd_offset_kind)                ::  header_real_index
188    INTEGER, PARAMETER                          ::  max_nr_real=256
189    CHARACTER(LEN=32), DIMENSION(max_nr_real)   ::  real_names
190    REAL(KIND=wp), DIMENSION(max_nr_real)       ::  real_values
191
192    INTEGER(KIND=rd_offset_kind)                ::  header_array_index
193    INTEGER, PARAMETER                          ::  max_nr_arrays=600
194    CHARACTER(LEN=32), DIMENSION(max_nr_arrays) ::  array_names
195    INTEGER(KIND=rd_offset_kind), DIMENSION(max_nr_arrays) :: array_offset
196
197    SAVE
198
199    PRIVATE
200
201    PUBLIC  restart_file_size, total_number_of_surface_values
202
203!
204!-- PALM interfaces
205    INTERFACE rd_mpi_io_check_array
206       MODULE PROCEDURE rd_mpi_io_check_array
207    END INTERFACE rd_mpi_io_check_array
208
209    INTERFACE rd_mpi_io_close
210       MODULE PROCEDURE rd_mpi_io_close
211    END INTERFACE rd_mpi_io_close
212
213    INTERFACE rd_mpi_io_open
214       MODULE PROCEDURE rd_mpi_io_open
215    END INTERFACE rd_mpi_io_open
216
217    INTERFACE rrd_mpi_io
218       MODULE PROCEDURE rrd_mpi_io_char
219       MODULE PROCEDURE rrd_mpi_io_int
220       MODULE PROCEDURE rrd_mpi_io_int_2d
221       MODULE PROCEDURE rrd_mpi_io_logical
222       MODULE PROCEDURE rrd_mpi_io_real
223       MODULE PROCEDURE rrd_mpi_io_real_2d
224       MODULE PROCEDURE rrd_mpi_io_real_3d
225       MODULE PROCEDURE rrd_mpi_io_real_3d_soil
226    END INTERFACE rrd_mpi_io
227
228    INTERFACE rrd_mpi_io_global_array
229       MODULE PROCEDURE rrd_mpi_io_global_array_int_1d
230       MODULE PROCEDURE rrd_mpi_io_global_array_real_1d
231       MODULE PROCEDURE rrd_mpi_io_global_array_real_2d
232       MODULE PROCEDURE rrd_mpi_io_global_array_real_3d
233       MODULE PROCEDURE rrd_mpi_io_global_array_real_4d
234    END INTERFACE rrd_mpi_io_global_array
235
236    INTERFACE rrd_mpi_io_surface
237       MODULE PROCEDURE rrd_mpi_io_surface
238       MODULE PROCEDURE rrd_mpi_io_surface_2d
239    END INTERFACE rrd_mpi_io_surface
240
241    INTERFACE rd_mpi_io_surface_filetypes
242       MODULE PROCEDURE rd_mpi_io_surface_filetypes
243    END INTERFACE rd_mpi_io_surface_filetypes
244
245    INTERFACE wrd_mpi_io
246       MODULE PROCEDURE wrd_mpi_io_char
247       MODULE PROCEDURE wrd_mpi_io_int
248       MODULE PROCEDURE wrd_mpi_io_int_2d
249       MODULE PROCEDURE wrd_mpi_io_logical
250       MODULE PROCEDURE wrd_mpi_io_real
251       MODULE PROCEDURE wrd_mpi_io_real_2d
252       MODULE PROCEDURE wrd_mpi_io_real_3d
253       MODULE PROCEDURE wrd_mpi_io_real_3d_soil
254    END INTERFACE wrd_mpi_io
255
256    INTERFACE wrd_mpi_io_global_array
257       MODULE PROCEDURE wrd_mpi_io_global_array_int_1d
258       MODULE PROCEDURE wrd_mpi_io_global_array_real_1d
259       MODULE PROCEDURE wrd_mpi_io_global_array_real_2d
260       MODULE PROCEDURE wrd_mpi_io_global_array_real_3d
261       MODULE PROCEDURE wrd_mpi_io_global_array_real_4d
262    END INTERFACE wrd_mpi_io_global_array
263
264    INTERFACE wrd_mpi_io_surface
265       MODULE PROCEDURE wrd_mpi_io_surface
266       MODULE PROCEDURE wrd_mpi_io_surface_2d
267    END INTERFACE wrd_mpi_io_surface
268
269    PUBLIC  rd_mpi_io_check_array, rd_mpi_io_close, rd_mpi_io_open, rrd_mpi_io,                    &
270            rrd_mpi_io_global_array, rrd_mpi_io_surface, rd_mpi_io_surface_filetypes, wrd_mpi_io,  &
271            wrd_mpi_io_global_array, wrd_mpi_io_surface
272
273
274 CONTAINS
275
276
277!--------------------------------------------------------------------------------------------------!
278! Description:
279! ------------
280!> Open restart file for read or write with MPI-IO
281!--------------------------------------------------------------------------------------------------!
282 SUBROUTINE rd_mpi_io_open( action, file_name, open_for_global_io_only )
283
284    IMPLICIT NONE
285
286    CHARACTER(LEN=*), INTENT(IN)  ::  action                           !<
287    CHARACTER(LEN=*), INTENT(IN)  ::  file_name                        !<
288
289    INTEGER(iwp)                  ::  i                                !<
290    INTEGER(iwp)                  ::  gh_size                          !<
291
292    INTEGER(KIND=rd_offset_kind)  ::  offset                           !<
293
294#if defined( __parallel )
295    INTEGER, DIMENSION(rd_status_size) ::  status                      !<
296#endif
297
298    LOGICAL, INTENT(IN), OPTIONAL ::  open_for_global_io_only          !<
299    LOGICAL                       ::  set_filetype                     !<
300
301#if ! defined( __parallel )
302    TYPE(C_PTR)                   ::  buf_ptr                          !<
303#endif
304
305
306    offset = 0
307    io_on_limited_cores_per_node = .FALSE.
308
309    rd_flag = ( TRIM( action ) == 'READ'  .OR. TRIM( action ) == 'read'  )
310    wr_flag = ( TRIM( action ) == 'WRITE' .OR. TRIM( action ) == 'write' )
311
312    IF ( .NOT. ( rd_flag .OR. wr_flag ) )  THEN
313       message_string = 'illegal action "' // TRIM( action ) // '" for opening restart files'
314       CALL message( 'restart_data_mpi_io_mod', 'PA0720', 1, 2, 0, 6, 0 )
315    ENDIF
316!
317!-- Store name of I/O file to communicate it internally within this module.
318    io_file_name = file_name
319!
320!-- Setup for IO on a limited number of threads per node (using shared memory MPI)
321    IF ( rd_flag )  THEN
322       set_filetype = .TRUE.
323       IF ( TRIM( restart_data_format_input ) == 'mpi_shared_memory' )  THEN
324          io_on_limited_cores_per_node = .TRUE.
325       ENDIF
326    ENDIF
327
328    IF ( TRIM( restart_data_format_output ) == 'mpi_shared_memory' .AND.  wr_flag )  THEN
329       io_on_limited_cores_per_node = .TRUE.
330    ENDIF
331!
332!-- Shared memory MPI is not used for reading of global data
333    IF ( PRESENT( open_for_global_io_only )  .AND.  rd_flag )  THEN
334       IF ( open_for_global_io_only )  THEN
335          io_on_limited_cores_per_node = .FALSE.
336          set_filetype                 = .FALSE.
337       ENDIF
338    ENDIF
339
340    CALL sm_io%sm_init_comm( io_on_limited_cores_per_node )
341
342!
343!-- Set communicator to be used. If all cores are doing I/O, comm2d is used as usual.
344    IF( sm_io%is_sm_active() )  THEN
345       comm_io = sm_io%comm_io
346    ELSE
347       comm_io = comm2d
348    ENDIF
349
350!
351!-- Create subarrays and file types
352    filetypes_created = .FALSE.
353
354!
355!-- In case of read it is not known yet if data include total domain. Filetypes will be created
356!-- further below.
357    IF ( wr_flag )  THEN
358       CALL rd_mpi_io_create_filetypes
359       filetypes_created = .TRUE.
360    ENDIF
361
362!
363!-- Open file for MPI-IO
364#if defined( __parallel )
365    IF ( sm_io%iam_io_pe )  THEN
366
367       IF ( rd_flag )  THEN
368
369          IF ( debug_output )  THEN
370             WRITE( debug_string, * )  'open joint restart file "' // TRIM( io_file_name ) //      &
371                                       '" for read with MPI-IO'
372             CALL debug_message( debug_string, 'start' )
373          ENDIF
374
375          CALL MPI_FILE_OPEN( comm_io, TRIM( io_file_name ), MPI_MODE_RDONLY, MPI_INFO_NULL, fh,   &
376                              ierr )
377
378          IF ( ierr /= 0 )  THEN
379             message_string = 'error opening restart file "' // TRIM( io_file_name ) //      &
380                              '" for reading with MPI-IO'
381             CALL message( 'rrd_mpi_io_open', 'PA0727', 3, 2, 0, 6, 0 )
382          ENDIF
383
384          IF ( debug_output )  THEN
385             WRITE( debug_string, * )  'open joint restart file "' // TRIM( io_file_name ) //      &
386                                       '" for read with MPI-IO'
387             CALL debug_message( debug_string, 'end' )
388          ENDIF
389
390       ELSEIF ( wr_flag )  THEN
391
392          IF ( debug_output )  THEN
393             WRITE( debug_string, * )  'open joint restart file "' // TRIM( io_file_name ) //      &
394                                       '" for write with MPI-IO'
395             CALL debug_message( debug_string, 'start' )
396          ENDIF
397
398          CALL MPI_FILE_OPEN( comm_io, TRIM( io_file_name ), MPI_MODE_CREATE+MPI_MODE_WRONLY,      &
399                              MPI_INFO_NULL, fh, ierr )
400
401          IF ( ierr /= 0 )  THEN
402             message_string = 'error opening restart file "' // TRIM( io_file_name ) //      &
403                              '" for writing with MPI-IO'
404             CALL message( 'rrd_mpi_io_open', 'PA0728', 3, 2, 0, 6, 0 )
405          ENDIF
406
407          IF ( debug_output )  THEN
408             WRITE( debug_string, * )  'open joint restart file "' // TRIM( io_file_name ) //      &
409                                       '" for write with MPI-IO'
410             CALL debug_message( debug_string, 'end' )
411          ENDIF
412
413       ENDIF
414
415    ENDIF
416#else
417    IF ( rd_flag )  THEN
418
419       IF ( debug_output )  THEN
420          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
421                                    '" for read in serial mode (posix)'
422          CALL debug_message( debug_string, 'start' )
423       ENDIF
424
425       fh = posix_open( TRIM( io_file_name ), .TRUE. )
426
427       IF ( debug_output )  THEN
428          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
429                                    '" for read in serial mode (posix)'
430          CALL debug_message( debug_string, 'end' )
431       ENDIF
432
433    ELSEIF ( wr_flag )  THEN
434
435       IF ( debug_output )  THEN
436          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
437                                    '" for write in serial mode (posix)'
438          CALL debug_message( debug_string, 'start' )
439       ENDIF
440
441       fh = posix_open( TRIM( io_file_name ), .FALSE. )
442
443       IF ( debug_output )  THEN
444          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
445                                    '" for write in serial mode (posix)'
446          CALL debug_message( debug_string, 'end' )
447       ENDIF
448
449    ENDIF
450
451    IF ( fh < 0 )  THEN
452       message_string = 'error opening restart file for posix I/O'
453       CALL message( 'restart_data_mpi_io_mod', 'PA0721', 1, 2, 0, 6, 0 )
454    ENDIF
455#endif
456
457    array_position  = 65536          !> Start offset for writing 2-D and 3.D arrays at 64 k
458    header_position = 0
459
460    header_int_index   = 1
461    header_char_index  = 1
462    header_real_index  = 1
463    header_array_index = 1
464
465    int_names    = ' '
466    int_values   = 0
467    text_lines   = ' '
468    real_names   = ' '
469    real_values  = 0.0
470    array_names  = ' '
471    array_offset = 0
472
473    int_names(1)     = 'nx'
474    int_values(1)    = nx
475    int_names(2)     = 'ny'
476    int_values(2)    = ny
477    int_names(3)     = 'nz'
478    int_values(3)    = nz
479    header_int_index = header_int_index+3
480
481    DO   i = 1, max_nr_arrays
482       array_offset(i) = 0
483       array_names(i)  = ' '
484    ENDDO
485
486    gh_size = STORAGE_SIZE( tgh ) / 8
487
488    IF ( rd_flag )  THEN
489       IF ( sm_io%iam_io_pe )  THEN
490!
491!--       File is open for read.
492#if defined( __parallel )
493!--       Set the default view
494          CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
495!
496!--       Read the file header size
497          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
498          CALL MPI_FILE_READ( fh, tgh, gh_size, MPI_BYTE, status, ierr )
499#else
500          CALL posix_lseek( fh, header_position )
501          buf_ptr = C_LOC( tgh )
502          CALL posix_read( fh, buf_ptr, gh_size )
503#endif
504       ENDIF
505#if defined( __parallel )
506       IF ( sm_io%is_sm_active() )  THEN
507          CALL MPI_BCAST( tgh, gh_size, MPI_BYTE, 0, sm_io%comm_shared, ierr )
508       ENDIF
509#endif
510       header_position = header_position + gh_size
511
512       include_total_domain_boundaries = ( tgh%i_outer_bound == 1 )
513
514!
515!--    File types depend on if boundaries of the total domain is included in data. This has been
516!--    checked with the previous statement.
517       IF ( set_filetype )  THEN
518          CALL rd_mpi_io_create_filetypes
519          filetypes_created = .TRUE.
520       ENDIF
521
522       IF ( sm_io%iam_io_pe )  THEN
523#if defined( __parallel )
524!
525!--       Read INTEGER values
526          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
527          CALL MPI_FILE_READ( fh, int_names, SIZE( int_names ) * 32, MPI_CHAR, status, ierr )
528          header_position = header_position + SIZE( int_names ) * 32
529
530          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
531          CALL MPI_FILE_READ (fh, int_values, SIZE( int_values ), MPI_INT, status, ierr )
532          header_position = header_position + SIZE( int_values ) * iwp
533!
534!--       Character entries
535          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
536          CALL MPI_FILE_READ( fh, text_lines, SIZE( text_lines ) * 128, MPI_CHAR, status, ierr )
537          header_position = header_position+size(text_lines) * 128
538!
539!--       REAL values
540          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
541          CALL MPI_FILE_READ( fh, real_names, SIZE( real_names ) * 32, MPI_CHAR, status, ierr )
542          header_position = header_position + SIZE( real_names ) * 32
543
544          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
545          CALL MPI_FILE_READ( fh, real_values, SIZE( real_values ), MPI_REAL, status, ierr )
546          header_position = header_position + SIZE( real_values ) * wp
547!
548!--       2d- and 3d-array headers
549          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
550          CALL MPI_FILE_READ( fh, array_names, SIZE( array_names ) * 32, MPI_CHAR, status, ierr )
551          header_position = header_position + SIZE( array_names ) * 32
552
553          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
554          CALL MPI_FILE_READ( fh, array_offset, SIZE( array_offset ) * MPI_OFFSET_KIND, MPI_BYTE,  &
555                              status,ierr )   ! there is no I*8 datatype in Fortran
556          header_position = header_position + SIZE( array_offset ) * rd_offset_kind
557#else
558          CALL posix_lseek( fh, header_position )
559          CALL posix_read( fh, int_names )
560          header_position = header_position + SIZE( int_names ) * 32
561
562          CALL posix_lseek( fh, header_position )
563          CALL posix_read( fh, int_values, SIZE( int_values ) )
564          header_position = header_position + SIZE( int_values ) * iwp
565!
566!--       Character entries
567          CALL posix_lseek( fh, header_position )
568          CALL posix_read( fh, text_lines )
569          header_position = header_position + SIZE( text_lines ) * 128
570!
571!--       REAL values
572          CALL posix_lseek( fh, header_position )
573          CALL posix_read( fh, real_names )
574          header_position = header_position + SIZE( real_names ) * 32
575
576          CALL posix_lseek( fh, header_position )
577          CALL posix_read( fh, real_values, SIZE( real_values ) )
578          header_position = header_position + SIZE( real_values ) * wp
579!
580!--       2d- and 3d-array headers
581          CALL posix_lseek( fh, header_position )
582          CALL posix_read( fh, array_names )
583          header_position = header_position + SIZE( array_names ) * 32
584
585          CALL posix_lseek( fh, header_position )
586          CALL posix_read( fh, array_offset, SIZE( array_offset ) ) ! there is no I*8 datatype in Fortran
587          header_position = header_position + SIZE( array_offset ) * rd_offset_kind
588#endif
589          IF ( debug_output )  CALL rd_mpi_io_print_header
590
591       ENDIF
592
593#if defined( __parallel )
594!
595!--    Broadcast header to all remaining cores that are not involved in I/O
596       IF ( sm_io%is_sm_active() )  THEN
597!
598!--        Not sure, that it is possible to broadcast CHARACTER array in one MPI_Bcast call
599           DO  i = 1, SIZE( int_names )
600              CALL MPI_BCAST( int_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
601           ENDDO
602           CALL MPI_BCAST( int_values, SIZE( int_values ), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
603
604           DO  i = 1, SIZE( text_lines )
605              CALL MPI_BCAST( text_lines(i), 128, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
606           ENDDO
607
608           DO  i = 1, SIZE( real_names )
609              CALL MPI_BCAST( real_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
610           ENDDO
611           CALL MPI_BCAST( real_values, SIZE( real_values ), MPI_REAL, 0, sm_io%comm_shared, ierr )
612
613           DO  i = 1, SIZE( array_names )
614              CALL MPI_BCAST( array_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
615           ENDDO
616           CALL MPI_BCAST( array_offset, SIZE( array_offset )*8, MPI_BYTE, 0, sm_io%comm_shared,   &
617                           ierr )  ! there is no I*8 datatype in Fortran (array_offset is I*8!)
618
619           CALL MPI_BCAST( header_position, rd_offset_kind, MPI_BYTE, 0, sm_io%comm_shared, ierr )
620
621       ENDIF
622#endif
623
624    ENDIF
625
626 END SUBROUTINE rd_mpi_io_open
627
628
629!--------------------------------------------------------------------------------------------------!
630! Description:
631! ------------
632!> Check, if array exists in restart file
633!--------------------------------------------------------------------------------------------------!
634 SUBROUTINE rd_mpi_io_check_array( name, found )
635
636    IMPLICIT NONE
637
638    CHARACTER(LEN=*), INTENT(IN) ::  name  !<
639
640    INTEGER(iwp) ::  i  !<
641
642    LOGICAl      ::  found  !<
643
644
645    DO  i = 1, tgh%nr_arrays
646       IF ( TRIM( array_names(i) ) == TRIM( name ) )  THEN
647          array_position = array_offset(i)
648          found = .TRUE.
649          RETURN
650       ENDIF
651    ENDDO
652
653    found = .FALSE.
654
655 END SUBROUTINE rd_mpi_io_check_array
656
657
658
659!--------------------------------------------------------------------------------------------------!
660! Description:
661! ------------
662!> Read INTEGER with MPI-IO
663!--------------------------------------------------------------------------------------------------!
664 SUBROUTINE rrd_mpi_io_int( name, value )
665
666    IMPLICIT NONE
667
668    CHARACTER(LEN=*), INTENT(IN)   :: name
669
670    INTEGER(iwp)                   ::  i
671    INTEGER(KIND=iwp), INTENT(OUT) ::  value
672
673    LOGICAL                        ::  found
674
675
676    found = .FALSE.
677    value = 0
678
679    DO  i = 1, tgh%nr_int
680       IF ( TRIM(int_names(i)) == TRIM( name ) )  THEN
681          value = int_values(i)
682          found = .TRUE.
683          EXIT
684       ENDIF
685    ENDDO
686
687    IF ( .NOT. found )  THEN
688       message_string = 'INTEGER variable "' // TRIM( name ) // '" not found in restart file'
689       CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
690    ENDIF
691
692 END SUBROUTINE rrd_mpi_io_int
693
694
695
696!--------------------------------------------------------------------------------------------------!
697! Description:
698! ------------
699!> Read REAL with MPI-IO
700!--------------------------------------------------------------------------------------------------!
701 SUBROUTINE rrd_mpi_io_real( name, value )
702
703    IMPLICIT NONE
704
705    CHARACTER(LEN=*), INTENT(IN)   ::  name
706
707    INTEGER(iwp)                   ::  i
708
709    LOGICAL                        ::  found
710
711    REAL(KIND=wp), INTENT(OUT)     ::  value
712
713
714    found = .FALSE.
715    value = 0.0
716
717    DO  i = 1, tgh%nr_real
718       IF ( TRIM(real_names(i)) == TRIM( name ) )  THEN
719          value = real_values(i)
720          found = .TRUE.
721          EXIT
722       ENDIF
723    ENDDO
724
725    IF ( .NOT. found )  THEN
726       message_string = 'REAL variable "' // TRIM( name ) // '" not found in restart file'
727       CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
728    ENDIF
729
730 END SUBROUTINE rrd_mpi_io_real
731
732
733
734!--------------------------------------------------------------------------------------------------!
735! Description:
736! ------------
737!> Read 2d-real array with MPI-IO
738!--------------------------------------------------------------------------------------------------!
739 SUBROUTINE rrd_mpi_io_real_2d( name, data )
740
741    IMPLICIT NONE
742
743    CHARACTER(LEN=*), INTENT(IN)       ::  name
744
745#if defined( __parallel )
746    INTEGER, DIMENSION(rd_status_size) ::  status
747#endif
748    INTEGER(iwp)                       ::  i
749
750    LOGICAL                            ::  found
751
752    REAL(wp), INTENT(INOUT), DIMENSION(nysg:nyng,nxlg:nxrg) ::  data
753
754
755    found = .FALSE.
756
757    DO  i = 1, tgh%nr_arrays
758       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
759          array_position = array_offset(i)
760          found = .TRUE.
761          EXIT
762       ENDIF
763    ENDDO
764
765    IF ( found )  THEN
766#if defined( __parallel )
767       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
768       IF ( sm_io%iam_io_pe )  THEN
769          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL,   &
770                                  ierr )
771          CALL MPI_FILE_READ_ALL( fh, array_2d, SIZE( array_2d ), MPI_REAL, status, ierr )
772       ENDIF
773       CALL sm_io%sm_node_barrier()
774#else
775       CALL posix_lseek( fh, array_position )
776       CALL posix_read( fh, array_2d, SIZE( array_2d ) )
777#endif
778
779       IF ( include_total_domain_boundaries)  THEN
780          DO  i = lb%nxl, lb%nxr
781             data(lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_2d(i,lb%nys:lb%nyn)
782          ENDDO
783          IF ( debug_level >= 2)  WRITE(9,*) 'r2f_ob ', TRIM(name),' ', SUM( data(nys:nyn,nxl:nxr) )
784       ELSE
785          DO  i = nxl, nxr
786             data(nys:nyn,i) = array_2d(i,nys:nyn)
787          ENDDO
788          IF ( debug_level >= 2) WRITE(9,*) 'r2f ', TRIM( name ),' ', SUM( data(nys:nyn,nxl:nxr) )
789       ENDIF
790
791       CALL exchange_horiz_2d( data )
792
793    ELSE
794       message_string = '2d-REAL array "' // TRIM( name ) // '" not found in restart file'
795       CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
796    ENDIF
797
798 END SUBROUTINE rrd_mpi_io_real_2d
799
800
801
802!--------------------------------------------------------------------------------------------------!
803! Description:
804! ------------
805!> Read 2d-INTEGER array with MPI-IO
806!--------------------------------------------------------------------------------------------------!
807 SUBROUTINE rrd_mpi_io_int_2d( name, data )
808
809    IMPLICIT NONE
810
811    CHARACTER(LEN=*), INTENT(IN)        ::  name
812
813    INTEGER(iwp)                        ::  i
814    INTEGER(iwp)                        ::  j
815
816#if defined( __parallel )
817    INTEGER, DIMENSION(rd_status_size)  ::  status
818#endif
819
820    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:,:) ::  data
821
822    LOGICAL                             ::  found
823
824
825    found = .FALSE.
826
827    DO  i = 1, tgh%nr_arrays
828       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
829          array_position = array_offset(i)
830          found = .TRUE.
831          EXIT
832       ENDIF
833    ENDDO
834
835    IF ( found )  THEN
836
837       IF ( ( nxr - nxl + 1 + 2*nbgp ) == SIZE( data, 2 ) )  THEN
838!
839!--       Output array with Halos.
840!--       ATTENTION: INTEGER array with ghost boundaries are not implemented yet. This kind of array
841!--                  would be dimensioned in the caller subroutine like this:
842!--                  INTEGER, DIMENSION(nysg:nyng,nxlg:nxrg)::  data
843          message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be read from restart ' // &
844                           'file is defined with illegal dimensions in the PALM code'
845          CALL message( 'rrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
846
847       ELSEIF ( (nxr-nxl+1) == SIZE( data, 2 ) )  THEN
848!
849!--       INTEGER input array without Halos.
850!--       This kind of array is dimensioned in the caller subroutine
851!--       INTEGER, DIMENSION(nys:nyn,nxl:nxr) ::  data
852
853#if defined( __parallel )
854          CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
855          IF ( sm_io%iam_io_pe )  THEN
856             CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native',         &
857                                     MPI_INFO_NULL, ierr )
858             CALL MPI_FILE_READ_ALL( fh, array_2di, SIZE( array_2di ), MPI_INTEGER, status, ierr )
859          ENDIF
860          CALL sm_io%sm_node_barrier()
861#else
862          CALL posix_lseek( fh, array_position )
863          CALL posix_read( fh, array_2di, SIZE( array_2di ) )
864#endif
865
866          DO  j = nys, nyn
867             DO  i = nxl, nxr
868                data(j-nys+1,i-nxl+1) = array_2di(i,j)
869             ENDDO
870          ENDDO
871
872       ELSE
873
874          message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be read from restart ' // &
875                           'file is defined with illegal dimensions in the PALM code'
876          CALL message( 'rrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
877
878       ENDIF
879
880    ELSE
881
882       message_string = '2d-INTEGER array "' // TRIM( name ) // '" not found in restart file'
883       CALL message( 'rrd_mpi_io_int_2d', 'PA0722', 3, 2, 0, 6, 0 )
884
885    ENDIF
886
887 END SUBROUTINE rrd_mpi_io_int_2d
888
889
890
891!--------------------------------------------------------------------------------------------------!
892! Description:
893! ------------
894!> Read 2d-REAL array with MPI-IO
895!--------------------------------------------------------------------------------------------------!
896 SUBROUTINE rrd_mpi_io_real_3d( name, data )
897
898    IMPLICIT NONE
899
900    CHARACTER(LEN=*), INTENT(IN)       ::  name
901
902    INTEGER(iwp)                       ::  i
903
904#if defined( __parallel )
905    INTEGER, DIMENSION(rd_status_size) ::  status
906#endif
907
908    LOGICAL                            ::  found
909
910    REAL(wp), INTENT(INOUT), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  data
911
912
913    found = .FALSE.
914
915    DO  i = 1, tgh%nr_arrays
916       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
917          array_position = array_offset(i)
918          found = .TRUE.
919          EXIT
920       ENDIF
921    ENDDO
922
923    IF ( found )  THEN
924#if defined( __parallel )
925       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
926       IF( sm_io%iam_io_pe )  THEN
927          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL,    &
928                                  ierr )
929          CALL MPI_FILE_READ_ALL( fh, array_3d, SIZE( array_3d ), MPI_REAL, status, ierr )
930       ENDIF
931       CALL sm_io%sm_node_barrier()
932#else
933       CALL posix_lseek( fh, array_position )
934       CALL posix_read(fh, array_3d, SIZE( array_3d ) )
935#endif
936       IF ( include_total_domain_boundaries)  THEN
937          DO  i = lb%nxl, lb%nxr
938             data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_3d(:,i,lb%nys:lb%nyn)
939          ENDDO
940       ELSE
941          DO  i = nxl, nxr
942             data(:,nys:nyn,i) = array_3d(:,i,nys:nyn)
943          ENDDO
944       ENDIF
945
946       CALL exchange_horiz( data, nbgp )
947
948    ELSE
949
950       message_string = '3d-REAL array "' // TRIM( name ) // '" not found in restart file'
951       CALL message( 'rrd_mpi_io_real_3d', 'PA0722', 3, 2, 0, 6, 0 )
952
953    ENDIF
954
955 END SUBROUTINE rrd_mpi_io_real_3d
956
957
958
959!--------------------------------------------------------------------------------------------------!
960! Description:
961! ------------
962!> Read 3d-REAL soil array with MPI-IO
963!> nzb_soil, nzt_soil are located in the module land_surface_model_mod. Since Fortran does not allow
964!> cross referencing of module variables, it is required to pass these variables as arguments.
965!--------------------------------------------------------------------------------------------------!
966 SUBROUTINE rrd_mpi_io_real_3d_soil( name, data, nzb_soil, nzt_soil )
967
968    IMPLICIT NONE
969
970    CHARACTER(LEN=*), INTENT(IN)       ::  name
971
972    INTEGER(iwp)                       ::  i
973    INTEGER, INTENT(IN)                ::  nzb_soil
974    INTEGER, INTENT(IN)                ::  nzt_soil
975
976#if defined( __parallel )
977    INTEGER, DIMENSION(rd_status_size) ::  status
978#endif
979
980    LOGICAL                            ::  found
981
982    REAL(wp), INTENT(INOUT), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) ::  data
983
984
985    found = .FALSE.
986
987    DO  i = 1, tgh%nr_arrays
988       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
989          array_position = array_offset(i)
990          found = .TRUE.
991          EXIT
992       ENDIF
993    ENDDO
994
995    IF ( found )  THEN
996#if defined( __parallel )
997       CALL rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
998       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
999       IF ( sm_io%iam_io_pe )  THEN
1000          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL,&
1001                                  ierr )
1002          CALL MPI_FILE_READ_ALL( fh, array_3d_soil, SIZE( array_3d_soil ), MPI_REAL, status, ierr )
1003          CALL MPI_TYPE_FREE( ft_3dsoil, ierr )
1004       ENDIF
1005       CALL sm_io%sm_node_barrier()
1006#else
1007       CALL posix_lseek( fh, array_position )
1008       CALL posix_read( fh, array_3d_soil, SIZE( array_3d_soil ) )
1009#endif
1010       IF ( include_total_domain_boundaries )  THEN
1011          DO  i = lb%nxl, lb%nxr
1012             data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_3d(:,i,lb%nys:lb%nyn)
1013          ENDDO
1014       ELSE
1015          DO  i = nxl, nxr
1016             data(:,nys:nyn,i) = array_3d(:,i,nys:nyn)
1017          ENDDO
1018       ENDIF
1019
1020    ELSE
1021
1022       message_string = '3d-REAL soil array "' // TRIM( name ) // '" not found in restart file'
1023       CALL message( 'rrd_mpi_io_real_3d_soil', 'PA0722', 3, 2, 0, 6, 0 )
1024
1025    ENDIF
1026
1027 END SUBROUTINE rrd_mpi_io_real_3d_soil
1028
1029
1030
1031!--------------------------------------------------------------------------------------------------!
1032! Description:
1033! ------------
1034!> Read CHARACTER with MPI-IO
1035!--------------------------------------------------------------------------------------------------!
1036 SUBROUTINE rrd_mpi_io_char( name, text )
1037
1038    IMPLICIT NONE
1039
1040    CHARACTER(LEN=*), INTENT(IN)   ::  name
1041    CHARACTER(LEN=*), INTENT(OUT)  ::  text
1042    CHARACTER(LEN=128)             ::  line
1043
1044    INTEGER(iwp)                   ::  i
1045
1046    LOGICAL                        ::  found
1047
1048
1049    found = .FALSE.
1050    text = ' '
1051
1052    DO  i = 1, tgh%nr_char
1053       line = text_lines(i)
1054       IF ( TRIM( line(1:32) ) == TRIM( name ) )  THEN
1055          text = line(33:)
1056          found = .TRUE.
1057          EXIT
1058       ENDIF
1059    ENDDO
1060
1061    IF ( .NOT. found )  THEN
1062       message_string = 'CHARACTER variable "' // TRIM( name ) // '" not found in restart file'
1063       CALL message( 'rrd_mpi_io_char', 'PA0722', 3, 2, 0, 6, 0 )
1064    ENDIF
1065
1066 END SUBROUTINE rrd_mpi_io_char
1067
1068
1069
1070!--------------------------------------------------------------------------------------------------!
1071! Description:
1072! ------------
1073!> Read LOGICAL with MPI-IO
1074!--------------------------------------------------------------------------------------------------!
1075 SUBROUTINE rrd_mpi_io_logical( name, value )
1076
1077    IMPLICIT NONE
1078
1079    CHARACTER(LEN=*), INTENT(IN) ::  name
1080
1081    INTEGER(iwp)                 ::  logical_as_integer
1082
1083    LOGICAL, INTENT(OUT)         ::  value
1084
1085
1086    CALL rrd_mpi_io_int( name, logical_as_integer )
1087    value = ( logical_as_integer == 1 )
1088
1089 END SUBROUTINE rrd_mpi_io_logical
1090
1091
1092
1093!--------------------------------------------------------------------------------------------------!
1094! Description:
1095! ------------
1096!> Write INTEGER with MPI-IO
1097!--------------------------------------------------------------------------------------------------!
1098 SUBROUTINE wrd_mpi_io_int( name, value )
1099
1100    IMPLICIT NONE
1101
1102    CHARACTER(LEN=*), INTENT(IN)  ::  name
1103
1104    INTEGER(KIND=iwp), INTENT(IN) ::  value
1105
1106
1107    IF ( header_int_index == max_nr_int )  THEN
1108       STOP '+++ maximum number of INTEGER entries in restart file header exceeded'
1109    ENDIF
1110
1111    int_names(header_int_index)  = name
1112    int_values(header_int_index) = value
1113    header_int_index = header_int_index + 1
1114
1115 END SUBROUTINE wrd_mpi_io_int
1116
1117
1118
1119 SUBROUTINE wrd_mpi_io_real( name, value )
1120
1121    IMPLICIT NONE
1122
1123    CHARACTER(LEN=*), INTENT(IN) ::  name
1124
1125    REAL(wp), INTENT(IN)         ::  value
1126
1127
1128    IF ( header_real_index == max_nr_real )  THEN
1129       STOP '+++ maximum number of REAL entries in restart file header exceeded'
1130    ENDIF
1131
1132    real_names(header_real_index)  = name
1133    real_values(header_real_index) = value
1134    header_real_index = header_real_index + 1
1135
1136 END SUBROUTINE wrd_mpi_io_real
1137
1138
1139
1140!--------------------------------------------------------------------------------------------------!
1141! Description:
1142! ------------
1143!> Write 2d-REAL array with MPI-IO
1144!--------------------------------------------------------------------------------------------------!
1145 SUBROUTINE wrd_mpi_io_real_2d( name, data )
1146
1147    IMPLICIT NONE
1148
1149    CHARACTER(LEN=*), INTENT(IN)       ::  name
1150
1151    INTEGER(iwp)                       ::  i
1152
1153#if defined( __parallel )
1154    INTEGER, DIMENSION(rd_status_size) ::  status
1155#endif
1156
1157    REAL(wp), INTENT(IN), DIMENSION(nysg:nyng,nxlg:nxrg)    :: data
1158
1159
1160    IF ( header_array_index == max_nr_arrays )  THEN
1161       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1162    ENDIF
1163
1164    array_names(header_array_index)  = name
1165    array_offset(header_array_index) = array_position
1166    header_array_index = header_array_index + 1
1167
1168    IF ( include_total_domain_boundaries )  THEN
1169!
1170!--    Prepare Output with outer boundaries
1171       DO  i = lb%nxl, lb%nxr
1172          array_2d(i,lb%nys:lb%nyn) = data(lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1173       ENDDO
1174
1175    ELSE
1176!
1177!--    Prepare Output without outer boundaries
1178       DO  i = nxl,nxr
1179          array_2d(i,lb%nys:lb%nyn) = data(nys:nyn,i)
1180       ENDDO
1181
1182    ENDIF
1183
1184#if defined( __parallel )
1185    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
1186    IF ( sm_io%iam_io_pe )  THEN
1187       CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL, ierr )
1188       CALL MPI_FILE_WRITE_ALL( fh, array_2d, SIZE( array_2d), MPI_REAL, status, ierr )
1189    ENDIF
1190    CALL sm_io%sm_node_barrier()
1191#else
1192    CALL posix_lseek( fh, array_position )
1193    CALL posix_write( fh, array_2d, SIZE( array_2d ) )
1194#endif
1195!
1196!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1197!-- Maybe a compiler problem.
1198    array_position = array_position + ( INT( lb%ny, KIND=rd_offset_kind ) + 1 ) *                  &
1199                                      ( INT( lb%nx, KIND=rd_offset_kind ) + 1 ) * wp
1200
1201 END SUBROUTINE wrd_mpi_io_real_2d
1202
1203
1204
1205!--------------------------------------------------------------------------------------------------!
1206! Description:
1207! ------------
1208!> Write 2d-INTEGER array with MPI-IO
1209!--------------------------------------------------------------------------------------------------!
1210 SUBROUTINE wrd_mpi_io_int_2d( name, data )
1211
1212    IMPLICIT NONE
1213
1214    CHARACTER(LEN=*), INTENT(IN)                  ::  name
1215
1216    INTEGER(iwp)                                  ::  i
1217    INTEGER(iwp)                                  ::  j
1218
1219#if defined( __parallel )
1220    INTEGER, DIMENSION(rd_status_size)            ::  status
1221#endif
1222    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:,:) ::  data
1223
1224
1225    IF ( header_array_index == max_nr_arrays )  THEN
1226       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1227    ENDIF
1228
1229    array_names(header_array_index)  = name
1230    array_offset(header_array_index) = array_position
1231    header_array_index = header_array_index + 1
1232
1233    IF ( ( nxr-nxl + 1 + 2 * nbgp ) == SIZE( data, 2 ) )  THEN
1234!
1235!--    Integer arrays with ghost layers are not implemented yet. These kind of arrays would be
1236!--    dimensioned in the caller subroutine as
1237!--    INTEGER, DIMENSION(nysg:nyng,nxlg:nxrg) ::  data
1238       message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be written to restart ' //   &
1239                        'file is defined with illegal dimensions in the PALM code'
1240       CALL message( 'wrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
1241
1242    ELSEIF ( ( nxr-nxl+1 ) == SIZE( data, 2 ) )  THEN
1243!
1244!--    INTEGER input array without ghost layers.
1245!--    This kind of array is dimensioned in the caller subroutine as
1246!--    INTEGER, DIMENSION(nys:nyn,nxl:nxr) ::  data
1247       DO  j = nys, nyn
1248          DO  i = nxl, nxr
1249             array_2di(i,j) = data(j-nys+1,i-nxl+1)
1250          ENDDO
1251       ENDDO
1252#if defined( __parallel )
1253       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
1254       IF ( sm_io%iam_io_pe )  THEN
1255          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native',            &
1256                                  MPI_INFO_NULL, ierr )
1257          CALL MPI_FILE_WRITE_ALL( fh, array_2di, SIZE( array_2di ), MPI_INTEGER, status, ierr )
1258       ENDIF
1259       CALL sm_io%sm_node_barrier()
1260#else
1261       CALL posix_lseek( fh, array_position )
1262       CALL posix_write( fh, array_2di, SIZE( array_2di ) )
1263#endif
1264!
1265!--    Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte
1266!--    INT. Maybe a compiler problem.
1267       array_position = array_position + INT( (ny+1), KIND=rd_offset_kind ) *                      &
1268                                         INT( (nx+1), KIND=rd_offset_kind ) * 4
1269
1270    ELSE
1271
1272       message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be written to restart ' //   &
1273                        'file is defined with illegal dimensions in the PALM code'
1274       CALL message( 'wrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
1275
1276    ENDIF
1277
1278 END SUBROUTINE wrd_mpi_io_int_2d
1279
1280
1281
1282!--------------------------------------------------------------------------------------------------!
1283! Description:
1284! ------------
1285!> Write 3d-REAL array with MPI-IO
1286!--------------------------------------------------------------------------------------------------!
1287 SUBROUTINE wrd_mpi_io_real_3d( name, data )
1288
1289    IMPLICIT NONE
1290
1291    CHARACTER(LEN=*), INTENT(IN)       ::  name
1292
1293    INTEGER(iwp)                       ::  i
1294#if defined( __parallel )
1295    INTEGER, DIMENSION(rd_status_size) ::  status
1296#endif
1297    REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  ::  data
1298
1299
1300    IF ( header_array_index == max_nr_arrays )  THEN
1301       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1302    ENDIF
1303
1304    array_names(header_array_index)  = name
1305    array_offset(header_array_index) = array_position
1306    header_array_index = header_array_index + 1
1307
1308    IF ( include_total_domain_boundaries )  THEN
1309!
1310!--    Prepare output of 3d-REAL-array with ghost layers.
1311!--    In the virtual PE grid, the first dimension is PEs along x, and the second along y.
1312!--    For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
1313!--    the first dimension should be along x and the second along y.
1314!--    For this reason, the original PALM data need to be swaped.
1315       DO  i = lb%nxl, lb%nxr
1316          array_3d(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1317       ENDDO
1318
1319    ELSE
1320!
1321!--    Prepare output of 3d-REAL-array without ghost layers
1322       DO  i = nxl, nxr
1323           array_3d(:,i,lb%nys:lb%nyn) = data(:,nys:nyn,i)
1324       ENDDO
1325
1326    ENDIF
1327#if defined( __parallel )
1328    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
1329    IF ( sm_io%iam_io_pe )  THEN
1330       CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL, ierr )
1331       CALL MPI_FILE_WRITE_ALL( fh, array_3d, SIZE( array_3d ), MPI_REAL, status, ierr )
1332    ENDIF
1333    CALL sm_io%sm_node_barrier()
1334#else
1335    CALL posix_lseek( fh, array_position )
1336    CALL posix_write( fh, array_3d, SIZE( array_3d ) )
1337#endif
1338!
1339!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1340!-- Maybe a compiler problem.
1341    array_position = array_position + INT(    (nz+2), KIND=rd_offset_kind ) *                      &
1342                                      INT( (lb%ny+1), KIND=rd_offset_kind ) *                      &
1343                                      INT( (lb%nx+1), KIND=rd_offset_kind ) * wp
1344
1345 END SUBROUTINE wrd_mpi_io_real_3d
1346
1347
1348
1349!--------------------------------------------------------------------------------------------------!
1350! Description:
1351! ------------
1352!> Write 3d-REAL soil array with MPI-IO.
1353!> nzb_soil, nzt_soil are located in the module land_surface_model_mod. Since Fortran does not allow
1354!> cross referencing of module variables, it is required to pass these variables as arguments.
1355!--------------------------------------------------------------------------------------------------!
1356 SUBROUTINE wrd_mpi_io_real_3d_soil( name, data, nzb_soil, nzt_soil )
1357
1358    IMPLICIT NONE
1359
1360    CHARACTER(LEN=*), INTENT(IN)       ::  name
1361
1362    INTEGER(iwp)                       ::  i
1363    INTEGER, INTENT(IN)                ::  nzb_soil
1364    INTEGER, INTENT(IN)                ::  nzt_soil
1365
1366#if defined( __parallel )
1367    INTEGER, DIMENSION(rd_status_size) ::  status
1368#endif
1369
1370    REAL(wp), INTENT(IN), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg)  ::  data
1371
1372
1373    IF ( header_array_index == max_nr_arrays )  THEN
1374       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1375    ENDIF
1376
1377    array_names(header_array_index)  = name
1378    array_offset(header_array_index) = array_position
1379    header_array_index = header_array_index + 1
1380
1381#if defined( __parallel )
1382    CALL rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
1383#endif
1384
1385    IF ( include_total_domain_boundaries)  THEN
1386!
1387!--    Prepare output of 3d-REAL-array with ghost layers.
1388!--    In the virtual PE grid, the first dimension is PEs along x, and the second along y.
1389!--    For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
1390!--    the first dimension should be along x and the second along y.
1391!--    For this reason, the original PALM data need to be swaped.
1392       DO  i = lb%nxl, lb%nxr
1393          array_3d_soil(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1394       ENDDO
1395
1396    ELSE
1397!
1398!--    Prepare output of 3d-REAL-array without ghost layers
1399       DO  i = nxl, nxr
1400          array_3d_soil(:,i,lb%nys:lb%nyn) = data(:,nys:nyn,i)
1401       ENDDO
1402
1403    ENDIF
1404#if defined( __parallel )
1405    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
1406    IF ( sm_io%iam_io_pe )  THEN
1407       CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL,   &
1408                               ierr )
1409       CALL MPI_FILE_WRITE_ALL( fh, array_3d_soil, SIZE( array_3d_soil ), MPI_REAL, status, ierr )
1410    ENDIF
1411    CALL sm_io%sm_node_barrier()
1412#else
1413    CALL posix_lseek( fh, array_position )
1414    CALL posix_write( fh, array_3d_soil, SIZE( array_3d_soil ) )
1415#endif
1416!
1417!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1418!-- Maybe a compiler problem.
1419    array_position = array_position + INT( (nzt_soil-nzb_soil+1), KIND=rd_offset_kind ) *          &
1420                                      INT( (lb%ny+1),             KIND=rd_offset_kind ) *          &
1421                                      INT( (lb%nx+1),             KIND=rd_offset_kind ) * wp
1422
1423 END SUBROUTINE wrd_mpi_io_real_3d_soil
1424
1425
1426
1427!--------------------------------------------------------------------------------------------------!
1428! Description:
1429! ------------
1430!> Write CHARATCTER with MPI-IO
1431!--------------------------------------------------------------------------------------------------!
1432 SUBROUTINE wrd_mpi_io_char( name, text )
1433
1434    IMPLICIT NONE
1435
1436    CHARACTER(LEN=128)           ::  lo_line
1437    CHARACTER(LEN=*), INTENT(IN) ::  name
1438    CHARACTER(LEN=*), INTENT(IN) ::  text
1439
1440
1441    IF ( header_char_index == max_nr_char )  THEN
1442       STOP '+++ maximum number of CHARACTER entries in restart file header exceeded'
1443    ENDIF
1444
1445    lo_line      = name
1446    lo_line(33:) = text
1447    text_lines(header_char_index) = lo_line
1448    header_char_index = header_char_index + 1
1449
1450 END SUBROUTINE wrd_mpi_io_char
1451
1452
1453
1454!--------------------------------------------------------------------------------------------------!
1455! Description:
1456! ------------
1457!> Write LOGICAL with MPI-IO
1458!--------------------------------------------------------------------------------------------------!
1459 SUBROUTINE wrd_mpi_io_logical( name, value )
1460
1461    IMPLICIT NONE
1462
1463    CHARACTER(LEN=*), INTENT(IN) ::  name
1464
1465    INTEGER(iwp)                 ::  logical_as_integer
1466
1467    LOGICAL, INTENT(IN)          ::  value
1468
1469
1470    IF ( value )  THEN
1471       logical_as_integer = 1
1472    ELSE
1473       logical_as_integer = 0
1474    ENDIF
1475
1476    CALL wrd_mpi_io_int( name, logical_as_integer )
1477
1478 END SUBROUTINE wrd_mpi_io_logical
1479
1480
1481
1482!--------------------------------------------------------------------------------------------------!
1483! Description:
1484! ------------
1485!> Read 1d-REAL global array with MPI-IO.
1486!> Array contains identical data on all PEs.
1487!--------------------------------------------------------------------------------------------------!
1488 SUBROUTINE rrd_mpi_io_global_array_real_1d( name, data )
1489
1490    IMPLICIT NONE
1491
1492    CHARACTER(LEN=*), INTENT(IN)       ::  name
1493
1494    INTEGER(iwp)                       ::  i
1495    INTEGER(KIND=rd_offset_kind)       ::  offset
1496
1497#if defined( __parallel )
1498    INTEGER, DIMENSION(rd_status_size) ::  status
1499#endif
1500
1501    LOGICAL                            ::  found
1502
1503    REAL(KIND=wp), INTENT(INOUT), DIMENSION(:) ::  data
1504
1505
1506    offset = 0
1507    found  = .FALSE.
1508
1509    DO  i = 1, tgh%nr_arrays
1510       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
1511          array_position = array_offset(i)
1512          found = .TRUE.
1513          EXIT
1514       ENDIF
1515    ENDDO
1516
1517    IF ( found )  THEN
1518!
1519!--    Set default view
1520#if defined( __parallel )
1521       IF ( sm_io%iam_io_pe )  THEN
1522          CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1523          CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1524          CALL MPI_FILE_READ_ALL( fh, data, SIZE( data ), MPI_REAL, status, ierr )
1525       ENDIF
1526       IF ( sm_io%is_sm_active() )  THEN
1527          CALL MPI_BCAST( data, SIZE(data), MPI_REAL, 0, sm_io%comm_shared, ierr )
1528       ENDIF
1529#else
1530       CALL posix_lseek( fh, array_position )
1531       CALL posix_read( fh, data, SIZE( data ) )
1532#endif
1533
1534    ELSE
1535
1536       message_string = '1d/2d/3d/4d-REAL global array "' // TRIM( name ) // '" not found in ' //  &
1537                        'restart file'
1538       CALL message( 'rrd_mpi_io_global_array_real_1d', 'PA0722', 3, 2, 0, 6, 0 )
1539
1540    ENDIF
1541
1542 END SUBROUTINE rrd_mpi_io_global_array_real_1d
1543
1544
1545
1546!--------------------------------------------------------------------------------------------------!
1547! Description:
1548! ------------
1549!> Read 2d-REAL global array with MPI-IO.
1550!> Array contains identical data on all PEs.
1551!--------------------------------------------------------------------------------------------------!
1552 SUBROUTINE rrd_mpi_io_global_array_real_2d( name, data )
1553
1554    IMPLICIT NONE
1555
1556    CHARACTER(LEN=*), INTENT(IN)                      ::  name
1557
1558    INTEGER, DIMENSION(1)                             ::  bufshape
1559
1560    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data
1561    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf
1562
1563    TYPE(C_PTR)                                       ::  c_data
1564
1565
1566    c_data = C_LOC( data )
1567    bufshape(1) = SIZE( data )
1568    CALL C_F_POINTER( c_data, buf, bufshape )
1569
1570    CALL rrd_mpi_io_global_array_real_1d( name, buf )
1571
1572 END SUBROUTINE rrd_mpi_io_global_array_real_2d
1573
1574
1575
1576!--------------------------------------------------------------------------------------------------!
1577! Description:
1578! ------------
1579!> Read 3d-REAL global array with MPI-IO.
1580!> Array contains identical data on all PEs.
1581!--------------------------------------------------------------------------------------------------!
1582 SUBROUTINE rrd_mpi_io_global_array_real_3d( name, data )
1583
1584    IMPLICIT NONE
1585
1586    CHARACTER(LEN=*), INTENT(IN)                        ::  name
1587
1588    INTEGER, DIMENSION(1)                               ::  bufshape
1589
1590    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data
1591    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf
1592
1593    TYPE(C_PTR)                                         ::  c_data
1594
1595
1596    c_data = C_LOC( data )
1597    bufshape(1) = SIZE( data )
1598    CALL C_F_POINTER( c_data, buf, bufshape )
1599
1600    CALL rrd_mpi_io_global_array_real_1d( name, buf )
1601
1602 END SUBROUTINE rrd_mpi_io_global_array_real_3d
1603
1604
1605
1606!--------------------------------------------------------------------------------------------------!
1607! Description:
1608! ------------
1609!> Read 4d-REAL global array with MPI-IO.
1610!> Array contains identical data on all PEs.
1611!--------------------------------------------------------------------------------------------------!
1612 SUBROUTINE rrd_mpi_io_global_array_real_4d( name, data )
1613
1614    IMPLICIT NONE
1615
1616    CHARACTER(LEN=*), INTENT(IN)                          ::  name
1617
1618    INTEGER, DIMENSION(1)                                 ::  bufshape
1619
1620    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data
1621    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf
1622
1623    TYPE(C_PTR)                                           ::  c_data
1624
1625
1626    c_data = C_LOC( data )
1627    bufshape(1) = SIZE( data)
1628    CALL C_F_POINTER( c_data, buf, bufshape )
1629
1630    CALL rrd_mpi_io_global_array_real_1d( name, buf )
1631
1632 END SUBROUTINE rrd_mpi_io_global_array_real_4d
1633
1634
1635
1636!--------------------------------------------------------------------------------------------------!
1637! Description:
1638! ------------
1639!> Read 1d-INTEGER global array with MPI-IO.
1640!> Array contains identical data on all PEs.
1641!--------------------------------------------------------------------------------------------------!
1642 SUBROUTINE rrd_mpi_io_global_array_int_1d( name, data )
1643
1644    IMPLICIT NONE
1645
1646    CHARACTER(LEN=*), INTENT(IN)                   ::  name
1647
1648    INTEGER(iwp)                                   ::  i
1649    INTEGER(KIND=rd_offset_kind)                   ::  offset
1650
1651#if defined( __parallel )
1652    INTEGER, DIMENSION(rd_status_size)             ::  status
1653#endif
1654    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:) ::  data
1655
1656    LOGICAL                                        ::  found
1657
1658
1659    offset = 0
1660    found  = .FALSE.
1661
1662    DO  i = 1, tgh%nr_arrays
1663       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
1664          array_position = array_offset(i)
1665          found = .TRUE.
1666          EXIT
1667       ENDIF
1668    ENDDO
1669
1670    IF ( found )  THEN
1671!
1672!--    Set default view
1673#if defined( __parallel )
1674       IF ( sm_io%iam_io_pe )  THEN
1675          CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1676          CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1677          CALL MPI_FILE_READ_ALL( fh, data, SIZE( data), MPI_INTEGER, status, ierr )
1678       ENDIF
1679       IF ( sm_io%is_sm_active() )  THEN
1680          CALL MPI_BCAST( data, SIZE(data), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
1681       ENDIF
1682#else
1683       CALL posix_lseek( fh, array_position )
1684       CALL posix_read( fh, data, SIZE( data ) )
1685#endif
1686    ELSE
1687
1688       message_string = '1d-INTEGER global array "' // TRIM( name ) // '" not found in ' //        &
1689                        'restart file'
1690       CALL message( 'rrd_mpi_io_global_array_int_1d', 'PA0722', 3, 2, 0, 6, 0 )
1691
1692    ENDIF
1693
1694 END SUBROUTINE rrd_mpi_io_global_array_int_1d
1695
1696
1697
1698!--------------------------------------------------------------------------------------------------!
1699! Description:
1700! ------------
1701!> Write 1d-REAL global array with MPI-IO.
1702!> Array contains identical data on all PEs.
1703!--------------------------------------------------------------------------------------------------!
1704 SUBROUTINE wrd_mpi_io_global_array_real_1d( name, data )
1705
1706    IMPLICIT NONE
1707
1708    CHARACTER(LEN=*), INTENT(IN)            ::  name
1709
1710    INTEGER(KIND=rd_offset_kind)            ::  offset
1711
1712#if defined( __parallel )
1713    INTEGER, DIMENSION(rd_status_size)      ::  status
1714#endif
1715
1716    REAL(KIND=wp), INTENT(IN), DIMENSION(:) ::  data
1717
1718
1719    offset = 0
1720
1721    IF ( header_array_index == max_nr_arrays )  THEN
1722       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1723    ENDIF
1724
1725    array_names(header_array_index)  = name
1726    array_offset(header_array_index) = array_position
1727    header_array_index = header_array_index + 1
1728
1729!
1730!-- Set default view
1731#if defined( __parallel )
1732    IF ( sm_io%iam_io_pe )  THEN
1733       CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1734    ENDIF
1735!
1736!-- Only PE 0 writes replicated data
1737    IF ( myid == 0 )  THEN
1738       CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1739       CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_REAL, status, ierr )
1740    ENDIF
1741#else
1742    CALL posix_lseek( fh, array_position )
1743    CALL posix_write( fh, data, SIZE( data ) )
1744#endif
1745    array_position = array_position + SIZE( data ) * wp
1746
1747 END SUBROUTINE wrd_mpi_io_global_array_real_1d
1748
1749
1750
1751!--------------------------------------------------------------------------------------------------!
1752! Description:
1753! ------------
1754!> Write 2d-REAL global array with MPI-IO.
1755!> Array contains identical data on all PEs.
1756!--------------------------------------------------------------------------------------------------!
1757 SUBROUTINE wrd_mpi_io_global_array_real_2d( name, data )
1758
1759    IMPLICIT NONE
1760
1761    CHARACTER(LEN=*), INTENT(IN)                      ::  name
1762
1763    INTEGER, DIMENSION(1)                             ::  bufshape
1764
1765    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf
1766    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data
1767
1768    TYPE(C_PTR)                                       ::  c_data
1769
1770
1771    c_data = C_LOC( data )
1772    bufshape(1) = SIZE( data)
1773    CALL C_F_POINTER( c_data, buf, bufshape )
1774
1775    CALL wrd_mpi_io_global_array_real_1d( name, buf )
1776
1777 END SUBROUTINE wrd_mpi_io_global_array_real_2d
1778
1779
1780
1781!--------------------------------------------------------------------------------------------------!
1782! Description:
1783! ------------
1784!> Write 3d-REAL global array with MPI-IO.
1785!> Array contains identical data on all PEs.
1786!--------------------------------------------------------------------------------------------------!
1787 SUBROUTINE wrd_mpi_io_global_array_real_3d( name, data )
1788
1789    IMPLICIT NONE
1790
1791    CHARACTER(LEN=*), INTENT(IN)                        ::  name
1792
1793    INTEGER, DIMENSION(1)                               ::  bufshape
1794
1795    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf
1796    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data
1797
1798    TYPE(C_PTR)                                         ::  c_data
1799
1800
1801    c_data = C_LOC( data )
1802    bufshape(1) = SIZE( data )
1803    CALL C_F_POINTER( c_data, buf, bufshape )
1804
1805    CALL wrd_mpi_io_global_array_real_1d( name, buf )
1806
1807 END SUBROUTINE wrd_mpi_io_global_array_real_3d
1808
1809
1810
1811!--------------------------------------------------------------------------------------------------!
1812! Description:
1813! ------------
1814!> Write 4d-REAL global array with MPI-IO.
1815!> Array contains identical data on all PEs.
1816!--------------------------------------------------------------------------------------------------!
1817 SUBROUTINE wrd_mpi_io_global_array_real_4d( name, data )
1818
1819    IMPLICIT NONE
1820
1821    CHARACTER(LEN=*), INTENT(IN)                          ::  name
1822
1823    INTEGER, DIMENSION(1)                                 ::  bufshape
1824
1825    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf
1826    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data
1827
1828    TYPE(C_PTR)                                           ::  c_data
1829
1830
1831    c_data = C_LOC( data )
1832    bufshape(1) = SIZE( data)
1833    CALL C_F_POINTER( c_data, buf, bufshape )
1834
1835    CALL wrd_mpi_io_global_array_real_1d( name, buf )
1836
1837 END SUBROUTINE wrd_mpi_io_global_array_real_4d
1838
1839
1840
1841!--------------------------------------------------------------------------------------------------!
1842! Description:
1843! ------------
1844!> Write 1d-INTEGER global array with MPI-IO.
1845!> Array contains identical data on all PEs.
1846!--------------------------------------------------------------------------------------------------!
1847 SUBROUTINE wrd_mpi_io_global_array_int_1d( name, data )
1848
1849    IMPLICIT NONE
1850
1851    CHARACTER(LEN=*), INTENT(IN)                ::  name
1852
1853    INTEGER(KIND=rd_offset_kind)                ::  offset
1854
1855    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:) ::  data
1856#if defined( __parallel )
1857    INTEGER, DIMENSION(rd_status_size)          ::  status
1858#endif
1859
1860    IF ( header_array_index == max_nr_arrays )  THEN
1861       STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
1862    ENDIF
1863
1864    offset = 0
1865    array_names(header_array_index)  = name
1866    array_offset(header_array_index) = array_position
1867    header_array_index = header_array_index + 1
1868
1869!
1870!-- Set default view
1871#if defined( __parallel )
1872    IF ( sm_io%iam_io_pe )  THEN
1873       CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1874    ENDIF
1875!
1876!-- Only PE 0 writes replicated data
1877    IF ( myid == 0 )  THEN                        !
1878       CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1879       CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_INTEGER, status, ierr )
1880    ENDIF
1881#else
1882    CALL posix_lseek( fh, array_position )
1883    CALL posix_write( fh, data, SIZE( data ) )
1884#endif
1885    array_position = array_position + SIZE( data ) * 4
1886
1887 END SUBROUTINE wrd_mpi_io_global_array_int_1d
1888
1889
1890
1891!--------------------------------------------------------------------------------------------------!
1892! Description:
1893! ------------
1894!> Read 1d-REAL surface data array with MPI-IO.
1895!--------------------------------------------------------------------------------------------------!
1896 SUBROUTINE rrd_mpi_io_surface( name, data, first_index )
1897
1898    IMPLICIT NONE
1899
1900    CHARACTER(LEN=*), INTENT(IN) ::  name
1901
1902    INTEGER(KIND=rd_offset_kind) ::  disp          !< displacement of actual indices
1903    INTEGER(KIND=rd_offset_kind) ::  disp_f        !< displacement in file
1904    INTEGER(KIND=rd_offset_kind) ::  disp_n        !< displacement of next column
1905    INTEGER(iwp), OPTIONAL       ::  first_index
1906
1907    INTEGER(iwp)                 ::  i
1908    INTEGER(iwp)                 ::  i_f
1909    INTEGER(iwp)                 ::  j
1910    INTEGER(iwp)                 ::  j_f
1911    INTEGER(iwp)                 ::  lo_first_index
1912    INTEGER(iwp)                 ::  nr_bytes
1913    INTEGER(iwp)                 ::  nr_bytes_f
1914    INTEGER(iwp)                 ::  nr_words
1915#if defined( __parallel )
1916    INTEGER, DIMENSION(rd_status_size)  ::  status
1917#endif
1918
1919    LOGICAL                             ::  found
1920
1921    REAL(wp), INTENT(OUT), DIMENSION(:) ::  data
1922
1923
1924    found = .FALSE.
1925    lo_first_index = 1
1926
1927    IF ( MAXVAL( m_global_start ) == -1 )   RETURN   ! nothing to do on this PE
1928
1929    IF ( PRESENT( first_index ) )   THEN
1930       lo_first_index = first_index
1931    ENDIF
1932
1933    DO  i = 1, tgh%nr_arrays
1934        IF ( TRIM( array_names(i) ) == TRIM( name ) )  THEN
1935           array_position = array_offset(i) + ( lo_first_index - 1 ) *                             &
1936                                              total_number_of_surface_values * wp
1937           found = .TRUE.
1938           EXIT
1939        ENDIF
1940    ENDDO
1941
1942    disp   = -1
1943    disp_f = -1
1944    disp_n = -1
1945    IF ( found )  THEN
1946
1947       DO  i = nxl, nxr
1948          DO  j = nys, nyn
1949
1950             IF ( m_global_start(j,i) > 0 )  THEN
1951                disp     = array_position+(m_global_start(j,i)-1) * wp
1952                nr_words = m_end_index(j,i)-m_start_index(j,i)+1
1953                nr_bytes = nr_words * wp
1954             ENDIF
1955             IF ( disp >= 0  .AND.  disp_f == -1 )  THEN   ! first Entry
1956                disp_f     = disp
1957                nr_bytes_f = 0
1958                i_f = i
1959                j_f = j
1960             ENDIF
1961             IF ( j == nyn  .AND.  i == nxr )  THEN        ! last Entry
1962                disp_n = -1
1963                IF (  nr_bytes > 0 )  THEN
1964                   nr_bytes_f = nr_bytes_f+nr_bytes
1965                ENDIF
1966             ELSEIF ( j == nyn )  THEN                     ! next x
1967                IF ( m_global_start(nys,i+1) > 0  .AND.  disp > 0 )  THEN
1968                   disp_n = array_position + ( m_global_start(nys,i+1) - 1 ) * wp
1969                ELSE
1970                   CYCLE
1971                ENDIF
1972             ELSE
1973                IF ( m_global_start(j+1,i) > 0  .AND.  disp > 0 )  THEN
1974                   disp_n = array_position + ( m_global_start(j+1,i) - 1 ) * wp
1975                ELSE
1976                   CYCLE
1977                ENDIF
1978             ENDIF
1979
1980
1981             IF ( disp + nr_bytes == disp_n )  THEN        ! contiguous block
1982                nr_bytes_f = nr_bytes_f + nr_bytes
1983             ELSE                                          ! read
1984#if defined( __parallel )
1985                CALL MPI_FILE_SEEK( fhs, disp_f, MPI_SEEK_SET, ierr )
1986                nr_words = nr_bytes_f / wp
1987                CALL MPI_FILE_READ( fhs, data(m_start_index(j_f,i_f)), nr_words, MPI_REAL, status, ierr )
1988#else
1989                CALL posix_lseek( fh, disp_f )
1990                CALL posix_read( fh, data(m_start_index(j_f,i_f):), nr_bytes_f )
1991#endif
1992                disp_f     = disp
1993                nr_bytes_f = nr_bytes
1994                i_f = i
1995                j_f = j
1996             ENDIF
1997
1998          ENDDO
1999       ENDDO
2000
2001    ELSE
2002
2003       message_string = 'surface array "' // TRIM( name ) // '" not found in restart file'
2004       CALL message( 'rrd_mpi_io_global_array_int_1d', 'PA0722', 3, 2, 0, 6, 0 )
2005
2006    ENDIF
2007
2008!    IF ( lo_first_index == 1 )  THEN
2009!       IF ( debug_level >= 2 .AND. nr_val > 0 )  WRITE(9,*)  'r_surf_1 ', TRIM( name ), ' ', nr_val, SUM( data(1:nr_val) )
2010!    ELSE
2011!       IF ( debug_level >= 2 .AND. nr_val > 0 )  WRITE(9,*)  'r_surf_next ', TRIM( name ), ' ', &
2012!                                                             lo_first_index,nr_val, SUM( data(1:nr_val) )
2013!    ENDIF
2014
2015 END SUBROUTINE rrd_mpi_io_surface
2016
2017
2018
2019!--------------------------------------------------------------------------------------------------!
2020! Description:
2021! ------------
2022!> Read 2d-REAL surface data array with MPI-IO.
2023!> These consist of multiple 1d-REAL surface data arrays.
2024!--------------------------------------------------------------------------------------------------!
2025 SUBROUTINE rrd_mpi_io_surface_2d( name, data )
2026
2027    IMPLICIT NONE
2028
2029    CHARACTER(LEN=*), INTENT(IN)          ::  name
2030
2031    INTEGER(iwp)                          ::  i
2032
2033    REAL(wp), INTENT(OUT), DIMENSION(:,:) ::  data
2034    REAL(wp), DIMENSION(SIZE( data,2))    ::  tmp
2035
2036
2037    DO  i = 1, SIZE( data,1)
2038       CALL rrd_mpi_io_surface( name, tmp, first_index = i )
2039       data(i,:) = tmp
2040    ENDDO
2041
2042!
2043!-- Comment from Klaus Ketelsen (September 2018)
2044!-- The intention of the following loop was let the compiler do the copying on return.
2045!-- In my understanding is it standard conform to pass the second dimension to a 1d-
2046!-- array inside a subroutine and the compiler is responsible to generate code for
2047!-- copying. Acually this works fine for INTENT(IN) variables (wrd_mpi_io_surface_2d).
2048!-- For INTENT(OUT) like in this case the code works on pgi compiler. But both, the Intel 16
2049!-- and the Cray compiler show wrong answers using this loop.
2050!-- That is the reason why the above auxiliary array tmp was introduced.
2051!    DO  i = 1, SIZE(  data,1)
2052!       CALL rrd_mpi_io_surface( name, data(i,:), first_index = i )
2053!    ENDDO
2054
2055 END SUBROUTINE rrd_mpi_io_surface_2d
2056
2057
2058
2059!--------------------------------------------------------------------------------------------------!
2060! Description:
2061! ------------
2062!> Write 1d-REAL surface data array with MPI-IO.
2063!--------------------------------------------------------------------------------------------------!
2064 SUBROUTINE wrd_mpi_io_surface( name, data, first_index )
2065
2066    IMPLICIT NONE
2067
2068    CHARACTER(LEN=*), INTENT(IN)       ::  name
2069
2070#if defined( __parallel )
2071    INTEGER(KIND=rd_offset_kind)       ::  disp
2072#endif
2073    INTEGER(iwp), OPTIONAL             ::  first_index
2074#if defined( __parallel )
2075    INTEGER(iwp)                       ::  i
2076#endif
2077    INTEGER(iwp)                       ::  lo_first_index
2078    INTEGER(KIND=rd_offset_kind)       ::  offset
2079
2080#if defined( __parallel )
2081    INTEGER, DIMENSION(rd_status_size) ::  status
2082#endif
2083
2084    REAL(wp), INTENT(IN), DIMENSION(:), TARGET ::  data
2085
2086
2087    offset = 0
2088    lo_first_index = 1
2089
2090    IF ( PRESENT(first_index) )  THEN
2091       lo_first_index = first_index
2092    ENDIF
2093!
2094!-- In case of 2d-data, name is written only once
2095    IF ( lo_first_index == 1 )  THEN
2096
2097       IF ( header_array_index == max_nr_arrays )  THEN
2098          STOP '+++ maximum number of 2d/3d-array entries in restart file header exceeded'
2099       ENDIF
2100
2101       array_names(header_array_index)  = name
2102       array_offset(header_array_index) = array_position
2103       header_array_index = header_array_index + 1
2104
2105    ENDIF
2106
2107#if defined( __parallel )
2108    IF ( sm_io%is_sm_active() )  THEN
2109       DO  i = 1, nr_val
2110          array_1d(i+local_start) = data(i)
2111       ENDDO
2112    ELSE
2113!       array_1d => data                           !kk Did not work in all cases    why???
2114       ALLOCATE( array_1d( SIZE( data ) ) )
2115       array_1d = data
2116    ENDIF
2117
2118    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
2119    IF ( sm_io%iam_io_pe )  THEN
2120       IF ( all_pes_write )  THEN
2121          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_surf, 'native', MPI_INFO_NULL,  &
2122                                  ierr )
2123          CALL MPI_FILE_WRITE_ALL( fh, array_1d, nr_iope, MPI_REAL, status, ierr )
2124       ELSE
2125          CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2126          IF ( nr_val > 0 )  THEN
2127             disp = array_position + 8 * ( glo_start - 1 )
2128             CALL MPI_FILE_SEEK( fh, disp, MPI_SEEK_SET, ierr )
2129             CALL MPI_FILE_WRITE( fh, array_1d, nr_iope, MPI_REAL, status, ierr )
2130          ENDIF
2131       ENDIF
2132    ENDIF
2133    CALL sm_io%sm_node_barrier()
2134    IF( .NOT. sm_io%is_sm_active() )  DEALLOCATE( array_1d )
2135#else
2136    CALL posix_lseek( fh, array_position )
2137    CALL posix_write( fh, data, nr_val )
2138#endif
2139    array_position = array_position + total_number_of_surface_values * wp
2140
2141!    IF ( lo_first_index == 1 )  THEN
2142!       IF ( debug_level >= 2 .AND. nr_val  > 0 )  WRITE(9,*) 'w_surf_1 ', TRIM( name ), ' ', nr_val, SUM( data(1:nr_val) )
2143!    ELSE
2144!       IF ( debug_level >= 2 .AND. nr_val  > 0 ) WRITE(9,*) 'w_surf_n ', TRIM( name ), ' ', &
2145!                                                            lo_first_index, nr_val, SUM( data(1:nr_val) )
2146!    ENDIF
2147
2148 END SUBROUTINE wrd_mpi_io_surface
2149
2150
2151
2152!--------------------------------------------------------------------------------------------------!
2153! Description:
2154! ------------
2155!> Read 2d-REAL surface data array with MPI-IO.
2156!> These consist of multiple 1d-REAL surface data arrays.
2157!--------------------------------------------------------------------------------------------------!
2158 SUBROUTINE wrd_mpi_io_surface_2d( name, data )
2159
2160    IMPLICIT NONE
2161
2162    CHARACTER(LEN=*), INTENT(IN)         ::  name
2163
2164    INTEGER(iwp)                         ::  i
2165
2166    REAL(wp), INTENT(IN), DIMENSION(:,:) ::  data
2167
2168
2169    DO  i = 1, SIZE( data,1)
2170       CALL wrd_mpi_io_surface( name, data(i,:), first_index = i )
2171    ENDDO
2172
2173 END SUBROUTINE wrd_mpi_io_surface_2d
2174
2175
2176
2177!--------------------------------------------------------------------------------------------------!
2178! Description:
2179! ------------
2180!> Close restart file for MPI-IO
2181!--------------------------------------------------------------------------------------------------!
2182 SUBROUTINE rd_mpi_io_close
2183
2184    IMPLICIT NONE
2185
2186    INTEGER(iwp)                       ::  gh_size
2187    INTEGER(KIND=rd_offset_kind)       ::  offset
2188#if defined( __parallel )
2189    INTEGER, DIMENSION(rd_status_size) ::  status
2190#endif
2191
2192#if ! defined( __parallel )
2193    TYPE(C_PTR)                        ::  buf_ptr
2194#endif
2195
2196
2197    offset = 0
2198
2199    IF ( wr_flag  .AND.  sm_io%iam_io_pe )  THEN
2200
2201       tgh%nr_int    = header_int_index - 1
2202       tgh%nr_char   = header_char_index - 1
2203       tgh%nr_real   = header_real_index - 1
2204       tgh%nr_arrays = header_array_index - 1
2205       tgh%total_nx  = lb%nx + 1
2206       tgh%total_ny  = lb%ny + 1
2207       IF ( include_total_domain_boundaries )  THEN   ! not sure, if LOGICAL interpretation is the same for all compilers,
2208          tgh%i_outer_bound = 1        ! therefore store as INTEGER in general header
2209       ELSE
2210          tgh%i_outer_bound = 0
2211       ENDIF
2212!
2213!--    Check for big/little endian format. This check is currently not used, and could be removed
2214!--    if we can assume little endian as the default on all machines.
2215       CALL rd_mpi_io_check_endian( tgh%endian )
2216
2217!
2218!--    Set default view
2219#if defined( __parallel )
2220       CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2221#endif
2222!
2223!--    Write header file
2224       gh_size = storage_size(tgh) / 8
2225       IF ( myid == 0 )  THEN   ! myid = 0 always performs I/O, even if I/O is limited to some cores
2226#if defined( __parallel )
2227          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2228          CALL MPI_FILE_WRITE( fh, tgh, gh_size, MPI_INT, status, ierr )
2229          header_position = header_position + gh_size
2230!
2231!--       INTEGER values
2232          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2233          CALL MPI_FILE_WRITE( fh, int_names, SIZE( int_names )*32, MPI_CHAR, status, ierr )
2234          header_position = header_position + SIZE( int_names ) * 32
2235
2236          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2237          CALL MPI_FILE_WRITE( fh, int_values, SIZE( int_values ), MPI_INT, status, ierr )
2238          header_position = header_position + SIZE( int_values ) * iwp
2239!
2240!--       Character entries
2241          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2242          CALL MPI_FILE_WRITE( fh, text_lines, SIZE( text_lines )*128, MPI_CHAR, status, ierr )
2243          header_position = header_position + SIZE( text_lines ) * 128
2244!
2245!---      REAL values
2246          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2247          CALL MPI_FILE_WRITE( fh, real_names, SIZE( real_names )*32, MPI_CHAR, status, ierr )
2248          header_position = header_position + SIZE( real_names ) * 32
2249
2250          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2251          CALL MPI_FILE_WRITE( fh, real_values, SIZE( real_values ), MPI_REAL, status, ierr )
2252          header_position = header_position + SIZE( real_values ) * wp
2253!
2254!--       2d- and 3d- distributed array headers, all replicated array headers
2255          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2256          CALL MPI_FILE_WRITE( fh, array_names, SIZE( array_names )*32, MPI_CHAR, status, ierr )
2257          header_position = header_position + SIZE( array_names ) * 32
2258
2259          CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2260          CALL MPI_FILE_WRITE( fh, array_offset, SIZE( array_offset )*MPI_OFFSET_KIND, MPI_BYTE,   &
2261                               status, ierr )  ! There is no I*8 datatype in Fortran
2262          header_position = header_position + SIZE( array_offset ) * rd_offset_kind
2263#else
2264          CALL posix_lseek( fh, header_position )
2265          buf_ptr = C_LOC( tgh )
2266          CALL posix_write( fh, buf_ptr, gh_size )
2267          header_position = header_position + gh_size
2268!
2269!--       INTEGER values
2270          CALL posix_lseek( fh, header_position )
2271          CALL posix_write( fh, int_names )
2272          header_position = header_position + SIZE( int_names ) * 32
2273
2274          CALL posix_lseek( fh, header_position )
2275          CALL posix_write( fh, int_values, SIZE( int_values ) )
2276          header_position = header_position + SIZE( int_values ) * iwp
2277!
2278!--       Character entries
2279          CALL posix_lseek( fh, header_position )
2280          CALL posix_write( fh, text_lines )
2281          header_position = header_position + SIZE( text_lines ) * 128
2282!
2283!--       REAL values
2284          CALL posix_lseek( fh, header_position )
2285          CALL posix_write( fh, real_names )
2286          header_position = header_position + SIZE( real_names ) * 32
2287
2288          CALL posix_lseek( fh, header_position )
2289          CALL posix_write( fh, real_values, SIZE( real_values ) )
2290          header_position = header_position + SIZE( real_values ) * wp
2291!
2292!--       2d- and 3d-distributed array headers, all replicated array headers
2293          CALL posix_lseek( fh, header_position )
2294          CALL posix_write( fh, array_names )
2295          header_position = header_position + SIZE( array_names ) * 32
2296
2297          CALL posix_lseek( fh, header_position )
2298          CALL posix_write( fh, array_offset, SIZE( array_offset ) )
2299          header_position = header_position + SIZE( array_offset ) * rd_offset_kind
2300#endif
2301          IF ( debug_output )  CALL rd_mpi_io_print_header
2302       ENDIF
2303
2304    ENDIF
2305
2306!
2307!-- Free file types
2308    CALL rd_mpi_io_free_filetypes
2309
2310!
2311!-- Close MPI-IO files
2312#if defined( __parallel )
2313!
2314!-- Restart file has been opened with comm2d
2315    IF ( fhs /= -1 )  THEN
2316       CALL MPI_FILE_CLOSE( fhs, ierr )
2317    ENDIF
2318#endif
2319
2320    IF ( sm_io%iam_io_pe )  THEN
2321
2322#if defined( __parallel )
2323       CALL MPI_FILE_CLOSE( fh, ierr )
2324#else
2325       CALL posix_close( fh )
2326#endif
2327
2328    ENDIF
2329
2330    restart_file_size = array_position / ( 1024.0_dp * 1024.0_dp )
2331
2332 END SUBROUTINE rd_mpi_io_close
2333
2334
2335
2336!--------------------------------------------------------------------------------------------------!
2337! Description:
2338! ------------
2339!> This subroutine prepares a filetype and some variables for the I/O of surface data.
2340!> Whenever a new set of start_index and end_index is used, rd_mpi_io_surface_filetypes has to be
2341!> called. A main feature of this subroutine is computing the global start indices of the 1d- and
2342!> 2d- surface arrays.
2343!> Even if I/O is done by a limited number of cores only, the surface data are read by ALL cores!
2344!> Reading them by some cores and then distributing the data would result in complicated code
2345!> which is suspectable for errors and overloads the reading subroutine. Since reading of surface
2346!> data is not time critical (data size is comparably small), it will be read by all cores.
2347!--------------------------------------------------------------------------------------------------!
2348 SUBROUTINE rd_mpi_io_surface_filetypes( start_index, end_index, data_to_write, global_start )
2349
2350    IMPLICIT NONE
2351
2352    INTEGER(iwp)                          ::  i            !<  loop index
2353    INTEGER(KIND=rd_offset_kind)          ::  offset
2354
2355    INTEGER(iwp), DIMENSION(1)            ::  dims1
2356    INTEGER(iwp), DIMENSION(1)            ::  lize1
2357    INTEGER(iwp), DIMENSION(1)            ::  start1
2358    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  lo_nr_val    !< local number of values in x and y direction
2359    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  all_nr_val   !< number of values for all PEs
2360
2361    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  end_index
2362    INTEGER, INTENT(OUT), DIMENSION(nys:nyn,nxl:nxr) ::  global_start
2363    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  start_index
2364
2365    LOGICAL, INTENT(OUT)                  ::  data_to_write  !< returns, if surface data have to be written
2366
2367
2368    offset = 0
2369    lo_nr_val= 0
2370    lo_nr_val(myid) = MAXVAL( end_index )
2371#if defined( __parallel )
2372    CALL MPI_ALLREDUCE( lo_nr_val, all_nr_val, numprocs, MPI_INTEGER, MPI_SUM, comm2d, ierr )
2373    IF ( ft_surf /= -1  .AND.  sm_io%iam_io_pe )  THEN
2374       CALL MPI_TYPE_FREE( ft_surf, ierr )    ! if set, free last surface filetype
2375    ENDIF
2376
2377    IF ( win_surf /= -1 )  THEN
2378       IF ( sm_io%is_sm_active() )  THEN
2379          CALL MPI_WIN_FREE( win_surf, ierr )
2380       ENDIF
2381       win_surf = -1
2382    ENDIF
2383
2384    IF ( sm_io%is_sm_active() .AND. rd_flag )  THEN
2385       IF ( fhs == -1 )  THEN
2386          CALL MPI_FILE_OPEN( comm2d, TRIM( io_file_name ), MPI_MODE_RDONLY, MPI_INFO_NULL, fhs,   &
2387                              ierr )
2388       ENDIF
2389    ELSE
2390       fhs = fh
2391    ENDIF
2392#else
2393    all_nr_val(myid) = lo_nr_val(myid)
2394#endif
2395    nr_val = lo_nr_val(myid)
2396
2397    total_number_of_surface_values = 0
2398    DO  i = 0, numprocs-1
2399       IF ( i == myid )  THEN
2400          glo_start = total_number_of_surface_values + 1
2401       ENDIF
2402       total_number_of_surface_values = total_number_of_surface_values + all_nr_val(i)
2403    ENDDO
2404
2405!
2406!-- Actions during read
2407    IF ( rd_flag )  THEN
2408       IF ( .NOT. ALLOCATED( m_start_index )  )  ALLOCATE( m_start_index(nys:nyn,nxl:nxr)  )
2409       IF ( .NOT. ALLOCATED( m_end_index )    )  ALLOCATE( m_end_index(nys:nyn,nxl:nxr)    )
2410       IF ( .NOT. ALLOCATED( m_global_start ) )  ALLOCATE( m_global_start(nys:nyn,nxl:nxr) )
2411!
2412!--    Save arrays for later reading
2413       m_start_index  = start_index
2414       m_end_index    = end_index
2415       m_global_start = global_start
2416       nr_val = MAXVAL( end_index )
2417
2418#if defined( __parallel )
2419       CALL MPI_FILE_SET_VIEW( fhs, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2420#endif
2421    ENDIF
2422
2423!
2424!-- Actions during write
2425    IF ( wr_flag )  THEN
2426!
2427!--    Create surface filetype
2428       ft_surf      = -1
2429       global_start = start_index + glo_start - 1
2430
2431       WHERE ( end_index < start_index )
2432          global_start = -1
2433       ENDWHERE
2434
2435#if defined( __parallel )
2436       IF ( sm_io%is_sm_active() )  THEN
2437          IF ( sm_io%iam_io_pe )  THEN
2438!
2439!--          Calculate number of values of all PEs of an I/O group
2440             nr_iope = 0
2441             DO  i = myid, myid+sm_io%sh_npes-1
2442                nr_iope = nr_iope + all_nr_val(i)
2443             ENDDO
2444          ELSE
2445             local_start = 0
2446             DO  i = myid-sm_io%sh_rank, myid-1
2447                local_start = local_start + all_nr_val(i)
2448             ENDDO
2449          ENDIF
2450!
2451!--       Get the size of shared memory window on all PEs
2452          CALL MPI_BCAST( nr_iope, 1, MPI_INTEGER, 0, sm_io%comm_shared, ierr )
2453          CALL sm_io%sm_allocate_shared( array_1d, 1, MAX( 1, nr_iope ), win_surf )
2454       ELSE
2455          nr_iope = nr_val
2456       ENDIF
2457#else
2458       nr_iope = nr_val
2459#endif
2460
2461!
2462!--    Check, if surface data exist on this PE
2463       data_to_write = .TRUE.
2464       IF ( total_number_of_surface_values == 0 )  THEN
2465          data_to_write = .FALSE.
2466          RETURN
2467       ENDIF
2468
2469       IF ( sm_io%iam_io_pe )  THEN
2470
2471          all_pes_write = ( MINVAL( all_nr_val ) > 0 )
2472
2473          IF ( all_pes_write )  THEN
2474             dims1(1)  = total_number_of_surface_values
2475             lize1(1)  = nr_iope
2476             start1(1) = glo_start-1
2477
2478#if defined( __parallel )
2479             IF ( total_number_of_surface_values > 0 )  THEN
2480                 CALL MPI_TYPE_CREATE_SUBARRAY( 1, dims1, lize1, start1, MPI_ORDER_FORTRAN,        &
2481                                                MPI_REAL, ft_surf, ierr )
2482                 CALL MPI_TYPE_COMMIT( ft_surf, ierr )
2483             ENDIF
2484#endif
2485          ENDIF
2486       ENDIF
2487
2488    ENDIF
2489
2490 END SUBROUTINE rd_mpi_io_surface_filetypes
2491
2492
2493
2494!--------------------------------------------------------------------------------------------------!
2495! Description:
2496! ------------
2497!> This subroutine creates file types to access 2d-/3d-REAL arrays and 2d-INTEGER arrays
2498!> distributed in blocks among processes to a single file that contains the global arrays.
2499!--------------------------------------------------------------------------------------------------!
2500  SUBROUTINE rd_mpi_io_create_filetypes
2501
2502    IMPLICIT NONE
2503
2504    INTEGER, DIMENSION(2) ::  dims2
2505    INTEGER, DIMENSION(2) ::  lize2
2506    INTEGER, DIMENSION(2) ::  start2
2507
2508    INTEGER, DIMENSION(3) ::  dims3
2509    INTEGER, DIMENSION(3) ::  lize3
2510    INTEGER, DIMENSION(3) ::  start3
2511
2512    TYPE(local_boundaries) ::  save_io_grid  !< temporary variable to store grid settings
2513
2514
2515    IF ( sm_io%is_sm_active() )  THEN
2516       save_io_grid = sm_io%io_grid
2517    ENDIF
2518
2519!
2520!-- Decision, if storage with or without ghost layers.
2521!-- Please note that the indexing of the global array always starts at 0, even in Fortran.
2522!-- Therefore the PE local indices have to be shifted by nbgp in the case with ghost layers.
2523    IF ( include_total_domain_boundaries )  THEN
2524
2525       lb%nxl = nxl + nbgp
2526       lb%nxr = nxr + nbgp
2527       lb%nys = nys + nbgp
2528       lb%nyn = nyn + nbgp
2529       lb%nnx = nnx
2530       lb%nny = nny
2531       lb%nx  = nx + 2 * nbgp
2532       lb%ny  = ny + 2 * nbgp
2533       IF ( myidx == 0 )  THEN
2534          lb%nxl = lb%nxl - nbgp
2535          lb%nnx = lb%nnx + nbgp
2536       ENDIF
2537       IF ( myidx == npex-1  .OR.  npex == -1 )  THEN   ! npex == 1 if -D__parallel not set
2538          lb%nxr = lb%nxr + nbgp
2539          lb%nnx = lb%nnx + nbgp
2540       ENDIF
2541       IF ( myidy == 0 )  THEN
2542          lb%nys = lb%nys - nbgp
2543          lb%nny = lb%nny + nbgp
2544       ENDIF
2545       IF ( myidy == npey-1  .OR.  npey == -1 )  THEN   ! npey == 1 if -D__parallel not set
2546          lb%nyn = lb%nyn + nbgp
2547          lb%nny = lb%nny + nbgp
2548       ENDIF
2549
2550       CALL sm_io%sm_adjust_outer_boundary()
2551
2552    ELSE
2553
2554       lb%nxl = nxl
2555       lb%nxr = nxr
2556       lb%nys = nys
2557       lb%nyn = nyn
2558       lb%nnx = nnx
2559       lb%nny = nny
2560       lb%nx  = nx
2561       lb%ny  = ny
2562
2563    ENDIF
2564
2565    IF ( sm_io%is_sm_active() )  THEN
2566#if defined( __parallel )
2567       CALL sm_io%sm_allocate_shared( array_2d,  sm_io%io_grid%nxl, sm_io%io_grid%nxr,             &
2568                                      sm_io%io_grid%nys, sm_io%io_grid%nyn, win_2dr )
2569       CALL sm_io%sm_allocate_shared( array_2di, save_io_grid%nxl, save_io_grid%nxr,               &
2570                                      save_io_grid%nys, save_io_grid%nyn, win_2di )
2571       CALL sm_io%sm_allocate_shared( array_3d, nzb, nzt+1, sm_io%io_grid%nxl, sm_io%io_grid%nxr,  &
2572                                      sm_io%io_grid%nys, sm_io%io_grid%nyn, win_3dr )
2573#endif
2574    ELSE
2575       ALLOCATE( array_2d(lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2576       ALLOCATE( array_2di(nxl:nxr,nys:nyn) )
2577       ALLOCATE( array_3d(nzb:nzt+1,lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2578       sm_io%io_grid = lb
2579    ENDIF
2580
2581!
2582!-- Create filetype for 2d-REAL array with ghost layers around the total domain
2583    dims2(1)  = lb%nx + 1
2584    dims2(2)  = lb%ny + 1
2585
2586    lize2(1)  = sm_io%io_grid%nnx
2587    lize2(2)  = sm_io%io_grid%nny
2588
2589    start2(1) = sm_io%io_grid%nxl
2590    start2(2) = sm_io%io_grid%nys
2591
2592#if defined( __parallel )
2593    IF ( sm_io%iam_io_pe )  THEN
2594       CALL MPI_TYPE_CREATE_SUBARRAY( 2, dims2, lize2, start2, MPI_ORDER_FORTRAN, MPI_REAL,        &
2595                                      ft_2d, ierr )
2596       CALL MPI_TYPE_COMMIT( ft_2d, ierr )
2597    ENDIF
2598#endif
2599!
2600!-- Create filetype for 2d-INTEGER array without ghost layers around the total domain
2601    dims2(1)  = nx + 1
2602    dims2(2)  = ny + 1
2603
2604    IF ( sm_io%is_sm_active() )  THEN
2605
2606       lize2(1)  = save_io_grid%nnx
2607       lize2(2)  = save_io_grid%nny
2608
2609       start2(1) = save_io_grid%nxl
2610       start2(2) = save_io_grid%nys
2611
2612    ELSE
2613
2614       lize2(1)  = nnx
2615       lize2(2)  = nny
2616
2617       start2(1) = nxl
2618       start2(2) = nys
2619
2620    ENDIF
2621
2622#if defined( __parallel )
2623    IF ( sm_io%iam_io_pe )  THEN
2624       CALL MPI_TYPE_CREATE_SUBARRAY( 2, dims2, lize2, start2, MPI_ORDER_FORTRAN, MPI_INTEGER,     &
2625                                      ft_2di_nb, ierr )
2626       CALL MPI_TYPE_COMMIT( ft_2di_nb, ierr )
2627    ENDIF
2628#endif
2629!
2630!-- Create filetype for 3d-REAL array
2631    dims3(1)  = nz + 2
2632    dims3(2)  = lb%nx + 1
2633    dims3(3)  = lb%ny + 1
2634
2635    lize3(1)  = dims3(1)
2636    lize3(2)  = sm_io%io_grid%nnx
2637    lize3(3)  = sm_io%io_grid%nny
2638
2639    start3(1) = nzb
2640    start3(2) = sm_io%io_grid%nxl
2641    start3(3) = sm_io%io_grid%nys
2642
2643#if defined( __parallel )
2644    IF ( sm_io%iam_io_pe )  THEN
2645       CALL MPI_TYPE_CREATE_SUBARRAY( 3, dims3, lize3, start3, MPI_ORDER_FORTRAN, MPI_REAL, ft_3d, &
2646                                      ierr )
2647       CALL MPI_TYPE_COMMIT( ft_3d, ierr )
2648    ENDIF
2649#endif
2650
2651 END SUBROUTINE rd_mpi_io_create_filetypes
2652
2653
2654
2655!--------------------------------------------------------------------------------------------------!
2656! Description:
2657! ------------
2658!> This subroutine creates file types to access 3d-soil arrays
2659!> distributed in blocks among processes to a single file that contains the global arrays.
2660!> It is not required for the serial mode.
2661!--------------------------------------------------------------------------------------------------!
2662#if defined( __parallel )
2663 SUBROUTINE rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
2664
2665    IMPLICIT NONE
2666
2667    INTEGER, INTENT(IN)  ::  nzb_soil
2668    INTEGER, INTENT(IN)  ::  nzt_soil
2669
2670    INTEGER, DIMENSION(3) ::  dims3
2671    INTEGER, DIMENSION(3) ::  lize3
2672    INTEGER, DIMENSION(3) ::  start3
2673
2674
2675    IF ( sm_io%is_sm_active() )  THEN
2676       CALL sm_io%sm_allocate_shared( array_3d_soil, nzb_soil, nzt_soil, sm_io%io_grid%nxl,        &
2677                                      sm_io%io_grid%nxr, sm_io%io_grid%nys, sm_io%io_grid%nyn,     &
2678                                      win_3ds )
2679    ELSE
2680       ALLOCATE( array_3d_soil(nzb_soil:nzt_soil,lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2681       sm_io%io_grid = lb
2682    ENDIF
2683
2684!
2685!-- Create filetype for 3d-soil array
2686    dims3(1)  = nzt_soil - nzb_soil + 1
2687    dims3(2)  = lb%nx + 1
2688    dims3(3)  = lb%ny + 1
2689
2690    lize3(1)  = dims3(1)
2691    lize3(2)  = sm_io%io_grid%nnx
2692    lize3(3)  = sm_io%io_grid%nny
2693
2694    start3(1) = nzb_soil
2695    start3(2) = sm_io%io_grid%nxl
2696    start3(3) = sm_io%io_grid%nys
2697
2698    IF ( sm_io%iam_io_pe )  THEN
2699       CALL MPI_TYPE_CREATE_SUBARRAY( 3, dims3, lize3, start3, MPI_ORDER_FORTRAN, MPI_REAL,        &
2700                                      ft_3dsoil, ierr )
2701       CALL MPI_TYPE_COMMIT( ft_3dsoil, ierr )
2702    ENDIF
2703
2704 END SUBROUTINE rd_mpi_io_create_filetypes_3dsoil
2705#endif
2706
2707
2708
2709!--------------------------------------------------------------------------------------------------!
2710! Description:
2711! ------------
2712!> Free all file types that have been created for MPI-IO.
2713!--------------------------------------------------------------------------------------------------!
2714 SUBROUTINE rd_mpi_io_free_filetypes
2715
2716    IMPLICIT NONE
2717
2718
2719#if defined( __parallel )
2720    IF ( filetypes_created )  THEN
2721
2722       IF ( sm_io%iam_io_pe )  THEN
2723          CALL MPI_TYPE_FREE( ft_2d, ierr )
2724          CALL MPI_TYPE_FREE( ft_2di_nb, ierr )
2725          CALL MPI_TYPE_FREE( ft_3d, ierr )
2726       ENDIF
2727
2728       IF ( sm_io%is_sm_active() )  THEN
2729          CALL sm_io%sm_free_shared( win_2dr )
2730          CALL sm_io%sm_free_shared( win_2di )
2731          CALL sm_io%sm_free_shared( win_3dr )
2732       ELSE
2733          DEALLOCATE( array_2d, array_2di, array_3d )
2734       ENDIF
2735
2736    ENDIF
2737!
2738!-- Free last surface filetype
2739    IF ( sm_io%iam_io_pe .AND. ft_surf /= -1 )  THEN
2740       CALL MPI_TYPE_FREE( ft_surf, ierr )
2741    ENDIF
2742
2743    IF ( sm_io%is_sm_active() .AND.  win_surf /= -1 )  THEN
2744       CALL sm_io%sm_free_shared( win_surf )
2745    ENDIF
2746
2747    ft_surf  = -1
2748    win_surf = -1
2749#else
2750    DEALLOCATE( array_2d, array_2di, array_3d )
2751#endif
2752
2753 END SUBROUTINE rd_mpi_io_free_filetypes
2754
2755
2756
2757!--------------------------------------------------------------------------------------------------!
2758! Description:
2759! ------------
2760!> Print the restart data file header (MPI-IO format) for debugging.
2761!--------------------------------------------------------------------------------------------------!
2762 SUBROUTINE rd_mpi_io_print_header
2763
2764    IMPLICIT NONE
2765
2766    INTEGER(iwp) ::  i
2767
2768
2769    WRITE (9,*)  'header position after reading the restart file header: ', header_position
2770    WRITE (9,*)  ' '
2771    WRITE (9,*)  'restart file header content:'
2772    WRITE (9,*)  '----------------------------'
2773    WRITE (9,*)  ' '
2774
2775    WRITE (9,*)  ' CHARACTER header values   Total number: ', tgh%nr_char
2776    WRITE (9,*)  ' '
2777    DO  i = 1, tgh%nr_char
2778       WRITE( 9, '(I3,A,1X,A)' )  i, ': ', text_lines(i)(1:80)
2779    ENDDO
2780    WRITE (9,*)  ' '
2781
2782    WRITE (9,*) ' INTEGER header variables and values   Total number: ', tgh%nr_int
2783    WRITE (9,*)  ' '
2784    DO  i = 1, tgh%nr_int
2785       WRITE(9,*)  ' variable: ', int_names(i), '  value: ', int_values(i)
2786    ENDDO
2787    WRITE (9,*)  ' '
2788
2789    WRITE (9,*)  ' REAL header variables and values   Total number: ', tgh%nr_real
2790    WRITE (9,*)  ' '
2791    DO  i = 1, tgh%nr_real
2792       WRITE(9,*)  ' variable: ', real_names(i), '  value: ', real_values(i)
2793    ENDDO
2794    WRITE (9,*)  ' '
2795
2796    WRITE (9,*)  ' Header entries with offset (2d/3d arrays)   Total number: ', tgh%nr_arrays
2797    WRITE (9,*)  ' '
2798    DO  i = 1, tgh%nr_arrays
2799       WRITE(9,*)  ' variable: ', array_names(i), '  offset: ', array_offset(i)
2800    ENDDO
2801    WRITE (9,*)  ' '
2802
2803 END SUBROUTINE rd_mpi_io_print_header
2804
2805
2806
2807!--------------------------------------------------------------------------------------------------!
2808! Description:
2809! ------------
2810!> Check if big/little endian data format is used.
2811!> An int*4 pointer is set to a int*8 variable, the int*8 is set to 1, and then it is checked, if
2812!> the first 4 bytes of the pointer are equal 1 (little endian) or not.
2813!--------------------------------------------------------------------------------------------------!
2814 SUBROUTINE rd_mpi_io_check_endian( i_endian )
2815
2816    IMPLICIT NONE
2817
2818    INTEGER, INTENT(out)                   ::  i_endian
2819    INTEGER(KIND=8), TARGET                ::  int8
2820
2821    INTEGER, DIMENSION(1)                  ::  bufshape
2822    INTEGER(KIND=4), POINTER, DIMENSION(:) ::  int4
2823
2824    TYPE(C_PTR)                            ::  ptr
2825
2826
2827    ptr = C_LOC( int8 )
2828    bufshape(1) = 2
2829    CALL C_F_POINTER( ptr, int4, bufshape )
2830
2831    int8 = 1
2832
2833    IF ( int4(1) == 1 )  THEN
2834       i_endian = 1    ! little endian
2835    ELSE
2836       i_endian = 2    ! big endian
2837    ENDIF
2838
2839 END SUBROUTINE rd_mpi_io_check_endian
2840
2841 END MODULE restart_data_mpi_io_mod
Note: See TracBrowser for help on using the repository browser.