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

Last change on this file since 4495 was 4495, checked in by raasch, 4 years ago

restart data handling with MPI-IO added, first part

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