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

Last change on this file since 4598 was 4598, checked in by suehring, 8 months ago

Revise and bugfix surface-element mapping and 3D soil array in mpi-io restart branch

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