Index: /palm/trunk/SOURCE/restart_data_mpi_io_mod.f90
===================================================================
--- /palm/trunk/SOURCE/restart_data_mpi_io_mod.f90	(revision 4590)
+++ /palm/trunk/SOURCE/restart_data_mpi_io_mod.f90	(revision 4591)
@@ -1,4 +1,4 @@
 !> @file restart_data_mpi_io_mod.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
@@ -15,38 +15,43 @@
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-! -------------------------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
-! checks added, if index limits in header are exceeded
-! bugfix in rrd_mpi_io_int_2d
-! 
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 4539 2020-05-18 14:05:17Z raasch
+! Checks added, if index limits in header are exceeded
+! Bugfix in rrd_mpi_io_int_2d
+!
 ! 4536 2020-05-17 17:24:13Z raasch
-! messages and debug output converted to PALM routines
-! 
+! Messages and debug output converted to PALM routines
+!
 ! 4534 2020-05-14 18:35:22Z raasch
 ! I/O on reduced number of cores added (using shared memory MPI)
-! 
+!
 ! 4500 2020-04-17 10:12:45Z suehring
 ! Fix too long lines
-! 
+!
 ! 4498 2020-04-15 14:26:31Z raasch
-! bugfix for creation of filetypes, argument removed from rd_mpi_io_open
-! 
+! Bugfix for creation of filetypes, argument removed from rd_mpi_io_open
+!
 ! 4497 2020-04-15 10:20:51Z raasch
-! last bugfix deactivated because of compile problems
-! 
+! Last bugfix deactivated because of compile problems
+!
 ! 4496 2020-04-15 08:37:26Z raasch
-! problem with posix read arguments for surface data fixed
-! 
+! Problem with posix read arguments for surface data fixed
+!
 ! 4495 2020-04-13 20:11:20Z raasch
 ! Initial version (K. Ketelsen), adjusted to PALM formatting standards (s. Raasch)
 !
-! 
+!
 !
 ! Description:
@@ -64,5 +69,9 @@
 #else
     USE posix_interface,                                                                           &
-        ONLY:  posix_close, posix_lseek, posix_open, posix_read, posix_write
+        ONLY:  posix_close,                                                                        &
+               posix_lseek,                                                                        &
+               posix_open,                                                                         &
+               posix_read,                                                                         &
+               posix_write
 #endif
 
@@ -70,26 +79,56 @@
 
     USE control_parameters,                                                                        &
-        ONLY:  debug_output, debug_string, include_total_domain_boundaries, message_string,        &
-               restart_data_format_input, restart_data_format_output, restart_file_size
+        ONLY:  debug_output,                                                                       &
+               debug_string,                                                                       &
+               include_total_domain_boundaries,                                                    &
+               message_string,                                                                     &
+               restart_data_format_input,                                                          &
+               restart_data_format_output,                                                         &
+               restart_file_size
 
     USE exchange_horiz_mod,                                                                        &
-        ONLY:  exchange_horiz, exchange_horiz_2d
+        ONLY:  exchange_horiz,                                                                     &
+               exchange_horiz_2d
 
     USE indices,                                                                                   &
-        ONLY:  nbgp, nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, nzb, nzt
+        ONLY:  nbgp,                                                                               &
+               nnx,                                                                                &
+               nny,                                                                                &
+               nx,                                                                                 &
+               nxl,                                                                                &
+               nxlg,                                                                               &
+               nxr,                                                                                &
+               nxrg,                                                                               &
+               ny,                                                                                 &
+               nyn,                                                                                &
+               nyng,                                                                               &
+               nys,                                                                                &
+               nysg,                                                                               &
+               nz,                                                                                 &
+               nzb,                                                                                &
+               nzt
 
     USE kinds
 
     USE pegrid,                                                                                    &
-        ONLY:  comm1dx, comm1dy, comm2d, myid, myidx, myidy, npex, npey, numprocs, pdims
+        ONLY:  comm1dx,                                                                            &
+               comm1dy,                                                                            &
+               comm2d,                                                                             &
+               myid,                                                                               &
+               myidx,                                                                              &
+               myidy,                                                                              &
+               npex,                                                                               &
+               npey,                                                                               &
+               numprocs,                                                                           &
+               pdims
 
     USE shared_memory_io_mod,                                                                      &
-        ONLY:  local_boundaries, sm_class
-
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=128) :: io_file_name  !> internal variable to communicate filename between
-                                        !> different subroutines
+        ONLY:  local_boundaries,                                                                   &
+               sm_class
+
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=128) ::  io_file_name  !> internal variable to communicate filename between different subroutines
 
 #if defined( __parallel )
@@ -99,35 +138,35 @@
 #else
     INTEGER(iwp), PARAMETER ::  rd_offset_kind = C_SIZE_T         !<
-    INTEGER(iwp), PARAMETER ::  rd_status_size = 1       !< Not required in sequential mode
-#endif
-
-    INTEGER(iwp)            ::  debug_level = 1 !< TODO: replace with standard debug output steering
-
-    INTEGER(iwp)            ::  comm_io       !< Communicator for MPI-IO
-    INTEGER(iwp)            ::  fh            !< MPI-IO file handle
-#if defined( __parallel )
-    INTEGER(iwp)            ::  fhs = -1      !< MPI-IO file handle to open file with comm2d always
-#endif
-    INTEGER(iwp)            ::  ft_surf = -1  !< MPI filetype surface data
-#if defined( __parallel )
-    INTEGER(iwp)            ::  ft_2di_nb     !< MPI filetype 2D array INTEGER no outer boundary
-    INTEGER(iwp)            ::  ft_2d         !< MPI filetype 2D array REAL with outer boundaries
-    INTEGER(iwp)            ::  ft_3d         !< MPI filetype 3D array REAL with outer boundaries
-    INTEGER(iwp)            ::  ft_3dsoil     !< MPI filetype for 3d-soil array
-#endif
-    INTEGER(iwp)            ::  glo_start     !< global start index on this PE
-#if defined( __parallel )
-    INTEGER(iwp)            ::  local_start   !<
-#endif
-    INTEGER(iwp)            ::  nr_iope       !<
-    INTEGER(iwp)            ::  nr_val        !< local number of values in x and y direction
-#if defined( __parallel )
-    INTEGER(iwp)            ::  win_2di
-    INTEGER(iwp)            ::  win_2dr
-    INTEGER(iwp)            ::  win_3dr
-    INTEGER(iwp)            ::  win_3ds
-    INTEGER(iwp)            ::  win_surf = -1
-#endif
-    INTEGER(iwp)            ::  total_number_of_surface_values    !< total number of values for one variable
+    INTEGER(iwp), PARAMETER ::  rd_status_size = 1                !< Not required in sequential mode
+#endif
+
+    INTEGER(iwp)            ::  debug_level = 1  !< TODO: replace with standard debug output steering
+
+    INTEGER(iwp)            ::  comm_io          !< Communicator for MPI-IO
+    INTEGER(iwp)            ::  fh               !< MPI-IO file handle
+#if defined( __parallel )
+    INTEGER(iwp)            ::  fhs = -1         !< MPI-IO file handle to open file with comm2d always
+#endif
+    INTEGER(iwp)            ::  ft_surf = -1     !< MPI filetype surface data
+#if defined( __parallel )
+    INTEGER(iwp)            ::  ft_2di_nb        !< MPI filetype 2D array INTEGER no outer boundary
+    INTEGER(iwp)            ::  ft_2d            !< MPI filetype 2D array REAL with outer boundaries
+    INTEGER(iwp)            ::  ft_3d            !< MPI filetype 3D array REAL with outer boundaries
+    INTEGER(iwp)            ::  ft_3dsoil        !< MPI filetype for 3d-soil array
+#endif
+    INTEGER(iwp)            ::  glo_start        !< global start index on this PE
+#if defined( __parallel )
+    INTEGER(iwp)            ::  local_start      !<
+#endif
+    INTEGER(iwp)            ::  nr_iope          !<
+    INTEGER(iwp)            ::  nr_val           !< local number of values in x and y direction
+#if defined( __parallel )
+    INTEGER(iwp)            ::  win_2di          !<
+    INTEGER(iwp)            ::  win_2dr          !<
+    INTEGER(iwp)            ::  win_3dr          !<
+    INTEGER(iwp)            ::  win_3ds          !<
+    INTEGER(iwp)            ::  win_surf = -1    !<
+#endif
+    INTEGER(iwp)            ::  total_number_of_surface_values  !< total number of values for one variable
 
     INTEGER(KIND=rd_offset_kind) ::  array_position   !<
@@ -137,12 +176,13 @@
 
     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_end_index     !<
+    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_global_start  !<
     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_start_index   !<
-    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  m_global_start  !<
-
-    LOGICAL ::  all_pes_write                     !< all PEs have data to write
-    LOGICAL ::  filetypes_created                 !<
-    LOGICAL ::  io_on_limited_cores_per_node      !< switch to shared memory MPI-IO
-    LOGICAL ::  rd_flag                           !< file is opened for read
-    LOGICAL ::  wr_flag                           !< file is opened for write
+
+
+    LOGICAL ::  all_pes_write                 !< all PEs have data to write
+    LOGICAL ::  filetypes_created             !<
+    LOGICAL ::  io_on_limited_cores_per_node  !< switch to shared memory MPI-IO
+    LOGICAL ::  rd_flag                       !< file is opened for read
+    LOGICAL ::  wr_flag                       !< file is opened for write
 
 #if defined( __parallel )
@@ -160,17 +200,17 @@
 !-- General Header (first 32 byte in restart file)
     TYPE general_header
+       INTEGER(iwp) :: endian         !< little endian (1) or big endian (2) internal format
+       INTEGER(iwp) :: i_outer_bound  !< if 1, outer boundaries are stored in restart file
+       INTEGER(iwp) :: nr_arrays      !< number of arrays in restart files
+       INTEGER(iwp) :: nr_char        !< number of Text strings entries in header
        INTEGER(iwp) :: nr_int         !< number of INTEGER entries in header
-       INTEGER(iwp) :: nr_char        !< number of Text strings entries in header
        INTEGER(iwp) :: nr_real        !< number of REAL entries in header
-       INTEGER(iwp) :: nr_arrays      !< number of arrays in restart files
        INTEGER(iwp) :: total_nx       !< total number of points in x-direction
        INTEGER(iwp) :: total_ny       !< total number of points in y-direction
-       INTEGER(iwp) :: i_outer_bound  !< if 1, outer boundaries are stored in restart file
-       INTEGER(iwp) :: endian         !< little endian (1) or big endian (2) internal format
     END TYPE general_header
 
-    TYPE(general_header), TARGET ::  tgh
-
-    TYPE(sm_class)               ::  sm_io
+    TYPE(general_header), TARGET ::  tgh    !<
+
+    TYPE(sm_class)               ::  sm_io  !<
 
 !
@@ -194,5 +234,4 @@
     CHARACTER(LEN=32), DIMENSION(max_nr_arrays) ::  array_names
     INTEGER(KIND=rd_offset_kind), DIMENSION(max_nr_arrays) :: array_offset
-
     SAVE
 
@@ -267,7 +306,14 @@
     END INTERFACE wrd_mpi_io_surface
 
-    PUBLIC  rd_mpi_io_check_array, rd_mpi_io_close, rd_mpi_io_open, rrd_mpi_io,                    &
-            rrd_mpi_io_global_array, rrd_mpi_io_surface, rd_mpi_io_surface_filetypes, wrd_mpi_io,  &
-            wrd_mpi_io_global_array, wrd_mpi_io_surface
+    PUBLIC  rd_mpi_io_check_array,                                                                 &
+            rd_mpi_io_close,                                                                       &
+            rd_mpi_io_open,                                                                        &
+            rrd_mpi_io,                                                                            &
+            rrd_mpi_io_global_array,                                                               &
+            rrd_mpi_io_surface,                                                                    &
+            rd_mpi_io_surface_filetypes,                                                           &
+            wrd_mpi_io,                                                                            &
+            wrd_mpi_io_global_array,                                                               &
+            wrd_mpi_io_surface
 
 
@@ -284,21 +330,21 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)  ::  action                           !<
-    CHARACTER(LEN=*), INTENT(IN)  ::  file_name                        !<
-
-    INTEGER(iwp)                  ::  i                                !<
-    INTEGER(iwp)                  ::  gh_size                          !<
-
-    INTEGER(KIND=rd_offset_kind)  ::  offset                           !<
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status                      !<
-#endif
-
-    LOGICAL, INTENT(IN), OPTIONAL ::  open_for_global_io_only          !<
-    LOGICAL                       ::  set_filetype                     !<
+    CHARACTER(LEN=*), INTENT(IN) ::  action     !<
+    CHARACTER(LEN=*), INTENT(IN) ::  file_name  !<
+
+    INTEGER(iwp)                 ::  i          !<
+    INTEGER(iwp)                 ::  gh_size    !<
+
+    INTEGER(KIND=rd_offset_kind) ::  offset     !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    LOGICAL, INTENT(IN), OPTIONAL ::  open_for_global_io_only  !<
+    LOGICAL                       ::  set_filetype             !<
 
 #if ! defined( __parallel )
-    TYPE(C_PTR)                   ::  buf_ptr                          !<
+    TYPE(C_PTR)                   ::  buf_ptr  !<
 #endif
 
@@ -377,5 +423,5 @@
 
           IF ( ierr /= 0 )  THEN
-             message_string = 'error opening restart file "' // TRIM( io_file_name ) //      &
+             message_string = 'error opening restart file "' // TRIM( io_file_name ) //            &
                               '" for reading with MPI-IO'
              CALL message( 'rrd_mpi_io_open', 'PA0727', 3, 2, 0, 6, 0 )
@@ -400,5 +446,5 @@
 
           IF ( ierr /= 0 )  THEN
-             message_string = 'error opening restart file "' // TRIM( io_file_name ) //      &
+             message_string = 'error opening restart file "' // TRIM( io_file_name ) //            &
                               '" for writing with MPI-IO'
              CALL message( 'rrd_mpi_io_open', 'PA0728', 3, 2, 0, 6, 0 )
@@ -418,5 +464,5 @@
 
        IF ( debug_output )  THEN
-          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
+          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //               &
                                     '" for read in serial mode (posix)'
           CALL debug_message( debug_string, 'start' )
@@ -426,5 +472,5 @@
 
        IF ( debug_output )  THEN
-          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
+          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //               &
                                     '" for read in serial mode (posix)'
           CALL debug_message( debug_string, 'end' )
@@ -434,5 +480,5 @@
 
        IF ( debug_output )  THEN
-          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
+          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //               &
                                     '" for write in serial mode (posix)'
           CALL debug_message( debug_string, 'start' )
@@ -442,5 +488,5 @@
 
        IF ( debug_output )  THEN
-          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //            &
+          WRITE( debug_string, * )  'open restart file "' // TRIM( io_file_name ) //               &
                                     '" for write in serial mode (posix)'
           CALL debug_message( debug_string, 'end' )
@@ -479,5 +525,5 @@
     header_int_index = header_int_index+3
 
-    DO   i = 1, max_nr_arrays
+    DO  i = 1, max_nr_arrays
        array_offset(i) = 0
        array_names(i)  = ' '
@@ -489,5 +535,5 @@
        IF ( sm_io%iam_io_pe )  THEN
 !
-!--       File is open for read.
+!--       File is open for reading
 #if defined( __parallel )
 !--       Set the default view
@@ -513,5 +559,5 @@
 
 !
-!--    File types depend on if boundaries of the total domain is included in data. This has been
+!--    File types depend on boundaries of the total domain being included in data. This has been
 !--    checked with the previous statement.
        IF ( set_filetype )  THEN
@@ -535,5 +581,5 @@
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
           CALL MPI_FILE_READ( fh, text_lines, SIZE( text_lines ) * 128, MPI_CHAR, status, ierr )
-          header_position = header_position+size(text_lines) * 128
+          header_position = header_position + SIZE ( text_lines ) * 128
 !
 !--       REAL values
@@ -640,5 +686,5 @@
     INTEGER(iwp) ::  i  !<
 
-    LOGICAl      ::  found  !<
+    LOGICAl ::  found  !<
 
 
@@ -666,10 +712,10 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)   :: name
-
-    INTEGER(iwp)                   ::  i
-    INTEGER(KIND=iwp), INTENT(OUT) ::  value
-
-    LOGICAL                        ::  found
+    CHARACTER(LEN=*), INTENT(IN) :: name  !<
+
+    INTEGER(iwp)                   ::  i      !<
+    INTEGER(KIND=iwp), INTENT(OUT) ::  value  !<
+
+    LOGICAL ::  found  !<
 
 
@@ -703,11 +749,11 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)   ::  name
-
-    INTEGER(iwp)                   ::  i
-
-    LOGICAL                        ::  found
-
-    REAL(KIND=wp), INTENT(OUT)     ::  value
+    CHARACTER(LEN=*), INTENT(IN) ::  name   !<
+
+    INTEGER(iwp)                 ::  i      !<
+
+    LOGICAL                      ::  found  !<
+
+    REAL(KIND=wp), INTENT(OUT)   ::  value  !<
 
 
@@ -741,14 +787,14 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-    INTEGER(iwp)                       ::  i
-
-    LOGICAL                            ::  found
-
-    REAL(wp), INTENT(INOUT), DIMENSION(nysg:nyng,nxlg:nxrg) ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+    INTEGER(iwp)                       ::  i       !<
+
+    LOGICAL                            ::  found   !<
+
+    REAL(wp), INTENT(INOUT), DIMENSION(nysg:nyng,nxlg:nxrg) ::  data  !<
 
 
@@ -765,7 +811,7 @@
     IF ( found )  THEN
 #if defined( __parallel )
-       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+       CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
        IF ( sm_io%iam_io_pe )  THEN
-          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL,   &
+          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL,    &
                                   ierr )
           CALL MPI_FILE_READ_ALL( fh, array_2d, SIZE( array_2d ), MPI_REAL, status, ierr )
@@ -809,16 +855,16 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)        ::  name
-
-    INTEGER(iwp)                        ::  i
-    INTEGER(iwp)                        ::  j
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)  ::  status
-#endif
-
-    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:,:) ::  data
-
-    LOGICAL                             ::  found
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+    INTEGER(iwp)                       ::  i       !<
+    INTEGER(iwp)                       ::  j       !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:,:) ::  data  !<
+
+    LOGICAL ::  found  !<
 
 
@@ -835,9 +881,9 @@
     IF ( found )  THEN
 
-       IF ( ( nxr - nxl + 1 + 2*nbgp ) == SIZE( data, 2 ) )  THEN
+       IF ( ( nxr - nxl + 1 + 2 * nbgp ) == SIZE( data, 2 ) )  THEN
 !
 !--       Output array with Halos.
-!--       ATTENTION: INTEGER array with ghost boundaries are not implemented yet. This kind of array
-!--                  would be dimensioned in the caller subroutine like this:
+!--       ATTENTION: INTEGER arrays with ghost boundaries are not implemented yet. This kind of
+!--                  array would be dimensioned in the caller subroutine like this:
 !--                  INTEGER, DIMENSION(nysg:nyng,nxlg:nxrg)::  data
           message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be read from restart ' // &
@@ -845,5 +891,5 @@
           CALL message( 'rrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
 
-       ELSEIF ( (nxr-nxl+1) == SIZE( data, 2 ) )  THEN
+       ELSEIF ( (nxr - nxl + 1) == SIZE( data, 2 ) )  THEN
 !
 !--       INTEGER input array without Halos.
@@ -852,5 +898,5 @@
 
 #if defined( __parallel )
-          CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
+          CALL sm_io%sm_node_barrier() ! Has no effect if I/O on limited number of cores is inactive
           IF ( sm_io%iam_io_pe )  THEN
              CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native',         &
@@ -898,15 +944,15 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    LOGICAL                            ::  found
-
-    REAL(wp), INTENT(INOUT), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+    INTEGER(iwp)                       ::  i       !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    LOGICAL                            ::  found   !<
+
+    REAL(wp), INTENT(INOUT), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  data  !<
 
 
@@ -923,5 +969,5 @@
     IF ( found )  THEN
 #if defined( __parallel )
-       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+       CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
        IF( sm_io%iam_io_pe )  THEN
           CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL,    &
@@ -968,17 +1014,17 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-    INTEGER, INTENT(IN)                ::  nzb_soil
-    INTEGER, INTENT(IN)                ::  nzt_soil
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    LOGICAL                            ::  found
-
-    REAL(wp), INTENT(INOUT), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name      !<
+
+    INTEGER(iwp)                       ::  i         !<
+    INTEGER, INTENT(IN)                ::  nzb_soil  !<
+    INTEGER, INTENT(IN)                ::  nzt_soil  !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status    !<
+#endif
+
+    LOGICAL                            ::  found     !<
+
+    REAL(wp), INTENT(INOUT), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) ::  data  !<
 
 
@@ -996,8 +1042,8 @@
 #if defined( __parallel )
        CALL rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
-       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+       CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
        IF ( sm_io%iam_io_pe )  THEN
-          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL,&
-                                  ierr )
+          CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native',               &
+                                  MPI_INFO_NULL, ierr )
           CALL MPI_FILE_READ_ALL( fh, array_3d_soil, SIZE( array_3d_soil ), MPI_REAL, status, ierr )
           CALL MPI_TYPE_FREE( ft_3dsoil, ierr )
@@ -1038,11 +1084,11 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)   ::  name
-    CHARACTER(LEN=*), INTENT(OUT)  ::  text
-    CHARACTER(LEN=128)             ::  line
-
-    INTEGER(iwp)                   ::  i
-
-    LOGICAL                        ::  found
+    CHARACTER(LEN=*), INTENT(IN)  ::  name   !<
+    CHARACTER(LEN=*), INTENT(OUT) ::  text   !<
+    CHARACTER(LEN=128)            ::  line   !<
+
+    INTEGER(iwp)                  ::  i      !<
+
+    LOGICAL                       ::  found  !<
 
 
@@ -1077,9 +1123,9 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN) ::  name
-
-    INTEGER(iwp)                 ::  logical_as_integer
-
-    LOGICAL, INTENT(OUT)         ::  value
+    CHARACTER(LEN=*), INTENT(IN) ::  name                !<
+
+    INTEGER(iwp)                 ::  logical_as_integer  !<
+
+    LOGICAL, INTENT(OUT)         ::  value               !<
 
 
@@ -1100,7 +1146,7 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)  ::  name
-
-    INTEGER(KIND=iwp), INTENT(IN) ::  value
+    CHARACTER(LEN=*), INTENT(IN)  ::  name   !<
+
+    INTEGER(KIND=iwp), INTENT(IN) ::  value  !<
 
 
@@ -1116,12 +1162,16 @@
 
 
-
+!--------------------------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> To do: Description missing!
+!--------------------------------------------------------------------------------------------------!
  SUBROUTINE wrd_mpi_io_real( name, value )
 
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN) ::  name
-
-    REAL(wp), INTENT(IN)         ::  value
+    CHARACTER(LEN=*), INTENT(IN) ::  name   !<
+
+    REAL(wp), INTENT(IN)         ::  value  !<
 
 
@@ -1147,13 +1197,13 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    REAL(wp), INTENT(IN), DIMENSION(nysg:nyng,nxlg:nxrg)    :: data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+    INTEGER(iwp)                       ::  i       !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    REAL(wp), INTENT(IN), DIMENSION(nysg:nyng,nxlg:nxrg) ::  data  !<
 
 
@@ -1168,5 +1218,5 @@
     IF ( include_total_domain_boundaries )  THEN
 !
-!--    Prepare Output with outer boundaries
+!--    Prepare output with outer boundaries
        DO  i = lb%nxl, lb%nxr
           array_2d(i,lb%nys:lb%nyn) = data(lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
@@ -1175,5 +1225,5 @@
     ELSE
 !
-!--    Prepare Output without outer boundaries
+!--    Prepare output without outer boundaries
        DO  i = nxl,nxr
           array_2d(i,lb%nys:lb%nyn) = data(nys:nyn,i)
@@ -1183,5 +1233,5 @@
 
 #if defined( __parallel )
-    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+    CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
     IF ( sm_io%iam_io_pe )  THEN
        CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL, ierr )
@@ -1194,5 +1244,5 @@
 #endif
 !
-!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
+!-- Type conversion required, otherwise right hand side brackets are calculated assuming 4 byte INT.
 !-- Maybe a compiler problem.
     array_position = array_position + ( INT( lb%ny, KIND=rd_offset_kind ) + 1 ) *                  &
@@ -1212,13 +1262,13 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                  ::  name
-
-    INTEGER(iwp)                                  ::  i
-    INTEGER(iwp)                                  ::  j
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)            ::  status
-#endif
-    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:,:) ::  data
+    CHARACTER(LEN=*), INTENT(IN)                  ::  name    !<
+
+    INTEGER(iwp)                                  ::  i       !<
+    INTEGER(iwp)                                  ::  j       !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size)            ::  status  !<
+#endif
+    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:,:) ::  data    !<
 
 
@@ -1231,5 +1281,5 @@
     header_array_index = header_array_index + 1
 
-    IF ( ( nxr-nxl + 1 + 2 * nbgp ) == SIZE( data, 2 ) )  THEN
+    IF ( ( nxr - nxl + 1 + 2 * nbgp ) == SIZE( data, 2 ) )  THEN
 !
 !--    Integer arrays with ghost layers are not implemented yet. These kind of arrays would be
@@ -1251,5 +1301,5 @@
        ENDDO
 #if defined( __parallel )
-       CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+       CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
        IF ( sm_io%iam_io_pe )  THEN
           CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native',            &
@@ -1289,11 +1339,11 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-    REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+    INTEGER(iwp)                       ::  i       !<
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+    REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  data !<
 
 
@@ -1308,9 +1358,8 @@
     IF ( include_total_domain_boundaries )  THEN
 !
-!--    Prepare output of 3d-REAL-array with ghost layers.
-!--    In the virtual PE grid, the first dimension is PEs along x, and the second along y.
-!--    For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
-!--    the first dimension should be along x and the second along y.
-!--    For this reason, the original PALM data need to be swaped.
+!--    Prepare output of 3d-REAL-array with ghost layers. In the virtual PE grid, the first
+!--    dimension is PEs along x, and the second along y. For MPI-IO it is recommended to have the
+!--    index order of the array in the same way, i.e. the first dimension should be along x and the
+!--    second along y. For this reason, the original PALM data need to be swaped.
        DO  i = lb%nxl, lb%nxr
           array_3d(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
@@ -1326,5 +1375,5 @@
     ENDIF
 #if defined( __parallel )
-    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+    CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
     IF ( sm_io%iam_io_pe )  THEN
        CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL, ierr )
@@ -1337,9 +1386,9 @@
 #endif
 !
-!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
+!-- Type conversion required, otherwise right hand side brackets are calculated assuming 4 byte INT.
 !-- Maybe a compiler problem.
-    array_position = array_position + INT(    (nz+2), KIND=rd_offset_kind ) *                      &
-                                      INT( (lb%ny+1), KIND=rd_offset_kind ) *                      &
-                                      INT( (lb%nx+1), KIND=rd_offset_kind ) * wp
+    array_position = array_position + INT(    (nz+2), KIND = rd_offset_kind ) *                    &
+                                      INT( (lb%ny+1), KIND = rd_offset_kind ) *                    &
+                                      INT( (lb%nx+1), KIND = rd_offset_kind ) * wp
 
  END SUBROUTINE wrd_mpi_io_real_3d
@@ -1358,15 +1407,15 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-    INTEGER, INTENT(IN)                ::  nzb_soil
-    INTEGER, INTENT(IN)                ::  nzt_soil
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    REAL(wp), INTENT(IN), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg)  ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name      !<
+
+    INTEGER(iwp)                       ::  i         !<
+    INTEGER, INTENT(IN)                ::  nzb_soil  !<
+    INTEGER, INTENT(IN)                ::  nzt_soil  !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    REAL(wp), INTENT(IN), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) ::  data  !<
 
 
@@ -1385,9 +1434,8 @@
     IF ( include_total_domain_boundaries)  THEN
 !
-!--    Prepare output of 3d-REAL-array with ghost layers.
-!--    In the virtual PE grid, the first dimension is PEs along x, and the second along y.
-!--    For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
-!--    the first dimension should be along x and the second along y.
-!--    For this reason, the original PALM data need to be swaped.
+!--    Prepare output of 3d-REAL-array with ghost layers. In the virtual PE grid, the first
+!--    dimension is PEs along x, and the second along y. For MPI-IO it is recommended to have the
+!--    index order of the array in the same way, i.e. the first dimension should be along x and the
+!--    second along y. For this reason, the original PALM data need to be swaped.
        DO  i = lb%nxl, lb%nxr
           array_3d_soil(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
@@ -1403,5 +1451,5 @@
     ENDIF
 #if defined( __parallel )
-    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+    CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
     IF ( sm_io%iam_io_pe )  THEN
        CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL,   &
@@ -1415,9 +1463,9 @@
 #endif
 !
-!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
+!-- Type conversion required, otherwise right hand side brackets are calculated assuming 4 byte INT.
 !-- Maybe a compiler problem.
-    array_position = array_position + INT( (nzt_soil-nzb_soil+1), KIND=rd_offset_kind ) *          &
-                                      INT( (lb%ny+1),             KIND=rd_offset_kind ) *          &
-                                      INT( (lb%nx+1),             KIND=rd_offset_kind ) * wp
+    array_position = array_position + INT( (nzt_soil-nzb_soil+1), KIND = rd_offset_kind ) *        &
+                                      INT( (lb%ny+1),             KIND = rd_offset_kind ) *        &
+                                      INT( (lb%nx+1),             KIND = rd_offset_kind ) * wp
 
  END SUBROUTINE wrd_mpi_io_real_3d_soil
@@ -1434,7 +1482,7 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=128)           ::  lo_line
-    CHARACTER(LEN=*), INTENT(IN) ::  name
-    CHARACTER(LEN=*), INTENT(IN) ::  text
+    CHARACTER(LEN=128)           ::  lo_line  !<
+    CHARACTER(LEN=*), INTENT(IN) ::  name     !<
+    CHARACTER(LEN=*), INTENT(IN) ::  text     !<
 
 
@@ -1461,9 +1509,9 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN) ::  name
-
-    INTEGER(iwp)                 ::  logical_as_integer
-
-    LOGICAL, INTENT(IN)          ::  value
+    CHARACTER(LEN=*), INTENT(IN) ::  name                !<
+
+    INTEGER(iwp)                 ::  logical_as_integer  !<
+
+    LOGICAL, INTENT(IN)          ::  value               !<
 
 
@@ -1490,16 +1538,16 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-    INTEGER(iwp)                       ::  i
-    INTEGER(KIND=rd_offset_kind)       ::  offset
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    LOGICAL                            ::  found
-
-    REAL(KIND=wp), INTENT(INOUT), DIMENSION(:) ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name    !<
+
+    INTEGER(iwp)                       ::  i       !<
+    INTEGER(KIND=rd_offset_kind)       ::  offset  !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status  !<
+#endif
+
+    LOGICAL                            ::  found   !<
+
+    REAL(KIND=wp), INTENT(INOUT), DIMENSION(:) ::  data  !<
 
 
@@ -1525,5 +1573,5 @@
        ENDIF
        IF ( sm_io%is_sm_active() )  THEN
-          CALL MPI_BCAST( data, SIZE(data), MPI_REAL, 0, sm_io%comm_shared, ierr )
+          CALL MPI_BCAST( data, SIZE( data ), MPI_REAL, 0, sm_io%comm_shared, ierr )
        ENDIF
 #else
@@ -1554,12 +1602,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                      ::  name
-
-    INTEGER, DIMENSION(1)                             ::  bufshape
-
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data
-    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf
-
-    TYPE(C_PTR)                                       ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                      ::  name      !<
+
+    INTEGER, DIMENSION(1)                             ::  bufshape  !<
+
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data      !<
+    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf       !<
+
+    TYPE(C_PTR)                                       ::  c_data    !<
 
 
@@ -1584,12 +1632,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                        ::  name
-
-    INTEGER, DIMENSION(1)                               ::  bufshape
-
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data
-    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf
-
-    TYPE(C_PTR)                                         ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                        ::  name      !<
+
+    INTEGER, DIMENSION(1)                               ::  bufshape  !<
+
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data      !<
+    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf       !<
+
+    TYPE(C_PTR)                                         ::  c_data    !<
 
 
@@ -1614,12 +1662,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                          ::  name
-
-    INTEGER, DIMENSION(1)                                 ::  bufshape
-
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data
-    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf
-
-    TYPE(C_PTR)                                           ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                          ::  name      !<
+
+    INTEGER, DIMENSION(1)                                 ::  bufshape  !<
+
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data      !<
+    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf       !<
+
+    TYPE(C_PTR)                                           ::  c_data    !<
 
 
@@ -1644,15 +1692,15 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                   ::  name
-
-    INTEGER(iwp)                                   ::  i
-    INTEGER(KIND=rd_offset_kind)                   ::  offset
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)             ::  status
-#endif
-    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:) ::  data
-
-    LOGICAL                                        ::  found
+    CHARACTER(LEN=*), INTENT(IN)                   ::  name    !<
+
+    INTEGER(iwp)                                   ::  i       !<
+    INTEGER(KIND=rd_offset_kind)                   ::  offset  !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size)             ::  status  !<
+#endif
+    INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:) ::  data    !<
+
+    LOGICAL                                        ::  found   !<
 
 
@@ -1661,5 +1709,5 @@
 
     DO  i = 1, tgh%nr_arrays
-       IF ( TRIM(array_names(i)) == TRIM( name ) )  THEN
+       IF ( TRIM( array_names(i) ) == TRIM( name ) )  THEN
           array_position = array_offset(i)
           found = .TRUE.
@@ -1678,5 +1726,5 @@
        ENDIF
        IF ( sm_io%is_sm_active() )  THEN
-          CALL MPI_BCAST( data, SIZE(data), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
+          CALL MPI_BCAST( data, SIZE( data ), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
        ENDIF
 #else
@@ -1706,13 +1754,13 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)            ::  name
-
-    INTEGER(KIND=rd_offset_kind)            ::  offset
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)      ::  status
-#endif
-
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:) ::  data
+    CHARACTER(LEN=*), INTENT(IN)            ::  name    !<
+
+    INTEGER(KIND=rd_offset_kind)            ::  offset  !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size)      ::  status  !<
+#endif
+
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:) ::  data    !<
 
 
@@ -1737,5 +1785,5 @@
     IF ( myid == 0 )  THEN
        CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
-       CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_REAL, status, ierr )
+       CALL MPI_FILE_WRITE( fh, data, SIZE( data ), MPI_REAL, status, ierr )
     ENDIF
 #else
@@ -1759,12 +1807,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                      ::  name
-
-    INTEGER, DIMENSION(1)                             ::  bufshape
-
-    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data
-
-    TYPE(C_PTR)                                       ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                      ::  name      !<
+
+    INTEGER, DIMENSION(1)                             ::  bufshape  !<
+
+    REAL(KIND=wp), POINTER, DIMENSION(:)              ::  buf       !<
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET ::  data      !<
+
+    TYPE(C_PTR)                                       ::  c_data    !<
 
 
@@ -1789,12 +1837,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                        ::  name
-
-    INTEGER, DIMENSION(1)                               ::  bufshape
-
-    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data
-
-    TYPE(C_PTR)                                         ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                        ::  name      !<
+
+    INTEGER, DIMENSION(1)                               ::  bufshape  !<
+
+    REAL(KIND=wp), POINTER, DIMENSION(:)                ::  buf       !<
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET ::  data      !<
+
+    TYPE(C_PTR)                                         ::  c_data    !<
 
 
@@ -1819,12 +1867,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                          ::  name
-
-    INTEGER, DIMENSION(1)                                 ::  bufshape
-
-    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf
-    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data
-
-    TYPE(C_PTR)                                           ::  c_data
+    CHARACTER(LEN=*), INTENT(IN)                          ::  name      !<
+
+    INTEGER, DIMENSION(1)                                 ::  bufshape  !<
+
+    REAL(KIND=wp), POINTER, DIMENSION(:)                  ::  buf       !<
+    REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET ::  data      !<
+
+    TYPE(C_PTR)                                           ::  c_data    !<
 
 
@@ -1849,11 +1897,11 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)                ::  name
-
-    INTEGER(KIND=rd_offset_kind)                ::  offset
-
-    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:) ::  data
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)          ::  status
+    CHARACTER(LEN=*), INTENT(IN)                ::  name    !<
+
+    INTEGER(KIND=rd_offset_kind)                ::  offset  !<
+
+    INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:) ::  data    !<
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size)          ::  status  !<
 #endif
 
@@ -1875,5 +1923,5 @@
 !
 !-- Only PE 0 writes replicated data
-    IF ( myid == 0 )  THEN                        ! 
+    IF ( myid == 0 )  THEN
        CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
        CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_INTEGER, status, ierr )
@@ -1898,26 +1946,26 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN) ::  name
-
-    INTEGER(KIND=rd_offset_kind) ::  disp          !< displacement of actual indices
-    INTEGER(KIND=rd_offset_kind) ::  disp_f        !< displacement in file
-    INTEGER(KIND=rd_offset_kind) ::  disp_n        !< displacement of next column
-    INTEGER(iwp), OPTIONAL       ::  first_index
-
-    INTEGER(iwp)                 ::  i
-    INTEGER(iwp)                 ::  i_f
-    INTEGER(iwp)                 ::  j
-    INTEGER(iwp)                 ::  j_f
-    INTEGER(iwp)                 ::  lo_first_index
-    INTEGER(iwp)                 ::  nr_bytes
-    INTEGER(iwp)                 ::  nr_bytes_f
-    INTEGER(iwp)                 ::  nr_words
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size)  ::  status
-#endif
-
-    LOGICAL                             ::  found
-
-    REAL(wp), INTENT(OUT), DIMENSION(:) ::  data
+    CHARACTER(LEN=*), INTENT(IN) ::  name            !<
+
+    INTEGER(KIND=rd_offset_kind) ::  disp            !< displacement of actual indices
+    INTEGER(KIND=rd_offset_kind) ::  disp_f          !< displacement in file
+    INTEGER(KIND=rd_offset_kind) ::  disp_n          !< displacement of next column
+    INTEGER(iwp), OPTIONAL       ::  first_index     !<
+
+    INTEGER(iwp)                 ::  i               !<
+    INTEGER(iwp)                 ::  i_f             !<
+    INTEGER(iwp)                 ::  j               !<
+    INTEGER(iwp)                 ::  j_f             !<
+    INTEGER(iwp)                 ::  lo_first_index  !<
+    INTEGER(iwp)                 ::  nr_bytes        !<
+    INTEGER(iwp)                 ::  nr_bytes_f      !<
+    INTEGER(iwp)                 ::  nr_words        !<
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size)  ::  status   !<
+#endif
+
+    LOGICAL                             ::  found    !<
+
+    REAL(wp), INTENT(OUT), DIMENSION(:) ::  data     !<
 
 
@@ -1925,5 +1973,5 @@
     lo_first_index = 1
 
-    IF ( MAXVAL( m_global_start ) == -1 )   RETURN   ! nothing to do on this PE
+    IF ( MAXVAL( m_global_start ) == -1 )   RETURN   ! Nothing to do on this PE
 
     IF ( PRESENT( first_index ) )   THEN
@@ -1934,5 +1982,5 @@
         IF ( TRIM( array_names(i) ) == TRIM( name ) )  THEN
            array_position = array_offset(i) + ( lo_first_index - 1 ) *                             &
-                                              total_number_of_surface_values * wp
+                            total_number_of_surface_values * wp
            found = .TRUE.
            EXIT
@@ -1953,5 +2001,5 @@
                 nr_bytes = nr_words * wp
              ENDIF
-             IF ( disp >= 0  .AND.  disp_f == -1 )  THEN   ! first Entry
+             IF ( disp >= 0  .AND.  disp_f == -1 )  THEN   ! First entry
                 disp_f     = disp
                 nr_bytes_f = 0
@@ -1959,10 +2007,10 @@
                 j_f = j
              ENDIF
-             IF ( j == nyn  .AND.  i == nxr )  THEN        ! last Entry
+             IF ( j == nyn  .AND.  i == nxr )  THEN        ! Last entry
                 disp_n = -1
                 IF (  nr_bytes > 0 )  THEN
                    nr_bytes_f = nr_bytes_f+nr_bytes
                 ENDIF
-             ELSEIF ( j == nyn )  THEN                     ! next x
+             ELSEIF ( j == nyn )  THEN                     ! Next x
                 IF ( m_global_start(nys,i+1) > 0  .AND.  disp > 0 )  THEN
                    disp_n = array_position + ( m_global_start(nys,i+1) - 1 ) * wp
@@ -1979,11 +2027,12 @@
 
 
-             IF ( disp + nr_bytes == disp_n )  THEN        ! contiguous block
+             IF ( disp + nr_bytes == disp_n )  THEN        ! Contiguous block
                 nr_bytes_f = nr_bytes_f + nr_bytes
-             ELSE                                          ! read
+             ELSE                                          ! Read
 #if defined( __parallel )
                 CALL MPI_FILE_SEEK( fhs, disp_f, MPI_SEEK_SET, ierr )
                 nr_words = nr_bytes_f / wp
-                CALL MPI_FILE_READ( fhs, data(m_start_index(j_f,i_f)), nr_words, MPI_REAL, status, ierr )
+                CALL MPI_FILE_READ( fhs, data(m_start_index(j_f,i_f)), nr_words, MPI_REAL, status, &
+                                    ierr )
 #else
                 CALL posix_lseek( fh, disp_f )
@@ -2027,13 +2076,13 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)          ::  name
-
-    INTEGER(iwp)                          ::  i
-
-    REAL(wp), INTENT(OUT), DIMENSION(:,:) ::  data
-    REAL(wp), DIMENSION(SIZE( data,2))    ::  tmp
-
-
-    DO  i = 1, SIZE( data,1)
+    CHARACTER(LEN=*), INTENT(IN)          ::  name  !<
+
+    INTEGER(iwp)                          ::  i     !<
+
+    REAL(wp), INTENT(OUT), DIMENSION(:,:) ::  data  !<
+    REAL(wp), DIMENSION(SIZE( data,2))    ::  tmp   !<
+
+
+    DO  i = 1, SIZE( data, 1 )
        CALL rrd_mpi_io_surface( name, tmp, first_index = i )
        data(i,:) = tmp
@@ -2042,11 +2091,10 @@
 !
 !-- Comment from Klaus Ketelsen (September 2018)
-!-- The intention of the following loop was let the compiler do the copying on return.
-!-- In my understanding is it standard conform to pass the second dimension to a 1d-
-!-- array inside a subroutine and the compiler is responsible to generate code for
-!-- copying. Acually this works fine for INTENT(IN) variables (wrd_mpi_io_surface_2d).
-!-- For INTENT(OUT) like in this case the code works on pgi compiler. But both, the Intel 16
-!-- and the Cray compiler show wrong answers using this loop.
-!-- That is the reason why the above auxiliary array tmp was introduced.
+!-- The intention of the following loop was to let the compiler do the copying on return.
+!-- In my understanding it is standard conform to pass the second dimension to a 1d-array inside a
+!-- subroutine and the compiler is responsible to generate code for copying. Acually this works fine
+!-- for INTENT(IN) variables (wrd_mpi_io_surface_2d). For INTENT(OUT) like in this case the code
+!-- works on pgi compiler. But both, the Intel 16 and the Cray compiler show wrong answers using
+!-- this loop. That is the reason why the above auxiliary array tmp was introduced.
 !    DO  i = 1, SIZE(  data,1)
 !       CALL rrd_mpi_io_surface( name, data(i,:), first_index = i )
@@ -2066,21 +2114,21 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)       ::  name
-
-#if defined( __parallel )
-    INTEGER(KIND=rd_offset_kind)       ::  disp
-#endif
-    INTEGER(iwp), OPTIONAL             ::  first_index
-#if defined( __parallel )
-    INTEGER(iwp)                       ::  i
-#endif
-    INTEGER(iwp)                       ::  lo_first_index
-    INTEGER(KIND=rd_offset_kind)       ::  offset
-
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
-#endif
-
-    REAL(wp), INTENT(IN), DIMENSION(:), TARGET ::  data
+    CHARACTER(LEN=*), INTENT(IN)       ::  name            !<
+
+#if defined( __parallel )
+    INTEGER(KIND=rd_offset_kind)       ::  disp            !<
+#endif
+    INTEGER(iwp), OPTIONAL             ::  first_index     !<
+#if defined( __parallel )
+    INTEGER(iwp)                       ::  i               !<
+#endif
+    INTEGER(iwp)                       ::  lo_first_index  !<
+    INTEGER(KIND=rd_offset_kind)       ::  offset          !<
+
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status          !<
+#endif
+
+    REAL(wp), INTENT(IN), DIMENSION(:), TARGET ::  data    !<
 
 
@@ -2088,5 +2136,5 @@
     lo_first_index = 1
 
-    IF ( PRESENT(first_index) )  THEN
+    IF ( PRESENT( first_index ) )  THEN
        lo_first_index = first_index
     ENDIF
@@ -2116,5 +2164,5 @@
     ENDIF
 
-    CALL sm_io%sm_node_barrier()  ! has no effect if I/O on limited number of cores is inactive
+    CALL sm_io%sm_node_barrier()  ! Has no effect if I/O on limited number of cores is inactive
     IF ( sm_io%iam_io_pe )  THEN
        IF ( all_pes_write )  THEN
@@ -2154,5 +2202,5 @@
 ! ------------
 !> Read 2d-REAL surface data array with MPI-IO.
-!> These consist of multiple 1d-REAL surface data arrays.
+!> This consist of multiple 1d-REAL surface data arrays.
 !--------------------------------------------------------------------------------------------------!
  SUBROUTINE wrd_mpi_io_surface_2d( name, data )
@@ -2160,12 +2208,12 @@
     IMPLICIT NONE
 
-    CHARACTER(LEN=*), INTENT(IN)         ::  name
-
-    INTEGER(iwp)                         ::  i
-
-    REAL(wp), INTENT(IN), DIMENSION(:,:) ::  data
-
-
-    DO  i = 1, SIZE( data,1)
+    CHARACTER(LEN=*), INTENT(IN)         ::  name  !<
+
+    INTEGER(iwp)                         ::  i     !<
+
+    REAL(wp), INTENT(IN), DIMENSION(:,:) ::  data  !<
+
+
+    DO  i = 1, SIZE( data, 1 )
        CALL wrd_mpi_io_surface( name, data(i,:), first_index = i )
     ENDDO
@@ -2184,12 +2232,12 @@
     IMPLICIT NONE
 
-    INTEGER(iwp)                       ::  gh_size
-    INTEGER(KIND=rd_offset_kind)       ::  offset
-#if defined( __parallel )
-    INTEGER, DIMENSION(rd_status_size) ::  status
+    INTEGER(iwp)                       ::  gh_size  !<
+    INTEGER(KIND=rd_offset_kind)       ::  offset   !<
+#if defined( __parallel )
+    INTEGER, DIMENSION(rd_status_size) ::  status   !<
 #endif
 
 #if ! defined( __parallel )
-    TYPE(C_PTR)                        ::  buf_ptr
+    TYPE(C_PTR)                        ::  buf_ptr  !<
 #endif
 
@@ -2205,6 +2253,6 @@
        tgh%total_nx  = lb%nx + 1
        tgh%total_ny  = lb%ny + 1
-       IF ( include_total_domain_boundaries )  THEN   ! not sure, if LOGICAL interpretation is the same for all compilers,
-          tgh%i_outer_bound = 1        ! therefore store as INTEGER in general header
+       IF ( include_total_domain_boundaries )  THEN   ! Not sure, if LOGICAL interpretation is the same for all compilers,
+          tgh%i_outer_bound = 1                       ! therefore store as INTEGER in general header
        ELSE
           tgh%i_outer_bound = 0
@@ -2231,5 +2279,5 @@
 !--       INTEGER values
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
-          CALL MPI_FILE_WRITE( fh, int_names, SIZE( int_names )*32, MPI_CHAR, status, ierr )
+          CALL MPI_FILE_WRITE( fh, int_names, SIZE( int_names ) * 32, MPI_CHAR, status, ierr )
           header_position = header_position + SIZE( int_names ) * 32
 
@@ -2240,10 +2288,10 @@
 !--       Character entries
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
-          CALL MPI_FILE_WRITE( fh, text_lines, SIZE( text_lines )*128, MPI_CHAR, status, ierr )
+          CALL MPI_FILE_WRITE( fh, text_lines, SIZE( text_lines ) * 128, MPI_CHAR, status, ierr )
           header_position = header_position + SIZE( text_lines ) * 128
 !
 !---      REAL values
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
-          CALL MPI_FILE_WRITE( fh, real_names, SIZE( real_names )*32, MPI_CHAR, status, ierr )
+          CALL MPI_FILE_WRITE( fh, real_names, SIZE( real_names ) * 32, MPI_CHAR, status, ierr )
           header_position = header_position + SIZE( real_names ) * 32
 
@@ -2254,9 +2302,9 @@
 !--       2d- and 3d- distributed array headers, all replicated array headers
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
-          CALL MPI_FILE_WRITE( fh, array_names, SIZE( array_names )*32, MPI_CHAR, status, ierr )
+          CALL MPI_FILE_WRITE( fh, array_names, SIZE( array_names ) * 32, MPI_CHAR, status, ierr )
           header_position = header_position + SIZE( array_names ) * 32
 
           CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
-          CALL MPI_FILE_WRITE( fh, array_offset, SIZE( array_offset )*MPI_OFFSET_KIND, MPI_BYTE,   &
+          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
           header_position = header_position + SIZE( array_offset ) * rd_offset_kind
@@ -2350,18 +2398,20 @@
     IMPLICIT NONE
 
-    INTEGER(iwp)                          ::  i            !<  loop index
-    INTEGER(KIND=rd_offset_kind)          ::  offset
-
-    INTEGER(iwp), DIMENSION(1)            ::  dims1
-    INTEGER(iwp), DIMENSION(1)            ::  lize1
-    INTEGER(iwp), DIMENSION(1)            ::  start1
-    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  lo_nr_val    !< local number of values in x and y direction
-    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  all_nr_val   !< number of values for all PEs
-
-    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  end_index
-    INTEGER, INTENT(OUT), DIMENSION(nys:nyn,nxl:nxr) ::  global_start
-    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  start_index
-
-    LOGICAL, INTENT(OUT)                  ::  data_to_write  !< returns, if surface data have to be written
+    INTEGER(iwp)                          ::  i           !<  loop index
+    INTEGER(KIND=rd_offset_kind)          ::  offset      !<
+
+    INTEGER(iwp), DIMENSION(1)            ::  dims1       !<
+    INTEGER(iwp), DIMENSION(1)            ::  lize1       !<
+    INTEGER(iwp), DIMENSION(1)            ::  start1      !<
+
+    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  all_nr_val  !< number of values for all PEs
+    INTEGER(iwp), DIMENSION(0:numprocs-1) ::  lo_nr_val   !< local number of values in x and y direction
+
+
+    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  end_index     !<
+    INTEGER, INTENT(OUT), DIMENSION(nys:nyn,nxl:nxr) ::  global_start  !<
+    INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr)  ::  start_index   !<
+
+    LOGICAL, INTENT(OUT) ::  data_to_write  !< returns, if surface data have to be written
 
 
@@ -2372,5 +2422,5 @@
     CALL MPI_ALLREDUCE( lo_nr_val, all_nr_val, numprocs, MPI_INTEGER, MPI_SUM, comm2d, ierr )
     IF ( ft_surf /= -1  .AND.  sm_io%iam_io_pe )  THEN
-       CALL MPI_TYPE_FREE( ft_surf, ierr )    ! if set, free last surface filetype
+       CALL MPI_TYPE_FREE( ft_surf, ierr )    ! If set, free last surface filetype
     ENDIF
 
@@ -2404,5 +2454,5 @@
 
 !
-!-- Actions during read
+!-- Actions during reading
     IF ( rd_flag )  THEN
        IF ( .NOT. ALLOCATED( m_start_index )  )  ALLOCATE( m_start_index(nys:nyn,nxl:nxr)  )
@@ -2422,5 +2472,5 @@
 
 !
-!-- Actions during write
+!-- Actions during writing
     IF ( wr_flag )  THEN
 !
@@ -2502,11 +2552,11 @@
     IMPLICIT NONE
 
-    INTEGER, DIMENSION(2) ::  dims2
-    INTEGER, DIMENSION(2) ::  lize2
-    INTEGER, DIMENSION(2) ::  start2
-
-    INTEGER, DIMENSION(3) ::  dims3
-    INTEGER, DIMENSION(3) ::  lize3
-    INTEGER, DIMENSION(3) ::  start3
+    INTEGER, DIMENSION(2) ::  dims2   !<
+    INTEGER, DIMENSION(2) ::  lize2   !<
+    INTEGER, DIMENSION(2) ::  start2  !<
+
+    INTEGER, DIMENSION(3) ::  dims3   !<
+    INTEGER, DIMENSION(3) ::  lize3   !<
+    INTEGER, DIMENSION(3) ::  start3  !<
 
     TYPE(local_boundaries) ::  save_io_grid  !< temporary variable to store grid settings
@@ -2656,7 +2706,6 @@
 ! Description:
 ! ------------
-!> This subroutine creates file types to access 3d-soil arrays
-!> distributed in blocks among processes to a single file that contains the global arrays.
-!> It is not required for the serial mode.
+!> This subroutine creates file types to access 3d-soil arrays distributed in blocks among processes
+!> to a single file that contains the global arrays. It is not required for the serial mode.
 !--------------------------------------------------------------------------------------------------!
 #if defined( __parallel )
@@ -2665,10 +2714,10 @@
     IMPLICIT NONE
 
-    INTEGER, INTENT(IN)  ::  nzb_soil
-    INTEGER, INTENT(IN)  ::  nzt_soil
-
-    INTEGER, DIMENSION(3) ::  dims3
-    INTEGER, DIMENSION(3) ::  lize3
-    INTEGER, DIMENSION(3) ::  start3
+    INTEGER, INTENT(IN)   ::  nzb_soil  !<
+    INTEGER, INTENT(IN)   ::  nzt_soil  !<
+
+    INTEGER, DIMENSION(3) ::  dims3     !<
+    INTEGER, DIMENSION(3) ::  lize3     !<
+    INTEGER, DIMENSION(3) ::  start3    !<
 
 
@@ -2764,5 +2813,5 @@
     IMPLICIT NONE
 
-    INTEGER(iwp) ::  i
+    INTEGER(iwp) ::  i  !<
 
 
@@ -2816,11 +2865,11 @@
     IMPLICIT NONE
 
-    INTEGER, INTENT(out)                   ::  i_endian
-    INTEGER(KIND=8), TARGET                ::  int8
-
-    INTEGER, DIMENSION(1)                  ::  bufshape
-    INTEGER(KIND=4), POINTER, DIMENSION(:) ::  int4
-
-    TYPE(C_PTR)                            ::  ptr
+    INTEGER, INTENT(out)                   ::  i_endian  !<
+    INTEGER(KIND=8), TARGET                ::  int8      !<
+
+    INTEGER, DIMENSION(1)                  ::  bufshape  !<
+    INTEGER(KIND=4), POINTER, DIMENSION(:) ::  int4      !<
+
+    TYPE(C_PTR)                            ::  ptr       !<
 
 
@@ -2832,7 +2881,7 @@
 
     IF ( int4(1) == 1 )  THEN
-       i_endian = 1    ! little endian
+       i_endian = 1    ! Little endian
     ELSE
-       i_endian = 2    ! big endian
+       i_endian = 2    ! Big endian
     ENDIF
 
Index: /palm/trunk/SOURCE/run_control.f90
===================================================================
--- /palm/trunk/SOURCE/run_control.f90	(revision 4590)
+++ /palm/trunk/SOURCE/run_control.f90	(revision 4591)
@@ -1,30 +1,34 @@
 !> @file run_control.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
 !
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
 !
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 4360 2020-01-07 11:25:50Z suehring
 ! Corrected "Former revisions" section
-! 
+!
 ! 3655 2019-01-07 16:51:22Z knoop
 ! Corrected "Former revisions" section
@@ -37,18 +41,26 @@
 ! ------------
 !> Computation and output of run-control quantities
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
  SUBROUTINE run_control
- 
 
-    USE cpulog,                                                                &
-        ONLY:  cpu_log, log_point
 
-    USE control_parameters,                                                    &
-        ONLY:  advected_distance_x, advected_distance_y,                       &
-               current_timestep_number, disturbance_created, dt_3d, mgcycles,  &
-               run_control_header, runnr, simulated_time, simulated_time_chr,  &
+    USE cpulog,                                                                                    &
+        ONLY:  cpu_log,                                                                            &
+               log_point
+
+    USE control_parameters,                                                                        &
+        ONLY:  advected_distance_x,                                                                &
+               advected_distance_y,                                                                &
+               current_timestep_number,                                                            &
+               disturbance_created,                                                                &
+               dt_3d,                                                                              &
+               mgcycles,                                                                           &
+               run_control_header,                                                                 &
+               runnr,                                                                              &
+               simulated_time,                                                                     &
+               simulated_time_chr,                                                                 &
                timestep_reason
 
-    USE indices,                                                               &
+    USE indices,                                                                                   &
         ONLY:  nzb
 
@@ -57,11 +69,18 @@
     USE pegrid
 
-    USE statistics,                                                            &
-        ONLY:  flow_statistics_called, hom, pr_palm, u_max, u_max_ijk, v_max,  &
-               v_max_ijk, w_max, w_max_ijk
+    USE statistics,                                                                                &
+        ONLY:  flow_statistics_called,                                                             &
+               hom,                                                                                &
+               pr_palm,                                                                            &
+               u_max,                                                                              &
+               u_max_ijk,                                                                          &
+               v_max,                                                                              &
+               v_max_ijk,                                                                          &
+               w_max,                                                                              &
+               w_max_ijk
 
     IMPLICIT NONE
 
-    CHARACTER (LEN=1) ::  disturb_chr
+    CHARACTER (LEN=1) ::  disturb_chr  !<
 
 !
@@ -78,6 +97,5 @@
 
 !
-!--    Check, whether file unit is already open (may have been opened in header
-!--    before)
+!--    Check, whether file unit is already open (may have been opened in header before)
        CALL check_open( 15 )
 
@@ -96,14 +114,11 @@
           disturb_chr = ' '
        ENDIF
-       WRITE ( 15, 101 )  runnr, current_timestep_number, simulated_time_chr,  &
-                          INT( ( simulated_time-INT( simulated_time ) ) * 100),&
-                          dt_3d, timestep_reason, u_max, disturb_chr,          &
-                          v_max, disturb_chr, w_max, hom(nzb,1,pr_palm,0),     &
-                          hom(nzb+8,1,pr_palm,0), hom(nzb+3,1,pr_palm,0),      &
-                          hom(nzb+6,1,pr_palm,0), hom(nzb+4,1,pr_palm,0),      &
-                          hom(nzb+5,1,pr_palm,0), hom(nzb+9,1,pr_palm,0),      &
-                          hom(nzb+10,1,pr_palm,0), u_max_ijk(1:3),             &
-                          v_max_ijk(1:3), w_max_ijk(1:3),                      &
-                          advected_distance_x/1000.0_wp,                       &
+       WRITE ( 15, 101 )  runnr, current_timestep_number, simulated_time_chr,                      &
+                          INT( ( simulated_time-INT( simulated_time ) ) * 100),                    &
+                          dt_3d, timestep_reason, u_max, disturb_chr, v_max, disturb_chr, w_max,   &
+                          hom(nzb,1,pr_palm,0), hom(nzb+8,1,pr_palm,0), hom(nzb+3,1,pr_palm,0),    &
+                          hom(nzb+6,1,pr_palm,0), hom(nzb+4,1,pr_palm,0), hom(nzb+5,1,pr_palm,0),  &
+                          hom(nzb+9,1,pr_palm,0), hom(nzb+10,1,pr_palm,0), u_max_ijk(1:3),         &
+                          v_max_ijk(1:3), w_max_ijk(1:3), advected_distance_x/1000.0_wp,           &
                           advected_distance_y/1000.0_wp, mgcycles
 !
@@ -113,5 +128,5 @@
     ENDIF
 !
-!-- If required, reset disturbance flag. This has to be done outside the above 
+!-- If required, reset disturbance flag. This has to be done outside the above
 !-- IF-loop, because the flag would otherwise only be reset on PE0
     IF ( disturbance_created )  disturbance_created = .FALSE.
@@ -131,6 +146,5 @@
           &'----------------------------------------------------------------', &
           &'---------')
-101 FORMAT (I3,1X,I6,1X,A8,'.',I2.2,1X,F8.4,A1,1X,F8.4,A1,F8.4,A1,F8.4,1X,     &
-            F6.3,1X,F5.2, &
+101 FORMAT (I3,1X,I6,1X,A8,'.',I2.2,1X,F8.4,A1,1X,F8.4,A1,F8.4,A1,F8.4,1X, F6.3,1X,F5.2,           &
             2X,E10.3,2X,F6.0,1X,4(E10.3,1X),3(3(I4),1X),F8.3,1X,F8.3,5X,I3)
 
Index: /palm/trunk/SOURCE/shared_memory_io_mod.f90
===================================================================
--- /palm/trunk/SOURCE/shared_memory_io_mod.f90	(revision 4590)
+++ /palm/trunk/SOURCE/shared_memory_io_mod.f90	(revision 4591)
@@ -1,38 +1,42 @@
 !> @file shared_memory_io_mod.f90
-!------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+!--------------------------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! $Id$
 !
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 
 ! Initial version (Klaus Ketelsen)
 !
-! 
-!
-! Description:
-! ------------
-!> handle MPI-IO or NetCDF-IO shared memory arrays.
-!> This module performs the organization of new communicators, adapted PE-grids
-!> and allocation of shared memory arrays. The IO itself is not done here.
-!------------------------------------------------------------------------------!
+!
+!
+! Description:
+! ------------
+!> Handle MPI-IO or NetCDF-IO shared memory arrays.
+!> This module performs the organization of new communicators, adapted PE-grids and allocation of
+!> shared memory arrays. The IO itself is not done here.
+!--------------------------------------------------------------------------------------------------!
  MODULE shared_memory_io_mod
 
@@ -48,21 +52,64 @@
 
     USE control_parameters,                                                                        &
-        ONLY:  maximum_grid_level, mg_switch_to_pe0_level, message_string
+        ONLY: maximum_grid_level,                                                                  &
+              message_string,                                                                      &
+              mg_switch_to_pe0_level
+
 
     USE indices,                                                                                   &
-        ONLY: nbgp, nnx, nny, nnz, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, nzt
+        ONLY: nbgp,                                                                                &
+              nnx,                                                                                 &
+              nny,                                                                                 &
+              nnz,                                                                                 &
+              nx,                                                                                  &
+              nxl,                                                                                 &
+              nxlg,                                                                                &
+              nxr,                                                                                 &
+              nxrg,                                                                                &
+              ny,                                                                                  &
+              nyn,                                                                                 &
+              nyng,                                                                                &
+              nys,                                                                                 &
+              nysg,                                                                                &
+              nzb,                                                                                 &
+              nzt
 
     USE kinds,                                                                                     &
-        ONLY: wp, iwp
+        ONLY: iwp,                                                                                 &
+              wp
+
 
     USE transpose_indices,                                                                         &
-        ONLY:  nys_x, nyn_x, nys_z, nyn_z, nxl_z, nxr_z
+        ONLY: nxl_z,                                                                               &
+              nxr_z,                                                                               &
+              nyn_x,                                                                               &
+              nyn_z,                                                                               &
+              nys_x,                                                                               &
+              nys_z
+
+
 
     USE pegrid,                                                                                    &
-        ONLY: comm1dx, comm1dy, comm2d, ierr, myid, myidx, myidy, npex, npey, numprocs, pdims,     &
-              pleft, pnorth, pright, psouth, sendrecvcount_xy
+        ONLY: comm1dx,                                                                             &
+              comm1dy,                                                                             &
+              comm2d,                                                                              &
+              ierr,                                                                                &
+              myid,                                                                                &
+              myidx,                                                                               &
+              myidy,                                                                               &
+              npex,                                                                                &
+              npey,                                                                                &
+              numprocs,                                                                            &
+              pdims,                                                                               &
+              pleft,                                                                               &
+              pnorth,                                                                              &
+              pright,                                                                              &
+              psouth,                                                                              &
+              sendrecvcount_xy
+
 #if defined( __parallel )
     USE pegrid,                                                                                    &
-        ONLY: pcoord, reorder
+        ONLY: pcoord,                                                                              &
+              reorder
 #endif
 
@@ -75,14 +122,17 @@
 !
 !-- Type to store grid information
-    TYPE, PUBLIC ::  local_boundaries
-
-       INTEGER(iwp) ::  nxl
-       INTEGER(iwp) ::  nxr
-       INTEGER(iwp) ::  nys
-       INTEGER(iwp) ::  nyn
-       INTEGER(iwp) ::  nnx
-       INTEGER(iwp) ::  nny
-       INTEGER(iwp) ::  nx
-       INTEGER(iwp) ::  ny
+    TYPE, PUBLIC ::  local_boundaries  !<
+
+       INTEGER(iwp) ::  nnx  !<
+       INTEGER(iwp) ::  nny  !<
+       INTEGER(iwp) ::  nx   !<
+       INTEGER(iwp) ::  nxl  !<
+       INTEGER(iwp) ::  nxr  !<
+       INTEGER(iwp) ::  ny   !<
+       INTEGER(iwp) ::  nyn  !<
+       INTEGER(iwp) ::  nys  !<
+
+
+
 
     END TYPE local_boundaries
@@ -91,20 +141,20 @@
 !-- Class definition for shared memory instances.
 !-- For every use of shared memory IO, one instance of this class is created.
-    TYPE, PUBLIC ::  sm_class
-
-       INTEGER(iwp)         :: nr_io_pe_per_node = 2   !< typical configuration, 2 sockets per node
-       LOGICAL              :: no_shared_Memory_in_this_run
+    TYPE, PUBLIC ::  sm_class  !<
+
+       INTEGER(iwp) ::  nr_io_pe_per_node = 2         !< typical configuration, 2 sockets per node
+       LOGICAL      ::  no_shared_Memory_in_this_run  !<
 !
 !--    Variables for the shared memory communicator
-       INTEGER(iwp), PUBLIC ::  comm_shared    !< Communicator for processes with shared array
-       INTEGER(iwp), PUBLIC ::  sh_npes
-       INTEGER(iwp), PUBLIC ::  sh_rank
+       INTEGER(iwp), PUBLIC ::  comm_shared   !< Communicator for processes with shared array
+       INTEGER(iwp), PUBLIC ::  sh_npes       !<
+       INTEGER(iwp), PUBLIC ::  sh_rank       !<
 
        LOGICAL, PUBLIC ::  iam_io_pe = .TRUE.  !< This PE is an IO-PE
 !
 !--    Variables for the I/O virtual grid
-       INTEGER(iwp), PUBLIC ::  comm_io        !< Communicator for all IO processes
-       INTEGER(iwp), PUBLIC ::  io_npes
-       INTEGER(iwp), PUBLIC ::  io_rank
+       INTEGER(iwp), PUBLIC ::  comm_io  !< Communicator for all IO processes
+       INTEGER(iwp), PUBLIC ::  io_npes  !<
+       INTEGER(iwp), PUBLIC ::  io_rank  !<
 
        TYPE( local_boundaries ), PUBLIC ::  io_grid
@@ -112,31 +162,31 @@
 !
 !--    Variables for the node local communicator
-       INTEGER(iwp)         ::  comm_node      !< Communicator for all processes of current node
-       INTEGER(iwp)         ::  io_pe_global_rank
-       INTEGER(iwp)         ::  n_npes
-       INTEGER(iwp)         ::  n_rank
-
-       CONTAINS
-
-          PRIVATE
-
-          PROCEDURE, PASS(this), PUBLIC ::  is_sm_active
-          PROCEDURE, PASS(this), PUBLIC ::  sm_adjust_outer_boundary
-          PROCEDURE, PASS(this), PUBLIC ::  sm_free_shared
-          PROCEDURE, PASS(this), PUBLIC ::  sm_init_comm
-          PROCEDURE, PASS(this), PUBLIC ::  sm_node_barrier
-#if defined( __parallel )
-          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_1d
-          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_2d
-          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_2di
-          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_3d
+       INTEGER(iwp) ::  comm_node          !< Communicator for all processes of current node
+       INTEGER(iwp) ::  io_pe_global_rank  !<
+       INTEGER(iwp) ::  n_npes             !<
+       INTEGER(iwp) ::  n_rank             !<
+
+ CONTAINS
+
+       PRIVATE
+
+          PROCEDURE, PASS(this), PUBLIC ::  is_sm_active              !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_adjust_outer_boundary  !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_free_shared            !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_init_comm              !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_node_barrier           !<
+#if defined( __parallel )
+          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_1d   !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_2d   !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_2di  !<
+          PROCEDURE, PASS(this), PUBLIC ::  sm_allocate_shared_3d   !<
 
           GENERIC, PUBLIC ::  sm_allocate_shared =>  sm_allocate_shared_1d, sm_allocate_shared_2d, &
-                                                     sm_allocate_shared_2di, sm_allocate_shared_3d
+                                                  sm_allocate_shared_2di, sm_allocate_shared_3d  !<
 #endif
     END TYPE sm_class
 
 
-CONTAINS
+ CONTAINS
 
 
@@ -154,6 +204,6 @@
 
 #if defined( __parallel )
-    INTEGER             :: color
-    INTEGER             :: max_n_npes  !< Maximum number of PEs/node
+    INTEGER ::  color       !<
+    INTEGER ::  max_n_npes  !< Maximum number of PEs/node
 #endif
 
@@ -244,19 +294,19 @@
     IMPLICIT NONE
 
-    INTEGER(iwp), INTENT(OUT) :: color
-
-    INTEGER(iwp) ::  group_start
-    INTEGER(iwp) ::  n
-    INTEGER(iwp) ::  my_color
-    INTEGER(iwp) ::  pe
-    INTEGER(iwp) ::  sh_group_size
-
-    INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) ::  local_dim_s
-    INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) ::  local_dim_r
-
-    TYPE(local_boundaries), DIMENSION(32) ::  node_grid
-
-!
-!-- Nn shared memory I/O on one node jobs
+    INTEGER(iwp), INTENT(OUT) ::  color  !<
+
+    INTEGER(iwp) ::  group_start    !<
+    INTEGER(iwp) ::  my_color       !<
+    INTEGER(iwp) ::  n              !<
+    INTEGER(iwp) ::  pe             !<
+    INTEGER(iwp) ::  sh_group_size  !<
+
+    INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) ::  local_dim_s   !<
+    INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) ::  local_dim_r   !<
+
+    TYPE(local_boundaries), DIMENSION(32) ::  node_grid  !<
+
+!
+!-- No shared memory I/O on one node jobs
     IF ( numprocs < this%n_npes )  THEN
        this%no_shared_memory_in_this_run = .TRUE.
@@ -337,11 +387,11 @@
 !> Function to return if shared Memory IO is active.
 !--------------------------------------------------------------------------------------------------!
- FUNCTION is_sm_active( this) RESULT( ac )
-
-    IMPLICIT NONE
-
-    CLASS(sm_class), INTENT(inout) ::  this
-
-    LOGICAL ::  ac
+ FUNCTION is_sm_active( this ) RESULT( ac )
+
+    IMPLICIT NONE
+
+    CLASS(sm_class), INTENT(inout) ::  this  !<
+
+    LOGICAL ::  ac  !<
 
     ac = .NOT. this%no_shared_memory_in_this_run
@@ -360,21 +410,21 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout)  ::  this
-
-    INTEGER(iwp)                    ::  disp_unit
-    INTEGER(iwp), INTENT(IN)        ::  d1
-    INTEGER(iwp), INTENT(IN)        ::  d2
-    INTEGER(iwp), SAVE              ::  pe_from = 0
-    INTEGER(KIND=MPI_ADDRESS_KIND)  ::  rem_size
-    INTEGER(iwp), INTENT(OUT)       ::  win
-    INTEGER(KIND=MPI_ADDRESS_KIND)  ::  wsize
-
-    INTEGER, DIMENSION(1)           ::  buf_shape
-
-    REAL(wp), DIMENSION(:), POINTER ::  buf
-    REAL(wp), DIMENSION(:), POINTER ::  p1
-
-    TYPE(C_PTR), SAVE               ::  base_ptr
-    TYPE(C_PTR), SAVE               ::  rem_ptr
+    CLASS(sm_class), INTENT(inout) ::  this         !<
+                                                    !<
+    INTEGER(iwp)                   ::  disp_unit    !<
+    INTEGER(iwp), INTENT(IN)       ::  d1           !<
+    INTEGER(iwp), INTENT(IN)       ::  d2           !<
+    INTEGER(iwp), SAVE             ::  pe_from = 0  !<
+    INTEGER(KIND=MPI_ADDRESS_KIND) ::  rem_size     !<
+    INTEGER(iwp), INTENT(OUT)      ::  win          !<
+    INTEGER(KIND=MPI_ADDRESS_KIND) ::  wsize        !<
+
+    INTEGER, DIMENSION(1)           ::  buf_shape   !<
+
+    REAL(wp), DIMENSION(:), POINTER ::  buf         !<
+    REAL(wp), DIMENSION(:), POINTER ::  p1          !<
+
+    TYPE(C_PTR), SAVE               ::  base_ptr    !<
+    TYPE(C_PTR), SAVE               ::  rem_ptr     !<
 
 
@@ -415,23 +465,23 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(INOUT)    ::  this
-
-    INTEGER(iwp)                      ::  disp_unit
-    INTEGER(iwp), INTENT(IN)          ::  n_nxlg
-    INTEGER(iwp), INTENT(IN)          ::  n_nxrg
-    INTEGER(iwp), INTENT(IN)          ::  n_nyng
-    INTEGER(iwp), INTENT(IN)          ::  n_nysg
-    INTEGER(iwp), SAVE                ::  pe_from = 0
-    INTEGER(KIND=MPI_ADDRESS_KIND)    ::  rem_size
-    INTEGER(iwp), INTENT(OUT)         ::  win
-    INTEGER(KIND=MPI_ADDRESS_KIND)    ::  wsize
-
-    INTEGER(iwp), DIMENSION(2)        ::  buf_shape
-
-    REAL(wp), DIMENSION(:,:), POINTER ::  buf
-    REAL(wp), DIMENSION(:,:), POINTER ::  p2
-
-    TYPE(C_PTR),SAVE                  ::  base_ptr
-    TYPE(C_PTR),SAVE                  ::  rem_ptr
+    CLASS(sm_class), INTENT(INOUT)    ::  this         !<
+
+    INTEGER(iwp)                      ::  disp_unit    !<
+    INTEGER(iwp), INTENT(IN)          ::  n_nxlg       !<
+    INTEGER(iwp), INTENT(IN)          ::  n_nxrg       !<
+    INTEGER(iwp), INTENT(IN)          ::  n_nyng       !<
+    INTEGER(iwp), INTENT(IN)          ::  n_nysg       !<
+    INTEGER(iwp), SAVE                ::  pe_from = 0  !<
+    INTEGER(KIND=MPI_ADDRESS_KIND)    ::  rem_size     !<
+    INTEGER(iwp), INTENT(OUT)         ::  win          !<
+    INTEGER(KIND=MPI_ADDRESS_KIND)    ::  wsize        !<
+
+    INTEGER(iwp), DIMENSION(2)        ::  buf_shape    !<
+
+    REAL(wp), DIMENSION(:,:), POINTER ::  buf          !<
+    REAL(wp), DIMENSION(:,:), POINTER ::  p2           !<
+
+    TYPE(C_PTR),SAVE                  ::  base_ptr     !<
+    TYPE(C_PTR),SAVE                  ::  rem_ptr      !<
 
 
@@ -474,23 +524,23 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout)      :: this
-
-    INTEGER(iwp)                          ::  disp_unit
-    INTEGER(iwp), INTENT(IN)              ::  n_nxlg
-    INTEGER(iwp), INTENT(IN)              ::  n_nxrg
-    INTEGER(iwp), INTENT(IN)              ::  n_nyng
-    INTEGER(iwp), INTENT(IN)              ::  n_nysg
-    INTEGER(iwp), SAVE                    ::  pe_from = 0
-    INTEGER(kind=MPI_ADDRESS_KIND)        ::  rem_size
-    INTEGER(iwp), INTENT(OUT)             ::  win
-    INTEGER(kind=MPI_ADDRESS_KIND)        ::  wsize
-
-    INTEGER(iwp), DIMENSION(2)            ::  buf_shape
-
-    INTEGER(iwp), DIMENSION(:,:), POINTER ::  buf
-    INTEGER(iwp), DIMENSION(:,:), POINTER ::  p2i
-
-    TYPE(C_PTR),SAVE                      ::  base_ptr
-    TYPE(C_PTR),SAVE                      ::  rem_ptr
+    CLASS(sm_class), INTENT(inout)        ::  this         !<
+
+    INTEGER(iwp)                          ::  disp_unit    !<
+    INTEGER(iwp), INTENT(IN)              ::  n_nxlg       !<
+    INTEGER(iwp), INTENT(IN)              ::  n_nxrg       !<
+    INTEGER(iwp), INTENT(IN)              ::  n_nyng       !<
+    INTEGER(iwp), INTENT(IN)              ::  n_nysg       !<
+    INTEGER(iwp), SAVE                    ::  pe_from = 0  !<
+    INTEGER(kind=MPI_ADDRESS_KIND)        ::  rem_size     !<
+    INTEGER(iwp), INTENT(OUT)             ::  win          !<
+    INTEGER(kind=MPI_ADDRESS_KIND)        ::  wsize        !<
+
+    INTEGER(iwp), DIMENSION(2)            ::  buf_shape    !<
+
+    INTEGER(iwp), DIMENSION(:,:), POINTER ::  buf          !<
+    INTEGER(iwp), DIMENSION(:,:), POINTER ::  p2i          !<
+
+    TYPE(C_PTR),SAVE                      ::  base_ptr     !<
+    TYPE(C_PTR),SAVE                      ::  rem_ptr      !<
 
 
@@ -533,25 +583,25 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout)      ::  this
-
-    INTEGER                             ::  disp_unit
-    INTEGER, INTENT(IN)                 ::  d1e
-    INTEGER, INTENT(IN)                 ::  d1s
-    INTEGER, INTENT(IN)                 ::  d2e
-    INTEGER, INTENT(IN)                 ::  d2s
-    INTEGER, INTENT(IN)                 ::  d3e
-    INTEGER, INTENT(IN)                 ::  d3s
-    INTEGER, SAVE                       ::  pe_from = 0
-    INTEGER(KIND=MPI_ADDRESS_KIND)      ::  rem_size
-    INTEGER, INTENT(OUT)                ::  win
-    INTEGER(KIND=MPI_ADDRESS_KIND)      ::  wsize
-
-    INTEGER, DIMENSION(3)               ::  buf_shape
-
-    REAL(wp), DIMENSION(:,:,:), POINTER ::  buf
-    REAL(wp), DIMENSION(:,:,:), POINTER ::  p3
-
-    TYPE(C_PTR), SAVE                   ::  base_ptr
-    TYPE(C_PTR), SAVE                   ::  rem_ptr
+    CLASS(sm_class), INTENT(inout)      ::  this         !<
+
+    INTEGER                             ::  disp_unit    !<
+    INTEGER, INTENT(IN)                 ::  d1e          !<
+    INTEGER, INTENT(IN)                 ::  d1s          !<
+    INTEGER, INTENT(IN)                 ::  d2e          !<
+    INTEGER, INTENT(IN)                 ::  d2s          !<
+    INTEGER, INTENT(IN)                 ::  d3e          !<
+    INTEGER, INTENT(IN)                 ::  d3s          !<
+    INTEGER, SAVE                       ::  pe_from = 0  !<
+    INTEGER(KIND=MPI_ADDRESS_KIND)      ::  rem_size     !<
+    INTEGER, INTENT(OUT)                ::  win          !<
+    INTEGER(KIND=MPI_ADDRESS_KIND)      ::  wsize        !<
+
+    INTEGER, DIMENSION(3)               ::  buf_shape    !<
+
+    REAL(wp), DIMENSION(:,:,:), POINTER ::  buf          !<
+    REAL(wp), DIMENSION(:,:,:), POINTER ::  p3           !<
+
+    TYPE(C_PTR), SAVE                   ::  base_ptr     !<
+    TYPE(C_PTR), SAVE                   ::  rem_ptr      !<
 
 
@@ -596,5 +646,5 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout) ::  this
+    CLASS(sm_class), INTENT(inout) ::  this  !<
 
 
@@ -640,7 +690,7 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout) ::  this
-
-    INTEGER(iwp), INTENT(INOUT)    ::  win
+    CLASS(sm_class), INTENT(inout) ::  this  !<
+
+    INTEGER(iwp), INTENT(INOUT)    ::  win   !<
 
     IF ( this%no_shared_memory_in_this_run  .OR.  win == -1234567890 )  RETURN
@@ -662,5 +712,5 @@
     IMPLICIT NONE
 
-    CLASS(sm_class), INTENT(inout)     :: this
+    CLASS(sm_class), INTENT(inout) ::  this  !<
 
 
Index: /palm/trunk/SOURCE/singleton_mod.f90
===================================================================
--- /palm/trunk/SOURCE/singleton_mod.f90	(revision 4590)
+++ /palm/trunk/SOURCE/singleton_mod.f90	(revision 4591)
@@ -1,15 +1,36 @@
 !> @file singleton_mod.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2020 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------------------------!
+!
+!
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 4182 2019-08-22 15:20:23Z scharf
 ! Corrected "Former revisions" section
-! 
+!
 ! 3761 2019-02-25 15:31:42Z raasch
-! statement added to prevent compiler warning about unused variables
+! Statement added to prevent compiler warning about unused variables
 !
 ! Revision 1.1  2002/05/02 18:56:59  raasch
@@ -17,22 +38,20 @@
 !
 !
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Multivariate Fast Fourier Transform
 !>
-!> Fortran 90 Implementation of Singleton's mixed-radix algorithm,
-!> RC Singleton, Stanford Research Institute, Sept. 1968.
-!>
-!> Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and
-!> John Beale.
-!>
-!> Fourier transforms can be computed either in place, using assumed size
-!> arguments, or by generic function, using assumed shape arguments.
-!>
+!> Fortran 90 Implementation of Singleton's mixed-radix algorithm, RC Singleton, Stanford Research
+!> Institute, Sept. 1968.
+!>
+!> Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and John Beale.
+!>
+!> Fourier transforms can be computed either in place, using assumed size arguments, or by generic
+!> function, using assumed shape arguments.
 !>
 !> Public:
 !>
-!>   fftkind                              kind parameter of complex arguments
-!>                                        and function results.
+!>   fftkind                              kind parameter of complex arguments and function results.
 !>
 !>   fft(array, dim, inv, stat)           generic transform function
@@ -52,47 +71,39 @@
 !> Formal Parameters:
 !>
-!>   array    The complex array to be transformed. array can be of arbitrary
-!>            rank (i.e. up to seven).
-!>
-!>   shape    With subroutine fftn, the shape of the array to be transformed
-!>            has to be passed separately, since fftradix - the internal trans-
-!>            formation routine - will treat array always as one dimensional.
-!>            The product of elements in shape must be the number of
+!>   array    The complex array to be transformed. Array can be of arbitrary rank (i.e. up to seven).
+!>
+!>   shape    With subroutine fftn, the shape of the array to be transformed has to be passed
+!>            separately, since fftradix - the internal transformation routine - will always treat
+!>            array as one dimensional. The product of elements in shape must be the number of
 !>            elements in array.
-!>            Although passing array with assumed shape would have been nicer,
-!>            I prefered assumed size in order to prevent the compiler from
-!>            using a copy-in-copy-out mechanism. That would generally be
-!>            necessary with fftn passing array to fftradix and with fftn
-!>            being prepared for accepting non consecutive array sections.
-!>            Using assumed size, it's up to the user to pass an array argu-
-!>            ment, that can be addressed as continous one dimensional array
-!>            without copying. Otherwise, transformation will not really be
-!>            performed in place.
-!>            On the other hand, since the rank of array and the size of
-!>            shape needn't match, fftn is appropriate for handling more than
-!>            seven dimensions.
-!>            As far as function fft is concerned all this doesn't matter,
-!>            because the argument will be copied anyway. Thus no extra
-!>            shape argument is needed for fft.
+!>            Although passing array with assumed shape would have been nicer, I prefered assumed
+!>            size in order to prevent the compiler from using a copy-in-copy-out mechanism. That
+!>            would generally be necessary with fftn passing array to fftradix and with fftn being
+!>            prepared for accepting non consecutive array sections. Using assumed size, it's up to
+!>            the user to pass an array argument, that can be addressed as continous one dimensional
+!>            array without copying. Otherwise, transformation will not really be performed in place.
+!>            On the other hand, since the rank of array and the size of shape needn't match, fftn
+!>            is appropriate for handling more than seven dimensions. As far as function fft is
+!>            concerned all this doesn't matter, because the argument will be copied anyway. Thus no
+!>            extra shape argument is needed for fft.
 !>
 !> Optional Parameters:
 !>
-!>   dim      One dimensional integer array, containing the dimensions to be
-!>            transformed. Default is (/1,...,N/) with N being the rank of
-!>            array, i.e. complete transform. dim can restrict transformation
-!>            to a subset of available dimensions. Its size must not exceed the
-!>            rank of array or the size of shape respectivly.
-!>
-!>   inv      If .true., inverse transformation will be performed. Default is
-!>            .false., i.e. forward transformation.
-!>
-!>   stat     If present, a system dependent nonzero status value will be
-!>            returned in stat, if allocation of temporary storage failed.
+!>   dim      One dimensional integer array, containing the dimensions to be transformed. Default
+!>            is (/1,...,N/) with N being the rank of array, i.e. complete transform. dim can
+!>            restrict transformation to a subset of available dimensions. Its size must not exceed
+!>            the rank of array or the size of shape respectivly.
+!>
+!>   inv      If .true., inverse transformation will be performed. Default is .false., i.e. forward
+!>            transformation.
+!>
+!>   stat     If present, a system dependent nonzero status value will be returned in stat, if
+!>            allocation of temporary storage failed.
 !>
 !>
 !> Scaling:
 !>
-!>   Transformation results will always be scaled by the square root of the
-!>   product of sizes of each dimension in dim. (See examples below)
+!>   Transformation results will always be scaled by the square root of the product of sizes of each
+!>   dimension in dim. (See examples below)
 !>
 !>
@@ -111,6 +122,5 @@
 !>     result = fft(A, dim=(/1,3/))
 !>
-!>   will transform with respect to the first and the third dimension, scaled
-!>   by sqrt(L*N).
+!>   will transform with respect to the first and the third dimension, scaled by sqrt(L*N).
 !>
 !>     result = fft(fft(A), inv=.true.)
@@ -127,33 +137,29 @@
 !>
 !>   Following changes have been introduced with respect to fftn.c:
-!>   - complex arguments and results are of type complex, rather than
-!>     real an imaginary part separately.
-!>   - increment parameter (magnitude of isign) has been dropped,
-!>     inc is always one, direction of transform is given by inv.     
-!>   - maxf and maxp have been dropped. The amount of temporary storage
-!>     needed is determined by the fftradix routine. Both fftn and fft
-!>     can handle any size of array. (Maybe they take a lot of time and
-!>     memory, but they will do it)
-!>
-!>   Redesigning fftradix in a way, that it handles assumed shape arrays
-!>   would have been desirable. However, I found it rather hard to do this
-!>   in an efficient way. Problems were:
-!>   - to prevent stride multiplications when indexing arrays. At least our
-!>     compiler was not clever enough to discover that in fact additions
-!>     would do the job as well. On the other hand, I haven't been clever
-!>     enough to find an implementation using array operations.
-!>   - fftradix is rather large and different versions would be necessaray
-!>     for each possible rank of array.
-!>   Consequently, in place transformation still needs the argument stored
-!>   in a consecutive bunch of memory and can't be performed on array
-!>   sections like A(100:199:-3, 50:1020). Calling fftn with such sections
-!>   will most probably imply copy-in-copy-out. However, the function fft
-!>   works with everything it gets and should be convenient to use.
+!>   - Complex arguments and results are of type complex, rather than real an imaginary part
+!>     separately.
+!>   - Increment parameter (magnitude of isign) has been dropped, inc is always one, direction of
+!>     transform is given by inv.
+!>   - maxf and maxp have been dropped. The amount of temporary storage needed is determined by the
+!>     fftradix routine. Both fftn and fft can handle any size of array. (Maybe they take a lot of
+!>     time and memory, but they will do it)
+!>
+!>   Redesigning fftradix in a way, that it handles assumed shape arrays would have been desirable.
+!>   However, I found it rather hard to do this in an efficient way. Problems were:
+!>   - To prevent stride multiplications when indexing arrays. At least our compiler was not clever
+!>     enough to discover that in fact additions would do the job as well. On the other hand, I
+!>     haven't been clever enough to find an implementation using array operations.
+!>   - fftradix is rather large and different versions would be necessaray for each possible rank of
+!>     array.
+!>   Consequently, in place transformation still needs the argument stored in a consecutive bunch of
+!>   memory and can't be performed on array sections like A(100:199:-3, 50:1020). Calling fftn with
+!>   such sections will most probably imply copy-in-copy-out. However, the function fft works with
+!>   everything it gets and should be convenient to use.
 !>
 !> Michael Steffens, 09.12.96, <Michael.Steffens@mbox.muk.uni-hannover.de>
 !> Restructured fftradix for better optimization. M. Steffens, 4 June 1997
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
  MODULE singleton
- 
+
 
     USE kinds
@@ -162,10 +168,11 @@
 
     PRIVATE
-    PUBLIC:: fft, fftn
-
-    REAL(wp), PARAMETER:: sin60 = 0.86602540378443865_wp
-    REAL(wp), PARAMETER:: cos72 = 0.30901699437494742_wp
-    REAL(wp), PARAMETER:: sin72 = 0.95105651629515357_wp
-    REAL(wp), PARAMETER:: pi    = 3.14159265358979323_wp
+    PUBLIC ::  fft   !<
+    PUBLIC ::  fftn  !<
+
+    REAL(wp), PARAMETER ::  cos72 = 0.30901699437494742_wp  !<
+    REAL(wp), PARAMETER ::  pi    = 3.14159265358979323_wp  !<
+    REAL(wp), PARAMETER ::  sin60 = 0.86602540378443865_wp  !<
+    REAL(wp), PARAMETER ::  sin72 = 0.95105651629515357_wp  !<
 
     INTERFACE fft
@@ -183,22 +190,22 @@
 
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft1d(array, dim, inv, stat) RESULT(ft)
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft1d( array, dim, inv, stat ) RESULT( ft )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp),  DIMENSION(:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                    INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Function result
-    COMPLEX(wp), DIMENSION(SIZE(array, 1)):: ft
-
-    INTEGER(iwp)::  idum
-    INTEGER(iwp)::  ishape(1)
+    COMPLEX(wp), DIMENSION(SIZE(array, 1)) ::  ft  !<
+
+    INTEGER(iwp) ::  idum       !<
+    INTEGER(iwp) ::  ishape(1)  !<
 
 !
@@ -208,5 +215,5 @@
     ft = array
     ishape = SHAPE( array )
-    CALL fftn(ft, ishape, inv = inv,  stat = stat)
+    CALL fftn( ft, ishape, inv = inv,  stat = stat )
 !
 !-- Next statement to prevent compiler warning about unused variable
@@ -216,21 +223,78 @@
 
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft2d(array, dim, inv, stat) RESULT(ft)
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft2d( array, dim, inv, stat ) RESULT( ft )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                 INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                      INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp),  DIMENSION(:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:),   INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                 INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                      INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Function result
-    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2)):: ft
-
-    INTEGER(iwp) ::  ishape(2)
+    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(2)  !<
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn( ft, ishape, dim, inv, stat )
+
+ END FUNCTION fft2d
+
+
+!--------------------------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft3d( array, dim, inv, stat ) RESULT( ft )
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:),     INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                   INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                        INTENT(IN),  OPTIONAL ::  inv    !<
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(3)  !<
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array)
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft3d
+
+
+!--------------------------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft4d( array, dim, inv, stat ) RESULT( ft )
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:),       INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                     INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                          INTENT(IN),  OPTIONAL ::  inv    !<
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(4)  !<
 !
 !-- Intrinsics used
@@ -241,55 +305,25 @@
     CALL fftn(ft, ishape, dim, inv, stat)
 
- END FUNCTION fft2d
-
-
-!------------------------------------------------------------------------------!
+ END FUNCTION fft4d
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft3d(array, dim, inv, stat) RESULT(ft)
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft5d( array, dim, inv, stat ) RESULT( ft )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),     INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                   INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp),  DIMENSION(:,:,:,:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:),         INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                       INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                            INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Function result
-    COMPLEX(wp), &
-         DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)):: ft
-
-    INTEGER(iwp) ::  ishape(3)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array)
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft3d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft4d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                     INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                          INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4)):: ft
-
-    INTEGER(iwp) ::  ishape(4)
+    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), SIZE(array, 5)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(5)  !<
+
 !
 !-- Intrinsics used
@@ -300,26 +334,25 @@
     CALL fftn(ft, ishape, dim, inv, stat)
 
- END FUNCTION fft4d
-
-
-!------------------------------------------------------------------------------!
+ END FUNCTION fft5d
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft5d(array, dim, inv, stat) RESULT(ft)
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft6d( array, dim, inv, stat ) RESULT( ft )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),         INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                       INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                            INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp),  DIMENSION(:,:,:,:,:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp), DIMENSION(:),           INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                         INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                              INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5)):: ft
-
-    INTEGER(iwp) ::  ishape(5)
+    COMPLEX(wp), DIMENSION( SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4),        &
+                            SIZE(array, 5), SIZE(array, 6)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(6)  !<
 
 !
@@ -331,26 +364,25 @@
     CALL fftn(ft, ishape, dim, inv, stat)
 
- END FUNCTION fft5d
-
-
-!------------------------------------------------------------------------------!
+ END FUNCTION fft6d
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft6d(array, dim, inv, stat) RESULT(ft)
+!--------------------------------------------------------------------------------------------------!
+ FUNCTION fft7d( array, dim, inv, stat ) RESULT( ft )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),           INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                         INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp), DIMENSION(:,:,:,:,:,:,:), INTENT(IN)            ::  array  !<
+    INTEGER(iwp),            DIMENSION(:), INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),                          INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                               INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5), SIZE(array, 6)):: ft
-
-    INTEGER(iwp) ::  ishape(6)
+    COMPLEX(wp), DIMENSION( SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4),        &
+                            SIZE(array, 5), SIZE(array, 6), SIZE(array, 7)) ::  ft  !<
+
+    INTEGER(iwp) ::  ishape(7)  !<
 
 !
@@ -362,59 +394,28 @@
     CALL fftn(ft, ishape, dim, inv, stat)
 
- END FUNCTION fft6d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft7d(array, dim, inv, stat) RESULT(ft)
+ END FUNCTION fft7d
+
+
+!--------------------------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE fftn( array, shape, dim, inv, stat )
 !
 !-- Formal parameters
-    COMPLEX(wp), DIMENSION(:,:,:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp),          DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                          INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                               INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5), SIZE(array, 6), SIZE(array, 7)):: ft
-
-    INTEGER(iwp) ::  ishape(7)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft7d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE fftn(array, shape, dim, inv, stat)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
-    INTEGER(iwp), DIMENSION(:), INTENT(IN)           :: shape
-    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
+    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)         ::  array  !<
+    INTEGER(iwp), DIMENSION(:), INTENT(IN)            ::  shape  !<
+    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL ::  dim    !<
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL ::  stat   !<
+    LOGICAL,                    INTENT(IN),  OPTIONAL ::  inv    !<
 !
 !-- Local arrays
-    INTEGER(iwp), DIMENSION(SIZE(shape)):: d
+    INTEGER(iwp), DIMENSION(SIZE(shape)) ::  d  !<
 !
 !-- Local scalars
-    LOGICAL      :: inverse
-    INTEGER(iwp) :: i, ndim, ntotal
-    REAL(wp):: scale
+    LOGICAL      ::  inverse          !<
+    INTEGER(iwp) ::  i, ndim, ntotal  !<
+    REAL(wp)     ::  scale            !<
 !
 !-- Intrinsics used
@@ -423,29 +424,27 @@
 !
 !-- Optional parameter settings
-    IF (PRESENT(inv)) THEN
+    IF ( PRESENT( inv ) )  THEN
        inverse = inv
     ELSE
        inverse = .FALSE.
     END IF
-    IF (PRESENT(dim)) THEN
-       ndim = MIN(SIZE(dim), SIZE(d))
-       d(1:ndim) = DIM(1:ndim)
+    IF ( PRESENT( dim ) )  THEN
+       ndim = MIN( SIZE( dim ), SIZE( d ) )
+       d(1:ndim) = DIM( 1:ndim )
     ELSE
-       ndim = SIZE(d)
-       d = (/(i, i = 1, SIZE(d))/)
+       ndim = SIZE( d )
+        d = (/( i, i = 1, SIZE( d ) )/)
     END IF
 
-    ntotal = PRODUCT(shape)
-    scale = SQRT(1.0_wp / PRODUCT(shape(d(1:ndim))))
-    DO i = 1, ntotal
-       array(i) = CMPLX(REAL(array(i)) * scale, AIMAG(array(i)) * scale, &
-            KIND=wp)
+    ntotal = PRODUCT( shape )
+    scale = SQRT( 1.0_wp / PRODUCT( shape( d(1:ndim) ) ) )
+    DO  i = 1, ntotal
+       array(i) = CMPLX( REAL( array(i) ) * scale, AIMAG( array(i) ) * scale, KIND = wp )
     END DO
 
-    DO i = 1, ndim
-       CALL fftradix(array, ntotal, shape(d(i)), PRODUCT(shape(1:d(i))), &
-            inverse, stat)
-       IF (PRESENT(stat)) THEN
-          IF (stat /=0) RETURN
+    DO  i = 1, ndim
+       CALL fftradix( array, ntotal, shape( d(i) ), PRODUCT( shape( 1:d(i) ) ), inverse, stat )
+       IF ( PRESENT( stat ) )  THEN
+          IF ( stat /= 0 )  RETURN
        END IF
     END DO
@@ -454,732 +453,711 @@
 
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE fftradix(array, ntotal, npass, nspan, inv, stat)
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE fftradix( array, ntotal, npass, nspan, inv, stat )
 !
 !-- Formal parameters
-    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
-    INTEGER(iwp),               INTENT(IN)           :: ntotal, npass, nspan
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN)           :: inv
+    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)         ::  array                 !<
+    INTEGER(iwp),               INTENT(IN)            ::  ntotal, npass, nspan  !<
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL ::  stat                  !<
+    LOGICAL,                    INTENT(IN)            ::  inv                   !<
 !
 !-- Local arrays
-    COMPLEX(wp),  DIMENSION(:), ALLOCATABLE  :: ctmp
-    INTEGER(iwp), DIMENSION(BIT_SIZE(0))     :: factor
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE  :: perm
-    REAL(wp),     DIMENSION(:), ALLOCATABLE  :: sine, cosine
+    COMPLEX(wp),  DIMENSION(:), ALLOCATABLE ::  ctmp          !<
+    INTEGER(iwp), DIMENSION(BIT_SIZE(0))    ::  factor        !<
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  perm          !<
+    REAL(wp),     DIMENSION(:), ALLOCATABLE ::  sine, cosine  !<
 !
 !-- Local scalars
-    INTEGER(iwp)         :: maxfactor, nfactor, nsquare, nperm
+    INTEGER(iwp) ::  maxfactor, nfactor, nsquare, nperm  !<
 !
 !-- Intrinsics used
-    INTRINSIC MAXVAL, MOD, PRESENT, ISHFT, BIT_SIZE, SIN, COS, &
-         CMPLX, REAL, AIMAG
-
-    IF (npass <= 1) RETURN
-
-    CALL factorize(npass, factor, nfactor, nsquare)
-
-    maxfactor = MAXVAL(factor(:nfactor))
-    IF (nfactor - ISHFT(nsquare, 1) > 0) THEN
-       nperm = MAX(nfactor + 1, PRODUCT(factor(nsquare+1: nfactor-nsquare)) - 1)
+    INTRINSIC MAXVAL, MOD, PRESENT, ISHFT, BIT_SIZE, SIN, COS, CMPLX, REAL, AIMAG
+
+    IF ( npass <= 1 )  RETURN
+
+    CALL factorize( npass, factor, nfactor, nsquare )
+
+    maxfactor = MAXVAL( factor(:nfactor) )
+    IF ( nfactor - ISHFT( nsquare, 1 ) > 0 )  THEN
+       nperm = MAX( nfactor + 1, PRODUCT( factor(nsquare+1: nfactor-nsquare) ) - 1 )
     ELSE
        nperm = nfactor + 1
     END IF
 
-    IF (PRESENT(stat)) THEN
-       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT=stat)
-       IF (stat /= 0) RETURN
-       CALL transform(array, ntotal, npass, nspan, &
-            factor, nfactor, ctmp, sine, cosine, inv)
-       DEALLOCATE(sine, cosine, STAT=stat)
-       IF (stat /= 0) RETURN
-       ALLOCATE(perm(nperm), STAT=stat)
-       IF (stat /= 0) RETURN
-       CALL permute(array, ntotal, npass, nspan, &
-            factor, nfactor, nsquare, maxfactor, &
-            ctmp, perm)
-       DEALLOCATE(perm, ctmp, STAT=stat)
-       IF (stat /= 0) RETURN
+    IF ( PRESENT( stat ) )  THEN
+       ALLOCATE( ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT = stat )
+       IF ( stat /= 0 )  RETURN
+       CALL transform( array, ntotal, npass, nspan, factor, nfactor, ctmp, sine, cosine, inv )
+       DEALLOCATE( sine, cosine, STAT = stat )
+       IF ( stat /= 0 )  RETURN
+       ALLOCATE( perm(nperm), STAT = stat )
+       IF ( stat /= 0 )  RETURN
+       CALL permute( array, ntotal, npass, nspan, factor, nfactor, nsquare, maxfactor, ctmp, perm )
+       DEALLOCATE( perm, ctmp, STAT = stat )
+       IF ( stat /= 0 )  RETURN
     ELSE
-       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor))
-       CALL transform(array, ntotal, npass, nspan, &
-            factor, nfactor, ctmp, sine, cosine, inv)
-       DEALLOCATE(sine, cosine)
-       ALLOCATE(perm(nperm))
-       CALL permute(array, ntotal, npass, nspan, &
-            factor, nfactor, nsquare, maxfactor, &
-            ctmp, perm)
-       DEALLOCATE(perm, ctmp)
+       ALLOCATE( ctmp(maxfactor), sine(maxfactor), cosine(maxfactor) )
+       CALL transform( array, ntotal, npass, nspan, factor, nfactor, ctmp, sine, cosine, inv )
+       DEALLOCATE( sine, cosine )
+       ALLOCATE( perm(nperm) )
+       CALL permute( array, ntotal, npass, nspan, factor, nfactor, nsquare, maxfactor, ctmp, perm )
+       DEALLOCATE( perm, ctmp )
     END IF
 
 
-  CONTAINS
-
-
-!------------------------------------------------------------------------------!
+ CONTAINS
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE factorize(npass, factor, nfactor, nsquare)
-!
-!--   Formal parameters
-      INTEGER(iwp),               INTENT(IN) :: npass
-      INTEGER(iwp), DIMENSION(*), INTENT(OUT):: factor
-      INTEGER(iwp),               INTENT(OUT):: nfactor, nsquare
-!
-!--   Local scalars
-      INTEGER(iwp):: j, jj, k
-
-      nfactor = 0
-      k = npass
-      DO WHILE (MOD(k, 16) == 0) 
-         nfactor = nfactor + 1
-         factor(nfactor) = 4
-         k = k / 16
-      END DO
-      j = 3
-      jj = 9
-      DO
-         DO WHILE (MOD(k, jj) == 0)
-            nfactor = nfactor + 1
-            factor(nfactor) = j
-            k = k / jj
-         END DO
-         j = j + 2
-         jj = j * j
-         IF (jj > k) EXIT
-      END DO
-      IF (k <= 4) THEN
-         nsquare = nfactor
-         factor(nfactor + 1) = k
-         IF (k /= 1) nfactor = nfactor + 1
-      ELSE 
-         IF (k - ISHFT(k / 4, 2) == 0) THEN
-            nfactor = nfactor + 1
-            factor(nfactor) = 2
-            k = k / 4
-         END IF
-         nsquare = nfactor
-         j = 2
-         DO
-            IF (MOD(k, j) == 0) THEN
-               nfactor = nfactor + 1
-               factor(nfactor) = j
-               k = k / j
-            END IF
-            j = ISHFT((j + 1) / 2, 1) + 1
-            IF (j > k) EXIT
-         END DO
-      END IF
-      IF (nsquare > 0) THEN
-         j = nsquare
-         DO
-            nfactor = nfactor + 1
-            factor(nfactor) = factor(j)
-            j = j - 1
-            IF (j==0) EXIT
-         END DO
-      END IF
-
-    END SUBROUTINE factorize
-
-
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE factorize( npass, factor, nfactor, nsquare )
+!
+!-- Formal parameters
+    INTEGER(iwp),               INTENT(IN)  ::  npass             !<
+    INTEGER(iwp),               INTENT(OUT) ::  nfactor, nsquare  !<
+    INTEGER(iwp), DIMENSION(*), INTENT(OUT) ::  factor            !<
+!
+!-- Local scalars
+    INTEGER(iwp) ::  j, jj, k  !<
+
+    nfactor = 0
+    k = npass
+    DO WHILE ( MOD( k, 16 ) == 0 )
+       nfactor = nfactor + 1
+       factor(nfactor) = 4
+       k = k / 16
+    END DO
+    j = 3
+    jj = 9
+    DO
+       DO WHILE ( MOD( k, jj ) == 0 )
+          nfactor = nfactor + 1
+          factor(nfactor) = j
+          k = k / jj
+       END DO
+       j = j + 2
+       jj = j * j
+       IF ( jj > k )  EXIT
+    END DO
+    IF ( k <= 4 )  THEN
+       nsquare = nfactor
+       factor(nfactor + 1) = k
+       IF ( k /= 1 )  nfactor = nfactor + 1
+    ELSE
+       IF ( k - ISHFT( k / 4, 2 ) == 0 )  THEN
+          nfactor = nfactor + 1
+          factor(nfactor) = 2
+          k = k / 4
+       END IF
+       nsquare = nfactor
+       j = 2
+       DO
+          IF ( MOD(k, j) == 0 )  THEN
+             nfactor = nfactor + 1
+             factor(nfactor) = j
+             k = k / j
+          END IF
+          j = ISHFT( (j + 1) / 2, 1 ) + 1
+          IF ( j > k )  EXIT
+       END DO
+    END IF
+    IF ( nsquare > 0 )  THEN
+       j = nsquare
+       DO
+          nfactor = nfactor + 1
+          factor(nfactor) = factor(j)
+          j = j - 1
+          IF ( j == 0 )  EXIT
+       END DO
+    END IF
+
+ END SUBROUTINE factorize
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE transform(array, ntotal, npass, nspan, &
-         factor, nfactor, ctmp, sine, cosine, inv) !-- compute fourier transform
-!
-!--   Formal parameters
-      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
-      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
-      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
-      INTEGER(iwp), DIMENSION(*), INTENT(IN)    :: factor
-      INTEGER(iwp),               INTENT(IN)    :: nfactor
-      LOGICAL,                    INTENT(IN)    :: inv
-      REAL(wp),     DIMENSION(*), INTENT(OUT)   :: sine, cosine
-!
-!--   Local scalars
-      INTEGER(iwp):: ii, ispan
-      INTEGER(iwp):: j, jc, jf, jj
-      INTEGER(iwp):: k, kk, kspan, k1, k2, k3, k4
-      INTEGER(iwp):: nn, nt
-      REAL(wp)    :: s60, c72, s72, pi2, radf
-      REAL(wp)    :: c1, s1, c2, s2, c3, s3, cd, sd, ak
-      COMPLEX(wp) :: cc, cj, ck, cjp, cjm, ckp, ckm
-
-      c72 = cos72
-      IF (inv) THEN
-         s72 = sin72
-         s60 = sin60
-         pi2 = pi
-      ELSE
-         s72 = -sin72
-         s60 = -sin60
-         pi2 = -pi
-      END IF
-
-      nt = ntotal
-      nn = nt - 1
-      kspan = nspan
-      jc = nspan / npass
-      radf = pi2 * jc
-      pi2 = pi2 * 2.0_wp !-- use 2 PI from here on
-
-      ii = 0
-      jf = 0
-      DO
-         sd = radf / kspan
-         cd = SIN(sd)
-         cd = 2.0_wp * cd * cd
-         sd = SIN(sd + sd)
-         kk = 1
-         ii = ii + 1
-
-         SELECT CASE (factor(ii))
-         CASE (2)
-!
-!--         Transform for factor of 2 (including rotation factor)
-            kspan = kspan / 2
-            k1 = kspan + 2
-            DO
-               DO
-                  k2 = kk + kspan
-                  ck = array(k2)
-                  array(k2) = array(kk)-ck
-                  array(kk) = array(kk) + ck
-                  kk = k2 + kspan
-                  IF (kk > nn) EXIT
-               END DO
-               kk = kk - nn
-               IF (kk > jc) EXIT
-            END DO
-            IF (kk > kspan) RETURN
-            DO
-               c1 = 1.0_wp - cd
-               s1 = sd
-               DO
-                  DO
-                     DO
-                        k2 = kk + kspan
-                        ck = array(kk) - array(k2)
-                        array(kk) = array(kk) + array(k2)
-                        array(k2) = ck * CMPLX(c1, s1, KIND=wp)
-                        kk = k2 + kspan
-                        IF (kk >= nt) EXIT
-                     END DO
-                     k2 = kk - nt
-                     c1 = -c1
-                     kk = k1 - k2
-                     IF (kk <= k2) EXIT
-                  END DO
-                  ak = c1 - (cd * c1 + sd * s1)
-                  s1 = sd * c1 - cd * s1 + s1
-                  c1 = 2.0_wp - (ak * ak + s1 * s1)
-                  s1 = s1 * c1
-                  c1 = c1 * ak
-                  kk = kk + jc
-                  IF (kk >= k2) EXIT
-               END DO
-               k1 = k1 + 1 + 1
-               kk = (k1 - kspan) / 2 + jc
-               IF (kk > jc + jc) EXIT
-            END DO
-
-         CASE (4) !-- transform for factor of 4
-            ispan = kspan
-            kspan = kspan / 4
-
-            DO
-               c1 = 1.0_wp
-               s1 = 0.0_wp
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     k3 = k2 + kspan
-                     ckp = array(kk) + array(k2)
-                     ckm = array(kk) - array(k2)
-                     cjp = array(k1) + array(k3)
-                     cjm = array(k1) - array(k3)
-                     array(kk) = ckp + cjp
-                     cjp = ckp - cjp
-                     IF (inv) THEN
-                        ckp = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
-                        ckm = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
-                     ELSE
-                        ckp = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
-                        ckm = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
-                     END IF
-!
-!--                  Avoid useless multiplies
-                     IF (s1 == 0.0_wp) THEN
-                        array(k1) = ckp
-                        array(k2) = cjp
-                        array(k3) = ckm
-                     ELSE
-                        array(k1) = ckp * CMPLX(c1, s1, KIND=wp)
-                        array(k2) = cjp * CMPLX(c2, s2, KIND=wp)
-                        array(k3) = ckm * CMPLX(c3, s3, KIND=wp)
-                     END IF
-                     kk = k3 + kspan
-                     IF (kk > nt) EXIT
-                  END DO
-
-                  c2 = c1 - (cd * c1 + sd * s1)
-                  s1 = sd * c1 - cd * s1 + s1
-                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
-                  s1 = s1 * c1
-                  c1 = c1 * c2
-!
-!--               Values of c2, c3, s2, s3 that will get used next time
-                  c2 = c1 * c1 - s1 * s1
-                  s2 = 2.0_wp * c1 * s1
-                  c3 = c2 * c1 - s2 * s1
-                  s3 = c2 * s1 + s2 * c1
-                  kk = kk - nt + jc
-                  IF (kk > kspan) EXIT
-               END DO
-               kk = kk - kspan + 1
-               IF (kk > jc) EXIT
-            END DO
-            IF (kspan == jc) RETURN
-
-         CASE default
-!
-!--         Transform for odd factors
-            k = factor(ii)
-            ispan = kspan
-            kspan = kspan / k
-
-            SELECT CASE (k)
-            CASE (3) !-- transform for factor of 3 (optional code)
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     ck = array(kk)
-                     cj = array(k1) + array(k2)
-                     array(kk) = ck + cj
-                     ck = ck - CMPLX( &
-                          0.5_wp * REAL (cj), &
-                          0.5_wp * AIMAG(cj), &
-                          KIND=wp)
-                     cj = CMPLX( &
-                          (REAL (array(k1)) - REAL (array(k2))) * s60, &
-                          (AIMAG(array(k1)) - AIMAG(array(k2))) * s60, &
-                          KIND=wp)
-                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     kk = k2 + kspan
-                     IF (kk >= nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            CASE (5) !-- transform for factor of 5 (optional code)
-               c2 = c72 * c72 - s72 * s72
-               s2 = 2.0_wp * c72 * s72
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     k3 = k2 + kspan
-                     k4 = k3 + kspan
-                     ckp = array(k1) + array(k4)
-                     ckm = array(k1) - array(k4)
-                     cjp = array(k2) + array(k3)
-                     cjm = array(k2) - array(k3)
-                     cc = array(kk)
-                     array(kk) = cc + ckp + cjp
-                     ck = CMPLX(REAL(ckp) * c72, AIMAG(ckp) * c72, &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjp) * c2,  AIMAG(cjp) * c2,  &
-                          KIND=wp) + cc
-                     cj = CMPLX(REAL(ckm) * s72, AIMAG(ckm) * s72, &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjm) * s2,  AIMAG(cjm) * s2,  &
-                          KIND=wp)
-                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k4) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     ck = CMPLX(REAL(ckp) * c2,  AIMAG(ckp) * c2,  &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjp) * c72, AIMAG(cjp) * c72, &
-                          KIND=wp) + cc
-                     cj = CMPLX(REAL(ckm) * s2,  AIMAG(ckm) * s2,  &
-                          KIND=wp) - &
-                          CMPLX(REAL(cjm) * s72, AIMAG(cjm) * s72, &
-                          KIND=wp)
-                     array(k2) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k3) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     kk = k4 + kspan
-                     IF (kk >= nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            CASE default
-               IF (k /= jf) THEN
-                  jf = k
-                  s1 = pi2 / k
-                  c1 = COS(s1)
-                  s1 = SIN(s1)
-                  cosine (jf) = 1.0_wp
-                  sine (jf) = 0.0_wp
-                  j = 1
-                  DO
-                     cosine (j) = cosine (k) * c1 + sine (k) * s1
-                     sine (j) = cosine (k) * s1 - sine (k) * c1
-                     k = k-1
-                     cosine (k) = cosine (j)
-                     sine (k) = -sine (j)
-                     j = j + 1
-                     IF (j >= k) EXIT
-                  END DO
-               END IF
-               DO
-                  DO
-                     k1 = kk
-                     k2 = kk + ispan
-                     cc = array(kk)
-                     ck = cc
-                     j = 1
-                     k1 = k1 + kspan
-                     DO
-                        k2 = k2 - kspan
-                        j = j + 1
-                        ctmp(j) = array(k1) + array(k2)
-                        ck = ck + ctmp(j)
-                        j = j + 1
-                        ctmp(j) = array(k1) - array(k2)
-                        k1 = k1 + kspan
-                        IF (k1 >= k2) EXIT
-                     END DO
-                     array(kk) = ck
-                     k1 = kk
-                     k2 = kk + ispan
-                     j = 1
-                     DO
-                        k1 = k1 + kspan
-                        k2 = k2 - kspan
-                        jj = j
-                        ck = cc
-                        cj = (0.0_wp, 0.0_wp)
-                        k = 1
-                        DO
-                           k = k + 1
-                           ck = ck + CMPLX( &
-                                REAL (ctmp(k)) * cosine(jj), &
-                                AIMAG(ctmp(k)) * cosine(jj), KIND=wp)
-                           k = k + 1
-                           cj = cj + CMPLX( &
-                                REAL (ctmp(k)) * sine(jj), &
-                                AIMAG(ctmp(k)) * sine(jj), KIND=wp)
-                           jj = jj + j
-                           IF (jj > jf) jj = jj - jf
-                           IF (k >= jf) EXIT
-                        END DO
-                        k = jf - j
-                        array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), &
-                             KIND=wp)
-                        array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), &
-                             KIND=wp)
-                        j = j + 1
-                        IF (j >= k) EXIT
-                     END DO
-                     kk = kk + ispan
-                     IF (kk > nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            END SELECT
-!
-!--         Multiply by rotation factor (except for factors of 2 and 4)
-            IF (ii == nfactor) RETURN
-            kk = jc + 1
-            DO
-               c2 = 1.0_wp - cd
-               s1 = sd
-               DO
-                  c1 = c2
-                  s2 = s1
-                  kk = kk + kspan
-                  DO
-                     DO
-                        array(kk) = CMPLX(c2, s2, KIND=wp) * array(kk)
-                        kk = kk + ispan
-                        IF (kk > nt) EXIT
-                     END DO
-                     ak = s1 * s2
-                     s2 = s1 * c2 + c1 * s2
-                     c2 = c1 * c2 - ak
-                     kk = kk - nt + kspan
-                     IF (kk > ispan) EXIT
-                  END DO
-                  c2 = c1 - (cd * c1 + sd * s1)
-                  s1 = s1 + sd * c1 - cd * s1
-                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
-                  s1 = s1 * c1
-                  c2 = c2 * c1
-                  kk = kk - ispan + jc
-                  IF (kk > kspan) EXIT
-               END DO
-               kk = kk - kspan + jc + 1
-               IF (kk > jc + jc) EXIT
-            END DO
-
-         END SELECT
-      END DO
-    END SUBROUTINE transform
-
-
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE transform( array, ntotal, npass, nspan, factor, nfactor, ctmp, sine, cosine, inv )
+!-- Compute fourier transform
+
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT) ::  array                 !<
+    COMPLEX(wp),  DIMENSION(*), INTENT(OUT)    ::  ctmp                  !<
+    INTEGER(iwp),               INTENT(IN)     ::  ntotal, npass, nspan  !<
+    INTEGER(iwp), DIMENSION(*), INTENT(IN)     ::  factor                !<
+    INTEGER(iwp),               INTENT(IN)     ::  nfactor               !<
+    LOGICAL,                    INTENT(IN)     ::  inv                   !<
+    REAL(wp),     DIMENSION(*), INTENT(OUT)    ::  sine, cosine          !<
+!
+!-- Local scalars
+    COMPLEX(wp)  ::  cc, cj, ck, cjp, cjm, ckp, ckm      !<
+    INTEGER(iwp) ::  ii, ispan                           !<
+    INTEGER(iwp) ::  j, jc, jf, jj                       !<
+    INTEGER(iwp) ::  k, kk, kspan, k1, k2, k3, k4        !<
+    INTEGER(iwp) ::  nn, nt                              !<
+    REAL(wp)     ::  s60, c72, s72, pi2, radf            !<
+    REAL(wp)     ::  c1, s1, c2, s2, c3, s3, cd, sd, ak  !<
+
+    c72 = cos72
+    IF ( inv )  THEN
+       s72 = sin72
+       s60 = sin60
+       pi2 = pi
+    ELSE
+       s72 = - sin72
+       s60 = - sin60
+       pi2 = - pi
+    END IF
+
+    nt = ntotal
+    nn = nt - 1
+    kspan = nspan
+    jc = nspan / npass
+    radf = pi2 * jc
+    pi2 = pi2 * 2.0_wp !-- Use 2 PI from here on
+
+    ii = 0
+    jf = 0
+    DO
+       sd = radf / kspan
+       cd = SIN( sd )
+       cd = 2.0_wp * cd * cd
+       sd = SIN( sd + sd )
+       kk = 1
+       ii = ii + 1
+
+       SELECT CASE ( factor(ii) )
+       CASE ( 2 )
+!
+!--       Transform for factor of 2 (including rotation factor)
+          kspan = kspan / 2
+          k1 = kspan + 2
+          DO
+             DO
+                k2 = kk + kspan
+                ck = array(k2)
+                array(k2) = array(kk) - ck
+                array(kk) = array(kk) + ck
+                kk = k2 + kspan
+                IF ( kk > nn )  EXIT
+             END DO
+             kk = kk - nn
+             IF ( kk > jc )  EXIT
+          END DO
+          IF ( kk > kspan )  RETURN
+          DO
+             c1 = 1.0_wp - cd
+             s1 = sd
+             DO
+                DO
+                   DO
+                      k2 = kk + kspan
+                      ck = array(kk) - array(k2)
+                      array(kk) = array(kk) + array(k2)
+                      array(k2) = ck * CMPLX( c1, s1, KIND = wp )
+                      kk = k2 + kspan
+                      IF ( kk >= nt )  EXIT
+                   END DO
+                   k2 = kk - nt
+                   c1 = - c1
+                   kk = k1 - k2
+                   IF ( kk <= k2 )  EXIT
+                END DO
+                ak = c1 - (cd * c1 + sd * s1)
+                s1 = sd * c1 - cd * s1 + s1
+                c1 = 2.0_wp - ( ak * ak + s1 * s1 )
+                s1 = s1 * c1
+                c1 = c1 * ak
+                kk = kk + jc
+                IF ( kk >= k2 ) EXIT
+             END DO
+             k1 = k1 + 1 + 1
+             kk = ( k1 - kspan ) / 2 + jc
+             IF ( kk > jc + jc )  EXIT
+          END DO
+!
+!--    Transform for factor of 4
+       CASE ( 4 )
+          ispan = kspan
+          kspan = kspan / 4
+
+          DO
+             c1 = 1.0_wp
+             s1 = 0.0_wp
+             DO
+                DO
+                   k1 = kk + kspan
+                   k2 = k1 + kspan
+                   k3 = k2 + kspan
+                   ckp = array(kk) + array(k2)
+                   ckm = array(kk) - array(k2)
+                   cjp = array(k1) + array(k3)
+                   cjm = array(k1) - array(k3)
+                   array(kk) = ckp + cjp
+                   cjp = ckp - cjp
+                   IF ( inv )  THEN
+                      ckp = ckm + CMPLX( - AIMAG( cjm ), REAL( cjm ), KIND = wp )
+                      ckm = ckm + CMPLX( AIMAG( cjm ), - REAL( cjm ), KIND = wp )
+                   ELSE
+                      ckp = ckm + CMPLX( AIMAG( cjm ), - REAL( cjm ), KIND = wp )
+                      ckm = ckm + CMPLX( - AIMAG( cjm ), REAL( cjm ), KIND = wp )
+                   END IF
+!
+!--                Avoid useless multiplies
+                   IF ( s1 == 0.0_wp )  THEN
+                      array(k1) = ckp
+                      array(k2) = cjp
+                      array(k3) = ckm
+                   ELSE
+                      array(k1) = ckp * CMPLX( c1, s1, KIND = wp )
+                      array(k2) = cjp * CMPLX( c2, s2, KIND = wp )
+                      array(k3) = ckm * CMPLX( c3, s3, KIND = wp )
+                   END IF
+                   kk = k3 + kspan
+                   IF ( kk > nt )  EXIT
+                END DO
+
+                c2 = c1 - ( cd * c1 + sd * s1 )
+                s1 = sd * c1 - cd * s1 + s1
+                c1 = 2.0_wp - ( c2 * c2 + s1 * s1 )
+                s1 = s1 * c1
+                c1 = c1 * c2
+!
+!--             Values of c2, c3, s2, s3 that will get used next time
+                c2 = c1 * c1 - s1 * s1
+                s2 = 2.0_wp * c1 * s1
+                c3 = c2 * c1 - s2 * s1
+                s3 = c2 * s1 + s2 * c1
+                kk = kk - nt + jc
+                IF ( kk > kspan )  EXIT
+             END DO
+             kk = kk - kspan + 1
+             IF ( kk > jc )  EXIT
+          END DO
+          IF ( kspan == jc )  RETURN
+
+       CASE default
+!
+!--       Transform for odd factors
+          k = factor(ii)
+          ispan = kspan
+          kspan = kspan / k
+
+          SELECT CASE ( k )
+!
+!--       Transform for factor of 3 (optional code)
+          CASE ( 3 )
+             DO
+                DO
+                   k1 = kk + kspan
+                   k2 = k1 + kspan
+                   ck = array(kk)
+                   cj = array(k1) + array(k2)
+                   array(kk) = ck + cj
+                   ck = ck - CMPLX( 0.5_wp * REAL( cj ), 0.5_wp * AIMAG( cj ), KIND = wp )
+                   cj = CMPLX( ( REAL( array(k1) ) - REAL( array(k2) ) ) * s60,                    &
+                               ( AIMAG( array(k1) ) - AIMAG( array(k2) ) ) * s60, KIND = wp )
+                   array(k1) = ck + CMPLX( - AIMAG( cj ), REAL( cj ), KIND = wp )
+                   array(k2) = ck + CMPLX( AIMAG( cj ), - REAL( cj ), KIND = wp )
+                   kk = k2 + kspan
+                   IF ( kk >= nn )  EXIT
+                END DO
+                kk = kk - nn
+                IF ( kk > kspan )  EXIT
+             END DO
+!
+!--       Transform for factor of 5 (optional code)
+          CASE ( 5 )
+             c2 = c72 * c72 - s72 * s72
+             s2 = 2.0_wp * c72 * s72
+             DO
+                DO
+                   k1 = kk + kspan
+                   k2 = k1 + kspan
+                   k3 = k2 + kspan
+                   k4 = k3 + kspan
+                   ckp = array(k1) + array(k4)
+                   ckm = array(k1) - array(k4)
+                   cjp = array(k2) + array(k3)
+                   cjm = array(k2) - array(k3)
+                   cc = array(kk)
+                   array(kk) = cc + ckp + cjp
+                   ck = CMPLX( REAL( ckp ) * c72, AIMAG( ckp ) * c72, KIND = wp ) +                &
+                        CMPLX( REAL( cjp ) * c2,  AIMAG( cjp ) * c2,  KIND = wp ) + cc
+                   cj = CMPLX( REAL( ckm ) * s72, AIMAG( ckm ) * s72, KIND = wp) +                 &
+                        CMPLX( REAL( cjm ) * s2,  AIMAG( cjm ) * s2,  KIND = wp )
+                   array(k1) = ck + CMPLX( - AIMAG( cj ), REAL( cj ), KIND = wp )
+                   array(k4) = ck + CMPLX( AIMAG( cj ), - REAL( cj ), KIND = wp )
+                   ck = CMPLX( REAL( ckp ) * c2,  AIMAG( ckp ) * c2,  KIND = wp ) +                &
+                        CMPLX( REAL( cjp ) * c72, AIMAG( cjp ) * c72, KIND = wp ) + cc
+                   cj = CMPLX( REAL( ckm ) * s2,  AIMAG( ckm ) * s2,  KIND = wp ) -                &
+                        CMPLX( REAL( cjm ) * s72, AIMAG( cjm ) * s72, KIND = wp )
+                   array(k2) = ck + CMPLX( -AIMAG( cj ), REAL( cj ), KIND = wp )
+                   array(k3) = ck + CMPLX( AIMAG( cj ), - REAL( cj ), KIND = wp )
+                   kk = k4 + kspan
+                   IF ( kk >= nn )  EXIT
+                END DO
+                kk = kk - nn
+                IF ( kk > kspan )  EXIT
+             END DO
+
+          CASE default
+             IF ( k /= jf )  THEN
+                jf = k
+                s1 = pi2 / k
+                c1 = COS( s1 )
+                s1 = SIN( s1 )
+                cosine(jf) = 1.0_wp
+                sine(jf) = 0.0_wp
+                j = 1
+                DO
+                   cosine(j) = cosine(k) * c1 + sine(k) * s1
+                   sine(j) = cosine(k) * s1 - sine(k) * c1
+                   k = k - 1
+                   cosine(k) = cosine(j)
+                   sine(k) = - sine(j)
+                   j = j + 1
+                   IF ( j >= k )  EXIT
+                END DO
+             END IF
+             DO
+                DO
+                   k1 = kk
+                   k2 = kk + ispan
+                   cc = array(kk)
+                   ck = cc
+                   j = 1
+                   k1 = k1 + kspan
+                   DO
+                      k2 = k2 - kspan
+                      j = j + 1
+                      ctmp(j) = array(k1) + array(k2)
+                      ck = ck + ctmp(j)
+                      j = j + 1
+                      ctmp(j) = array(k1) - array(k2)
+                      k1 = k1 + kspan
+                      IF ( k1 >= k2 )  EXIT
+                   END DO
+                   array(kk) = ck
+                   k1 = kk
+                   k2 = kk + ispan
+                   j = 1
+                   DO
+                      k1 = k1 + kspan
+                      k2 = k2 - kspan
+                      jj = j
+                      ck = cc
+                      cj = ( 0.0_wp, 0.0_wp )
+                      k = 1
+                      DO
+                         k = k + 1
+                         ck = ck + CMPLX( REAL( ctmp(k) ) * cosine(jj), AIMAG( ctmp(k) ) *         &
+                                          cosine(jj), KIND = wp )
+                         k = k + 1
+                         cj = cj + CMPLX( REAL( ctmp(k) ) * sine(jj), AIMAG( ctmp(k) ) * sine(jj), &
+                                          KIND = wp )
+                         jj = jj + j
+                         IF ( jj > jf )  jj = jj - jf
+                         IF ( k >= jf )  EXIT
+                      END DO
+                      k = jf - j
+                      array(k1) = ck + CMPLX( - AIMAG( cj ), REAL( cj ), KIND = wp )
+                      array(k2) = ck + CMPLX( AIMAG( cj ), -REAL( cj ), KIND = wp )
+                      j = j + 1
+                      IF ( j >= k )  EXIT
+                   END DO
+                   kk = kk + ispan
+                   IF ( kk > nn )  EXIT
+                END DO
+                kk = kk - nn
+                IF ( kk > kspan )  EXIT
+             END DO
+
+          END SELECT
+!
+!--       Multiply by rotation factor (except for factors of 2 and 4)
+          IF ( ii == nfactor )  RETURN
+          kk = jc + 1
+          DO
+             c2 = 1.0_wp - cd
+             s1 = sd
+             DO
+                c1 = c2
+                s2 = s1
+                kk = kk + kspan
+                DO
+                   DO
+                      array(kk) = CMPLX( c2, s2, KIND = wp ) * array(kk)
+                      kk = kk + ispan
+                      IF ( kk > nt )  EXIT
+                   END DO
+                   ak = s1 * s2
+                   s2 = s1 * c2 + c1 * s2
+                   c2 = c1 * c2 - ak
+                   kk = kk - nt + kspan
+                   IF ( kk > ispan )  EXIT
+                END DO
+                c2 = c1 - ( cd * c1 + sd * s1 )
+                s1 = s1 + sd * c1 - cd * s1
+                c1 = 2.0_wp - ( c2 * c2 + s1 * s1 )
+                s1 = s1 * c1
+                c2 = c2 * c1
+                kk = kk - ispan + jc
+                IF ( kk > kspan )  EXIT
+             END DO
+             kk = kk - kspan + jc + 1
+             IF ( kk > jc + jc )  EXIT
+          END DO
+
+       END SELECT
+    END DO
+ END SUBROUTINE transform
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE permute(array, ntotal, npass, nspan, &
-         factor, nfactor, nsquare, maxfactor, &
-         ctmp, perm)
-!
-!--   Formal parameters
-      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
-      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
-      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
-      INTEGER(iwp), DIMENSION(*), INTENT(IN OUT):: factor
-      INTEGER(iwp),               INTENT(IN)    :: nfactor, nsquare
-      INTEGER(iwp),               INTENT(IN)    :: maxfactor
-      INTEGER(iwp), DIMENSION(*), INTENT(OUT)   :: perm
-!
-!--   Local scalars
-      COMPLEX(wp) :: ck
-      INTEGER(iwp):: ii, ispan
-      INTEGER(iwp):: j, jc, jj
-      INTEGER(iwp):: k, kk, kspan, kt, k1, k2, k3
-      INTEGER(iwp):: nn, nt
-!
-!--   Permute the results to normal order---done in two stages
-!--   Permutation for square factors of n
-
-      nt = ntotal
-      nn = nt - 1
-      kt = nsquare
-      kspan = nspan
-      jc = nspan / npass
-
-      perm (1) = nspan
-      IF (kt > 0) THEN
-         k = kt + kt + 1
-         IF (nfactor < k) k = k - 1
-         j = 1
-         perm (k + 1) = jc
-         DO
-            perm (j + 1) = perm (j) / factor(j)
-            perm (k) = perm (k + 1) * factor(j)
-            j = j + 1
-            k = k - 1
-            IF (j >= k) EXIT
-         END DO
-         k3 = perm (k + 1)
-         kspan = perm (2)
-         kk = jc + 1
-         k2 = kspan + 1
-         j = 1
-
-         IF (npass /= ntotal) THEN
-            permute_multi: DO
-               DO
-                  DO
-                     k = kk + jc
-                     DO
-!
-!--                     Swap array(kk) <> array(k2)
-                        ck = array(kk)
-                        array(kk) = array(k2)
-                        array(k2) = ck
-                        kk = kk + 1
-                        k2 = k2 + 1
-                        IF (kk >= k) EXIT
-                     END DO
-                     kk = kk + nspan - jc
-                     k2 = k2 + nspan - jc
-                     IF (kk >= nt) EXIT
-                  END DO
-                  kk = kk - nt + jc
-                  k2 = k2 - nt + kspan
-                  IF (k2 >= nspan) EXIT
-               END DO
-               DO
-                  DO
-                     k2 = k2 - perm (j)
-                     j = j + 1
-                     k2 = perm (j + 1) + k2
-                     IF (k2 <= perm (j)) EXIT
-                  END DO
-                  j = 1
-                  DO
-                     IF (kk < k2) CYCLE permute_multi
-                     kk = kk + jc
-                     k2 = k2 + kspan
-                     IF (k2 >= nspan) EXIT
-                  END DO
-                  IF (kk >= nspan) EXIT
-               END DO
-               EXIT
-            END DO permute_multi
-         ELSE
-            permute_single: DO
-               DO
-!
-!--               Swap array(kk) <> array(k2)
-                  ck = array(kk)
-                  array(kk) = array(k2)
-                  array(k2) = ck
-                  kk = kk + 1
-                  k2 = k2 + kspan
-                  IF (k2 >= nspan) EXIT
-               END DO
-               DO
-                  DO
-                     k2 = k2 - perm (j)
-                     j = j + 1
-                     k2 = perm (j + 1) + k2
-                     IF (k2 <= perm (j)) EXIT
-                  END DO
-                  j = 1
-                  DO
-                     IF (kk < k2) CYCLE permute_single
-                     kk = kk + 1
-                     k2 = k2 + kspan
-                     IF (k2 >= nspan) EXIT
-                  END DO
-                  IF (kk >= nspan) EXIT
-               END DO
-               EXIT
-            END DO permute_single
-         END IF
-         jc = k3
-      END IF
-
-      IF (ISHFT(kt, 1) + 1 >= nfactor) RETURN
-
-      ispan = perm (kt + 1)
-!
-!--   Permutation for square-free factors of n
-      j = nfactor - kt
-      factor(j + 1) = 1
-      DO
-         factor(j) = factor(j) * factor(j+1)
-         j = j - 1
-         IF (j == kt) EXIT
-      END DO
-      kt = kt + 1
-      nn = factor(kt) - 1
-      j = 0
-      jj = 0
-      DO
-         k = kt + 1
-         k2 = factor(kt)
-         kk = factor(k)
-         j = j + 1
-         IF (j > nn) EXIT !-- exit infinite loop
-         jj = jj + kk
-         DO WHILE (jj >= k2)
-            jj = jj - k2
-            k2 = kk
-            k = k + 1
-            kk = factor(k)
-            jj = jj + kk
-         END DO
-         perm (j) = jj
-      END DO
-!
-!--   Determine the permutation cycles of length greater than 1
-      j = 0
-      DO
-         DO
-            j = j + 1
-            kk = perm(j)
-            IF (kk >= 0) EXIT
-         END DO
-         IF (kk /= j) THEN
-            DO
-               k = kk
-               kk = perm (k)
-               perm (k) = -kk
-               IF (kk == j) EXIT
-            END DO
-            k3 = kk
-         ELSE
-            perm (j) = -j
-            IF (j == nn) EXIT !-- exit infinite loop
-         END IF
-      END DO
-!
-!--   Reorder a and b, following the permutation cycles
-      DO
-         j = k3 + 1
-         nt = nt - ispan
-         ii = nt - 1 + 1
-         IF (nt < 0) EXIT !-- exit infinite loop
-         DO
-            DO
-               j = j-1
-               IF (perm(j) >= 0) EXIT
-            END DO
-            jj = jc
-            DO
-               kspan = jj
-               IF (jj > maxfactor) kspan = maxfactor
-               jj = jj - kspan
-               k = perm(j)
-               kk = jc * k + ii + jj
-               k1 = kk + kspan
-               k2 = 0
-               DO
-                  k2 = k2 + 1
-                  ctmp(k2) = array(k1)
-                  k1 = k1 - 1
-                  IF (k1 == kk) EXIT
-               END DO
-               DO
-                  k1 = kk + kspan
-                  k2 = k1 - jc * (k + perm(k))
-                  k = -perm(k)
-                  DO
-                     array(k1) = array(k2)
-                     k1 = k1 - 1
-                     k2 = k2 - 1
-                     IF (k1 == kk) EXIT
-                  END DO
-                  kk = k2
-                  IF (k == j) EXIT
-               END DO
-               k1 = kk + kspan
-               k2 = 0
-               DO
-                  k2 = k2 + 1
-                  array(k1) = ctmp(k2)
-                  k1 = k1 - 1
-                  IF (k1 == kk) EXIT
-               END DO
-               IF (jj == 0) EXIT
-            END DO
-            IF (j == 1) EXIT
-         END DO
-      END DO
-
-    END SUBROUTINE permute
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE permute( array, ntotal, npass, nspan, factor, nfactor, nsquare, maxfactor, ctmp, perm )
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT) ::  array                 !<
+    COMPLEX(wp),  DIMENSION(*), INTENT(OUT)    ::  ctmp                  !<
+    INTEGER(iwp),               INTENT(IN)     ::  ntotal, npass, nspan  !<
+    INTEGER(iwp),               INTENT(IN)     ::  nfactor, nsquare      !<
+    INTEGER(iwp),               INTENT(IN)     ::  maxfactor             !<
+    INTEGER(iwp), DIMENSION(*), INTENT(IN OUT) ::  factor                !<
+    INTEGER(iwp), DIMENSION(*), INTENT(OUT)    ::  perm                  !<
+!
+!-- Local scalars
+    COMPLEX(wp)  ::  ck                            !<
+    INTEGER(iwp) ::  ii, ispan                     !<
+    INTEGER(iwp) ::  j, jc, jj                     !<
+    INTEGER(iwp) ::  k, kk, kspan, kt, k1, k2, k3  !<
+    INTEGER(iwp) ::  nn, nt                        !<
+!
+!-- Permute the results to normal order---done in two stages
+!-- Permutation for square factors of n
+
+    nt = ntotal
+    nn = nt - 1
+    kt = nsquare
+    kspan = nspan
+    jc = nspan / npass
+
+    perm (1) = nspan
+    IF ( kt > 0 )  THEN
+       k = kt + kt + 1
+       IF ( nfactor < k )  k = k - 1
+       j = 1
+       perm(k + 1) = jc
+       DO
+          perm(j + 1) = perm(j) / factor(j)
+          perm(k) = perm(k + 1) * factor(j)
+          j = j + 1
+          k = k - 1
+          IF ( j >= k )  EXIT
+       END DO
+       k3 = perm(k + 1)
+       kspan = perm(2)
+       kk = jc + 1
+       k2 = kspan + 1
+       j = 1
+
+       IF ( npass /= ntotal )  THEN
+          permute_multi: DO
+             DO
+                DO
+                   k = kk + jc
+                   DO
+!
+!--                   Swap array(kk) <> array(k2)
+                      ck = array(kk)
+                      array(kk) = array(k2)
+                      array(k2) = ck
+                      kk = kk + 1
+                      k2 = k2 + 1
+                      IF ( kk >= k )  EXIT
+                   END DO
+                   kk = kk + nspan - jc
+                   k2 = k2 + nspan - jc
+                   IF ( kk >= nt )  EXIT
+                END DO
+                kk = kk - nt + jc
+                k2 = k2 - nt + kspan
+                IF ( k2 >= nspan )  EXIT
+             END DO
+             DO
+                DO
+                   k2 = k2 - perm(j)
+                   j = j + 1
+                   k2 = perm(j + 1) + k2
+                   IF ( k2 <= perm(j) )  EXIT
+                END DO
+                j = 1
+                DO
+                   IF ( kk < k2 )  CYCLE permute_multi
+                   kk = kk + jc
+                   k2 = k2 + kspan
+                   IF ( k2 >= nspan )  EXIT
+                END DO
+                IF ( kk >= nspan )  EXIT
+             END DO
+             EXIT
+          END DO permute_multi
+       ELSE
+          permute_single: DO
+             DO
+!
+!--             Swap array(kk) <> array(k2)
+                ck = array(kk)
+                array(kk) = array(k2)
+                array(k2) = ck
+                kk = kk + 1
+                k2 = k2 + kspan
+                IF ( k2 >= nspan )  EXIT
+             END DO
+             DO
+                DO
+                   k2 = k2 - perm(j)
+                   j = j + 1
+                   k2 = perm(j + 1) + k2
+                   IF ( k2 <= perm(j) )  EXIT
+                END DO
+                j = 1
+                DO
+                   IF ( kk < k2 )  CYCLE permute_single
+                   kk = kk + 1
+                   k2 = k2 + kspan
+                   IF ( k2 >= nspan )  EXIT
+                END DO
+                IF ( kk >= nspan )  EXIT
+             END DO
+             EXIT
+          END DO permute_single
+       END IF
+       jc = k3
+    END IF
+
+    IF ( ISHFT( kt, 1 ) + 1 >= nfactor )  RETURN
+
+    ispan = perm(kt + 1)
+!
+!-- Permutation for square-free factors of n
+    j = nfactor - kt
+    factor( j + 1 ) = 1
+    DO
+       factor(j) = factor(j) * factor(j+1)
+       j = j - 1
+       IF ( j == kt )  EXIT
+    END DO
+    kt = kt + 1
+    nn = factor( kt ) - 1
+    j = 0
+    jj = 0
+    DO
+       k = kt + 1
+       k2 = factor(kt)
+       kk = factor(k)
+       j = j + 1
+       IF ( j > nn )  EXIT !-- Exit infinite loop
+       jj = jj + kk
+       DO WHILE ( jj >= k2 )
+          jj = jj - k2
+          k2 = kk
+          k = k + 1
+          kk = factor(k)
+          jj = jj + kk
+       END DO
+       perm(j) = jj
+    END DO
+!
+!-- Determine the permutation cycles of length greater than 1
+    j = 0
+    DO
+       DO
+          j = j + 1
+          kk = perm(j)
+          IF ( kk >= 0 )  EXIT
+       END DO
+       IF ( kk /= j )  THEN
+          DO
+             k = kk
+             kk = perm(k)
+             perm(k) = - kk
+             IF ( kk == j )  EXIT
+          END DO
+          k3 = kk
+       ELSE
+          perm(j) = - j
+          IF ( j == nn )  EXIT !-- Exit infinite loop
+       END IF
+    END DO
+!
+!-- Reorder a and b, following the permutation cycles
+    DO
+       j = k3 + 1
+       nt = nt - ispan
+       ii = nt - 1 + 1
+       IF ( nt < 0 )  EXIT !-- Exit infinite loop
+       DO
+          DO
+             j = j - 1
+             IF ( perm(j) >= 0 )  EXIT
+          END DO
+          jj = jc
+          DO
+             kspan = jj
+             IF ( jj > maxfactor )  kspan = maxfactor
+             jj = jj - kspan
+             k = perm(j)
+             kk = jc * k + ii + jj
+             k1 = kk + kspan
+             k2 = 0
+             DO
+                k2 = k2 + 1
+                ctmp(k2) = array(k1)
+                k1 = k1 - 1
+                IF ( k1 == kk )  EXIT
+             END DO
+             DO
+                k1 = kk + kspan
+                k2 = k1 - jc * ( k + perm(k) )
+                k = - perm(k)
+                DO
+                   array(k1) = array(k2)
+                   k1 = k1 - 1
+                   k2 = k2 - 1
+                   IF ( k1 == kk )  EXIT
+                END DO
+                kk = k2
+                IF ( k == j )  EXIT
+             END DO
+             k1 = kk + kspan
+             k2 = 0
+             DO
+                k2 = k2 + 1
+                array(k1) = ctmp(k2)
+                k1 = k1 - 1
+                IF ( k1 == kk )  EXIT
+             END DO
+             IF ( jj == 0 )  EXIT
+          END DO
+          IF ( j == 1 )  EXIT
+       END DO
+    END DO
+
+ END SUBROUTINE permute
 
  END SUBROUTINE fftradix
Index: /palm/trunk/SOURCE/sor.f90
===================================================================
--- /palm/trunk/SOURCE/sor.f90	(revision 4590)
+++ /palm/trunk/SOURCE/sor.f90	(revision 4591)
@@ -1,33 +1,37 @@
 !> @file sor.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
-! use statement for exchange horiz added
-! 
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 4457 2020-03-11 14:20:43Z raasch
+! Use statement for exchange horiz added
+!
 ! 4360 2020-01-07 11:25:50Z suehring
 ! Corrected "Former revisions" section
-! 
+!
 ! 3655 2019-01-07 16:51:22Z knoop
 ! Rename variables in mesoscale-offline nesting mode
@@ -36,28 +40,51 @@
 ! Initial revision
 !
-!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Solve the Poisson-equation with the SOR-Red/Black-scheme.
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
  SUBROUTINE sor( d, ddzu, ddzw, p )
 
-    USE arrays_3d,                                                             &
-        ONLY:  rho_air, rho_air_zw
-
-    USE control_parameters,                                                    &
-        ONLY:  bc_dirichlet_l, bc_dirichlet_n, bc_dirichlet_r,                 &
-               bc_dirichlet_s, bc_lr_cyc, bc_ns_cyc, bc_radiation_l,           &
-               bc_radiation_n, bc_radiation_r, bc_radiation_s, ibc_p_b,        &
-               ibc_p_t, n_sor, omega_sor
-
-    USE exchange_horiz_mod,                                                    &
+    USE arrays_3d,                                                                                 &
+        ONLY:  rho_air,                                                                            &
+               rho_air_zw
+
+    USE control_parameters,                                                                        &
+        ONLY:  bc_dirichlet_l,                                                                     &
+               bc_dirichlet_n,                                                                     &
+               bc_dirichlet_r,                                                                     &
+               bc_dirichlet_s,                                                                     &
+               bc_lr_cyc,                                                                          &
+               bc_ns_cyc,                                                                          &
+               bc_radiation_l,                                                                     &
+               bc_radiation_n,                                                                     &
+               bc_radiation_r,                                                                     &
+               bc_radiation_s,                                                                     &
+               ibc_p_b,                                                                            &
+               ibc_p_t,                                                                            &
+               n_sor,                                                                              &
+               omega_sor
+
+    USE exchange_horiz_mod,                                                                        &
         ONLY:  exchange_horiz
 
-    USE grid_variables,                                                        &
-        ONLY:  ddx2, ddy2
-
-    USE indices,                                                               &
-        ONLY:  nbgp, nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nz, nzb, nzt
+    USE grid_variables,                                                                            &
+        ONLY:  ddx2,                                                                               &
+               ddy2
+
+    USE indices,                                                                                   &
+        ONLY:  nbgp,                                                                               &
+               nxl,                                                                                &
+               nxlg,                                                                               &
+               nxr,                                                                                &
+               nxrg,                                                                               &
+               nyn,                                                                                &
+               nyng,                                                                               &
+               nys,                                                                                &
+               nysg,                                                                               &
+               nz,                                                                                 &
+               nzb,                                                                                &
+               nzt
 
     USE kinds
@@ -65,22 +92,22 @@
     IMPLICIT NONE
 
-    INTEGER(iwp) ::  i              !<
-    INTEGER(iwp) ::  j              !<
-    INTEGER(iwp) ::  k              !<
-    INTEGER(iwp) ::  n              !<
-    INTEGER(iwp) ::  nxl1           !<
-    INTEGER(iwp) ::  nxl2           !<
-    INTEGER(iwp) ::  nys1           !<
-    INTEGER(iwp) ::  nys2           !<
-
-    REAL(wp)     ::  ddzu(1:nz+1)   !<
-    REAL(wp)     ::  ddzw(1:nzt+1)  !<
-
-    REAL(wp)     ::  d(nzb+1:nzt,nys:nyn,nxl:nxr)      !<
-    REAL(wp)     ::  p(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  !<
-
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f1         !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f2         !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f3         !<
+    INTEGER(iwp) ::  i     !<
+    INTEGER(iwp) ::  j     !<
+    INTEGER(iwp) ::  k     !<
+    INTEGER(iwp) ::  n     !<
+    INTEGER(iwp) ::  nxl1  !<
+    INTEGER(iwp) ::  nxl2  !<
+    INTEGER(iwp) ::  nys1  !<
+    INTEGER(iwp) ::  nys2  !<
+
+    REAL(wp) ::  ddzu(1:nz+1)   !<
+    REAL(wp) ::  ddzw(1:nzt+1)  !<
+
+    REAL(wp) ::  d(nzb+1:nzt,nys:nyn,nxl:nxr)      !<
+    REAL(wp) ::  p(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  !<
+
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f1  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f2  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  f3  !<
 
     ALLOCATE( f1(1:nz), f2(1:nz), f3(1:nz) )
@@ -118,11 +145,11 @@
           DO  j = nys2, nyn, 2
              DO  k = nzb+1, nzt
-                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (            &
-                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +   &
-                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +   &
-                           f2(k) * p(k+1,j,i)                              +   &
-                           f3(k) * p(k-1,j,i)                              -   &
-                           d(k,j,i)                                        -   &
-                           f1(k) * p(k,j,i)           )
+                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (                                        &
+                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +                       &
+                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +                       &
+                           f2(k) * p(k+1,j,i)                              +                       &
+                           f3(k) * p(k-1,j,i)                              -                       &
+                           d(k,j,i)                                        -                       &
+                           f1(k) * p(k,j,i)               )
              ENDDO
           ENDDO
@@ -132,11 +159,11 @@
           DO  j = nys1, nyn, 2
              DO  k = nzb+1, nzt
-                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (                    &
-                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +   &
-                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +   &
-                           f2(k) * p(k+1,j,i)                              +   &
-                           f3(k) * p(k-1,j,i)                              -   &
-                           d(k,j,i)                                        -   &
-                           f1(k) * p(k,j,i)           )
+                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (                                        &
+                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +                       &
+                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +                       &
+                           f2(k) * p(k+1,j,i)                              +                       &
+                           f3(k) * p(k-1,j,i)                              -                       &
+                           d(k,j,i)                                        -                       &
+                           f1(k) * p(k,j,i)               )
              ENDDO
           ENDDO
@@ -146,4 +173,5 @@
 !--    Exchange of boundary values for p.
        CALL exchange_horiz( p, nbgp )
+
 
 !
@@ -163,11 +191,11 @@
           DO  j = nys1, nyn, 2
              DO  k = nzb+1, nzt
-                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (            &
-                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +   &
-                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +   &
-                           f2(k) * p(k+1,j,i)                              +   &
-                           f3(k) * p(k-1,j,i)                              -   &
-                           d(k,j,i)                                        -   &
-                           f1(k) * p(k,j,i)           )
+                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (                                        &
+                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +                       &
+                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +                       &
+                           f2(k) * p(k+1,j,i)                              +                       &
+                           f3(k) * p(k-1,j,i)                              -                       &
+                           d(k,j,i)                                        -                       &
+                           f1(k) * p(k,j,i)               )
              ENDDO
           ENDDO
@@ -177,11 +205,11 @@
           DO  j = nys2, nyn, 2
              DO  k = nzb+1, nzt
-                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (            &
-                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +   &
-                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +   &
-                           f2(k) * p(k+1,j,i)                              +   &
-                           f3(k) * p(k-1,j,i)                              -   &
-                           d(k,j,i)                                        -   &
-                           f1(k) * p(k,j,i)           )
+                p(k,j,i) = p(k,j,i) + omega_sor / f1(k) * (                                        &
+                           rho_air(k) * ddx2 * ( p(k,j,i+1) + p(k,j,i-1) ) +                       &
+                           rho_air(k) * ddy2 * ( p(k,j+1,i) + p(k,j-1,i) ) +                       &
+                           f2(k) * p(k+1,j,i)                              +                       &
+                           f3(k) * p(k-1,j,i)                              -                       &
+                           d(k,j,i)                                        -                       &
+                           f1(k) * p(k,j,i)               )
              ENDDO
           ENDDO
@@ -195,7 +223,7 @@
 !--    Boundary conditions top/bottom.
 !--    Bottom boundary
-       IF ( ibc_p_b == 1 )  THEN       !       Neumann
+       IF ( ibc_p_b == 1 )  THEN       ! Neumann
           p(nzb,:,:) = p(nzb+1,:,:)
-       ELSE                            !       Dirichlet
+       ELSE                            ! Dirichlet
           p(nzb,:,:) = 0.0_wp
        ENDIF
@@ -203,7 +231,7 @@
 !
 !--    Top boundary
-       IF ( ibc_p_t == 1 )  THEN                 !  Neumann
+       IF ( ibc_p_t == 1 )  THEN       ! Neumann
           p(nzt+1,:,:) = p(nzt,:,:)
-       ELSE                      !  Dirichlet
+       ELSE                            ! Dirichlet
           p(nzt+1,:,:) = 0.0_wp
        ENDIF
Index: /palm/trunk/SOURCE/spectra_mod.f90
===================================================================
--- /palm/trunk/SOURCE/spectra_mod.f90	(revision 4590)
+++ /palm/trunk/SOURCE/spectra_mod.f90	(revision 4591)
@@ -1,36 +1,39 @@
 !> @file spectra_mod.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
-! bugfix: preprocessor directives rearranged for serial mode
-! 
+! File re-formatted to follow the PALM coding standard
+!
+! 4429 2020-02-27 15:24:30Z raasch
+! Bugfix: preprocessor directives rearranged for serial mode
+!
 ! 4360 2020-01-07 11:25:50Z suehring
 ! Corrected "Former revisions" section
-! 
+!
 ! 3805 2019-03-20 15:26:35Z raasch
-! unused variable removed
-! 
+! Unused variable removed
+!
 ! 3655 2019-01-07 16:51:22Z knoop
 ! Renamed output variables
@@ -39,13 +42,12 @@
 ! Initial revision
 !
-!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
-!> Calculate horizontal spectra along x and y. 
-!> ATTENTION: 1d-decomposition along y still needs improvement, because in that
-!>            case the gridpoint number along z still depends on the PE number
-!>            because transpose_xz has to be used (and possibly also
-!>            transpose_zyd needs modification).
-!------------------------------------------------------------------------------!
+!> Calculate horizontal spectra along x and y.
+!> ATTENTION: 1d-decomposition along y still needs improvement, because in that case the gridpoint
+!>            number along z still depends on the PE number because transpose_xz has to be used
+!>            (and possibly also transpose_zyd needs modification).
+!--------------------------------------------------------------------------------------------------!
  MODULE spectra_mod
 
@@ -54,12 +56,11 @@
     PRIVATE
 
-    CHARACTER (LEN=2),  DIMENSION(10) ::  spectra_direction = 'x'
-    CHARACTER (LEN=10), DIMENSION(10) ::  data_output_sp  = ' '
-
-    INTEGER(iwp) ::  average_count_sp = 0
-    INTEGER(iwp) ::  dosp_time_count = 0
-    INTEGER(iwp) ::  n_sp_x = 0, n_sp_y = 0
-
-    INTEGER(iwp) ::  comp_spectra_level(100) = 999999
+    CHARACTER (LEN=10), DIMENSION(10) ::  data_output_sp  = ' '    !<
+    CHARACTER (LEN=2),  DIMENSION(10) ::  spectra_direction = 'x'  !<
+
+    INTEGER(iwp) ::  average_count_sp = 0              !<
+    INTEGER(iwp) ::  comp_spectra_level(100) = 999999  !<
+    INTEGER(iwp) ::  dosp_time_count = 0               !<
+    INTEGER(iwp) ::  n_sp_x = 0, n_sp_y = 0            !<
 
     LOGICAL ::  calculate_spectra   = .FALSE.  !< internal switch that spectra are calculated
@@ -70,7 +71,8 @@
     REAL(wp) ::  skip_time_dosp = 9999999.9_wp         !< no output of spectra data before this interval has passed
 
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  var_d
-
-    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  spectrum_x, spectrum_y
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  var_d  !<
+
+    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  spectrum_x  !<
+    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  spectrum_y  !<
 
     SAVE
@@ -110,180 +112,201 @@
     END INTERFACE spectra_parin
 
-    PUBLIC average_count_sp, averaging_interval_sp, calc_spectra,              &
-           calculate_spectra, comp_spectra_level, data_output_sp,              &
-           dosp_time_count, dt_dosp, n_sp_x, n_sp_y,                           &
-           skip_time_dosp, spectra_check_parameters, spectra_direction,        &
-           spectra_header, spectra_init, spectra_parin, spectrum_x,            &
-           spectrum_y, var_d
+    PUBLIC average_count_sp,                                                                       &
+           averaging_interval_sp,                                                                  &
+           calc_spectra,                                                                           &
+           calculate_spectra,                                                                      &
+           comp_spectra_level,                                                                     &
+           data_output_sp,                                                                         &
+           dosp_time_count,                                                                        &
+           dt_dosp,                                                                                &
+           n_sp_x,                                                                                 &
+           n_sp_y,                                                                                 &
+           skip_time_dosp,                                                                         &
+           spectra_check_parameters,                                                               &
+           spectra_direction,                                                                      &
+           spectra_header,                                                                         &
+           spectra_init,                                                                           &
+           spectra_parin,                                                                          &
+           spectrum_x,                                                                             &
+           spectrum_y,                                                                             &
+           var_d
 
 
  CONTAINS
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Parin for &spectra_par for calculating spectra
-!------------------------------------------------------------------------------!
-    SUBROUTINE spectra_parin
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_data_output, message_string
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=80) ::  line  !< dummy string that contains the current  &
-                                    !< line of the parameter file
-
-       NAMELIST /spectra_par/  averaging_interval_sp, comp_spectra_level,      &
-                               data_output_sp, dt_dosp, skip_time_dosp,        &
-                               spectra_direction
-
-       NAMELIST /spectra_parameters/                                           &
-                               averaging_interval_sp, comp_spectra_level,      &
-                               data_output_sp, dt_dosp, skip_time_dosp,        &
-                               spectra_direction
-!
-!--    Position the namelist-file at the beginning (it was already opened in
-!--    parin), search for the namelist-group of the package and position the
-!--    file at this line.
-       line = ' '
-
-!
-!--    Try to find the spectra package
-       REWIND ( 11 )
-       line = ' '
-       DO WHILE ( INDEX( line, '&spectra_parameters' ) == 0 )
-          READ ( 11, '(A)', END=12 )  line
-       ENDDO
-       BACKSPACE ( 11 )
-
-!
-!--    Read namelist
-       READ ( 11, spectra_parameters, ERR = 10 )
-
-!
-!--    Default setting of dt_dosp here (instead of check_parameters), because
-!--    its current value is needed in init_pegrid
-       IF ( dt_dosp == 9999999.9_wp )  dt_dosp = dt_data_output
-
-!
-!--    Set general switch that spectra shall be calculated
-       calculate_spectra = .TRUE.
-
-       GOTO 14
-
- 10    BACKSPACE( 11 )
-       READ( 11 , '(A)') line
-       CALL parin_fail_message( 'spectra_parameters', line )
-!
-!--    Try to find the old namelist
- 12    REWIND ( 11 )
-       line = ' '
-       DO WHILE ( INDEX( line, '&spectra_par' ) == 0 )
-          READ ( 11, '(A)', END=14 )  line
-       ENDDO
-       BACKSPACE ( 11 )
-
-!
-!--    Read namelist
-       READ ( 11, spectra_par, ERR = 13, END = 14 )
-
-       
-       message_string = 'namelist spectra_par is deprecated and will be ' // &
-                     'removed in near future. Please use namelist ' //       &
-                     'spectra_parameters instead'
-       CALL message( 'spectra_parin', 'PA0487', 0, 1, 0, 6, 0 )
-!
-!--    Default setting of dt_dosp here (instead of check_parameters), because
-!--    its current value is needed in init_pegrid
-       IF ( dt_dosp == 9999999.9_wp )  dt_dosp = dt_data_output
-
-!
-!--    Set general switch that spectra shall be calculated
-       calculate_spectra = .TRUE.
-       
-       GOTO 14
-
- 13    BACKSPACE( 11 )
-       READ( 11 , '(A)') line
-       CALL parin_fail_message( 'spectra_par', line )
-       
-       
- 14    CONTINUE
-
-    END SUBROUTINE spectra_parin
-
-
-
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE spectra_parin
+
+    USE control_parameters,                                                                        &
+        ONLY:  dt_data_output,                                                                     &
+               message_string
+
+    IMPLICIT NONE
+
+    CHARACTER (LEN=80) ::  line  !< dummy string that contains the current line of the parameter file
+
+    NAMELIST /spectra_par/  averaging_interval_sp,                                                 &
+                            comp_spectra_level,                                                    &
+                            data_output_sp,                                                        &
+                            dt_dosp,                                                               &
+                            skip_time_dosp,                                                        &
+                            spectra_direction
+
+    NAMELIST /spectra_parameters/                                                                  &
+                            averaging_interval_sp,                                                 &
+                            comp_spectra_level,                                                    &
+                            data_output_sp,                                                        &
+                            dt_dosp,                                                               &
+                            skip_time_dosp,                                                        &
+                            spectra_direction
+!
+!-- Position the namelist-file at the beginning (it was already opened in parin), search for the
+!-- namelist-group of the package and position the file at this line.
+    line = ' '
+
+!
+!-- Try to find the spectra package
+    REWIND ( 11 )
+    line = ' '
+    DO WHILE ( INDEX( line, '&spectra_parameters' ) == 0 )
+       READ ( 11, '(A)', END=12 )  line
+    ENDDO
+    BACKSPACE ( 11 )
+
+!
+!-- Read namelist
+    READ ( 11, spectra_parameters, ERR = 10 )
+
+!
+!-- Default setting of dt_dosp here (instead of check_parameters), because its current value is
+!-- needed in init_pegrid
+    IF ( dt_dosp == 9999999.9_wp )  dt_dosp = dt_data_output
+
+!
+!-- Set general switch that spectra shall be calculated
+    calculate_spectra = .TRUE.
+
+    GOTO 14
+
+ 10 BACKSPACE( 11 )
+    READ( 11 , '(A)') line
+    CALL parin_fail_message( 'spectra_parameters', line )
+!
+!-- Try to find the old namelist
+ 12 REWIND ( 11 )
+    line = ' '
+    DO WHILE ( INDEX( line, '&spectra_par' ) == 0 )
+       READ ( 11, '(A)', END=14 )  line
+    ENDDO
+    BACKSPACE ( 11 )
+
+!
+!-- Read namelist
+    READ ( 11, spectra_par, ERR = 13, END = 14 )
+
+
+    message_string = 'namelist spectra_par is deprecated and will be removed in near future.' //   &
+                     ' Please use namelist spectra_parameters instead'
+    CALL message( 'spectra_parin', 'PA0487', 0, 1, 0, 6, 0 )
+!
+!-- Default setting of dt_dosp here (instead of check_parameters), because its current value is
+!-- needed in init_pegrid
+    IF ( dt_dosp == 9999999.9_wp )  dt_dosp = dt_data_output
+
+!
+!-- Set general switch that spectra shall be calculated
+    calculate_spectra = .TRUE.
+
+    GOTO 14
+
+ 13 BACKSPACE( 11 )
+    READ( 11 , '(A)') line
+    CALL parin_fail_message( 'spectra_par', line )
+
+
+ 14 CONTINUE
+
+ END SUBROUTINE spectra_parin
+
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Initialization of spectra related variables
-!------------------------------------------------------------------------------!
-    SUBROUTINE spectra_init
-
-       USE indices,                                                            &
-           ONLY:  nx, ny, nzb, nzt
-
-       IMPLICIT NONE
-
-       IF ( spectra_initialized )  RETURN
-
-       IF ( dt_dosp /= 9999999.9_wp )  THEN
-
-          IF ( .NOT. ALLOCATED( spectrum_x ) )  THEN
-             ALLOCATE( spectrum_x( 1:nx/2, 1:100, 1:10 ) )
-             spectrum_x = 0.0_wp
-          ENDIF
-
-          IF ( .NOT. ALLOCATED( spectrum_y ) )  THEN
-             ALLOCATE( spectrum_y( 1:ny/2, 1:100, 1:10 ) )
-             spectrum_y = 0.0_wp
-          ENDIF
-
-          ALLOCATE( var_d(nzb:nzt+1) )
-          var_d = 0.0_wp
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE spectra_init
+
+    USE indices,                                                                                   &
+        ONLY:  nx,                                                                                 &
+               ny,                                                                                 &
+               nzb,                                                                                &
+               nzt
+
+    IMPLICIT NONE
+
+    IF ( spectra_initialized )  RETURN
+
+    IF ( dt_dosp /= 9999999.9_wp )  THEN
+
+       IF ( .NOT. ALLOCATED( spectrum_x ) )  THEN
+          ALLOCATE( spectrum_x( 1:nx/2, 1:100, 1:10 ) )
+          spectrum_x = 0.0_wp
        ENDIF
 
-       spectra_initialized = .TRUE.
-
-    END SUBROUTINE spectra_init
-
-
-
-!------------------------------------------------------------------------------!
+       IF ( .NOT. ALLOCATED( spectrum_y ) )  THEN
+          ALLOCATE( spectrum_y( 1:ny/2, 1:100, 1:10 ) )
+          spectrum_y = 0.0_wp
+       ENDIF
+
+       ALLOCATE( var_d(nzb:nzt+1) )
+       var_d = 0.0_wp
+    ENDIF
+
+    spectra_initialized = .TRUE.
+
+ END SUBROUTINE spectra_init
+
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Check spectra related quantities
-!------------------------------------------------------------------------------!
-    SUBROUTINE spectra_check_parameters
-
-       USE control_parameters,                                                 &
-           ONLY:  averaging_interval, message_string, skip_time_data_output
-
-       IMPLICIT NONE
-
-!
-!--    Check the average interval
-       IF ( averaging_interval_sp == 9999999.9_wp )  THEN
-          averaging_interval_sp = averaging_interval
-       ENDIF
-
-       IF ( averaging_interval_sp > dt_dosp )  THEN
-          WRITE( message_string, * )  'averaging_interval_sp = ',              &
-                averaging_interval_sp, ' must be <= dt_dosp = ', dt_dosp
-          CALL message( 'spectra_check_parameters', 'PA0087', 1, 2, 0, 6, 0 )
-       ENDIF
-
-!
-!--    Set the default skip time interval for data output, if necessary
-       IF ( skip_time_dosp == 9999999.9_wp )                                   &
-                                          skip_time_dosp = skip_time_data_output
-
-    END SUBROUTINE spectra_check_parameters
-
-
-
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE spectra_check_parameters
+
+    USE control_parameters,                                                                        &
+        ONLY:  averaging_interval,                                                                 &
+               message_string,                                                                     &
+               skip_time_data_output
+
+    IMPLICIT NONE
+
+!
+!-- Check the average interval
+    IF ( averaging_interval_sp == 9999999.9_wp )  THEN
+       averaging_interval_sp = averaging_interval
+    ENDIF
+
+    IF ( averaging_interval_sp > dt_dosp )  THEN
+       WRITE( message_string, * )  'averaging_interval_sp = ', averaging_interval_sp,              &
+                                   ' must be <= dt_dosp = ', dt_dosp
+       CALL message( 'spectra_check_parameters', 'PA0087', 1, 2, 0, 6, 0 )
+    ENDIF
+
+!
+!-- Set the default skip time interval for data output, if necessary
+    IF ( skip_time_dosp == 9999999.9_wp )  skip_time_dosp = skip_time_data_output
+
+ END SUBROUTINE spectra_check_parameters
+
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
@@ -291,583 +314,614 @@
 !>
 !> @todo Output of netcdf data format and compression level
-!------------------------------------------------------------------------------!
-    SUBROUTINE spectra_header ( io )
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_averaging_input_pr
-
-!       USE netcdf_interface,                                                  &
-!           ONLY:  netcdf_data_format_string, netcdf_deflate
-
-       IMPLICIT NONE
-
-!       CHARACTER (LEN=40) ::  output_format       !< internal string
-
-       INTEGER(iwp) ::  i                         !< internal counter
-       INTEGER(iwp), INTENT(IN) ::  io            !< Unit of the output file
-
-!
-!--    Spectra output
-       IF ( dt_dosp /= 9999999.9_wp )  THEN
-          WRITE ( io, 1 )
-
-!          output_format = netcdf_data_format_string
-!          IF ( netcdf_deflate == 0 )  THEN
-!             WRITE ( io, 2 )  output_format
-!          ELSE
-!             WRITE ( io, 3 )  TRIM( output_format ), netcdf_deflate
-!          ENDIF
-          WRITE ( io, 2 )  'see profiles or other quantities'
-          WRITE ( io, 4 )  dt_dosp
-          IF ( skip_time_dosp /= 0.0_wp )  WRITE ( io, 5 )  skip_time_dosp
-          WRITE ( io, 6 )  ( data_output_sp(i), i = 1,10 ),     &
-                           ( spectra_direction(i), i = 1,10 ),  &
-                           ( comp_spectra_level(i), i = 1,100 ), &
-                           averaging_interval_sp, dt_averaging_input_pr
-       ENDIF
-
-     1 FORMAT ('    Spectra:')
-     2 FORMAT ('       Output format: ',A/)
-!     3 FORMAT ('       Output format: ',A, '   compressed with level: ',I1/)
-     4 FORMAT ('       Output every ',F7.1,' s'/)
-     5 FORMAT ('       No output during initial ',F8.2,' s')
-     6 FORMAT ('       Arrays:     ', 10(A5,',')/                         &
-               '       Directions: ', 10(A5,',')/                         &
-               '       height levels  k = ', 20(I3,',')/                  &
-               '                          ', 20(I3,',')/                  &
-               '                          ', 20(I3,',')/                  &
-               '                          ', 20(I3,',')/                  &
-               '                          ', 19(I3,','),I3,'.'/           &
-               '       Time averaged over ', F7.1, ' s,' /                &
-               '       Profiles for the time averaging are taken every ', &
-                    F6.1,' s')
-
-    END SUBROUTINE spectra_header
-
-
-
-    SUBROUTINE calc_spectra
-
-       USE arrays_3d,                                                          &
-           ONLY:  d
-#if defined( __parallel )
-       USE arrays_3d,                                                          &
-           ONLY:  tend
-#endif
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, message_string, psolver
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point
-
-       USE fft_xy,                                                             &
-           ONLY:  fft_init
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb, nzt
-
-       USE kinds
-
-       USE pegrid,                                                             &
-           ONLY:  myid
-#if defined( __parallel )
-       USE pegrid,                                                             &
-           ONLY:  pdims
-#endif
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  m  !<
-       INTEGER(iwp) ::  pr !<
-
-
-!
-!--    Check if user gave any levels for spectra to be calculated
-       IF ( comp_spectra_level(1) == 999999 )  RETURN
-
-       CALL cpu_log( log_point(30), 'calc_spectra', 'start' )
-
-!
-!--    Initialize spectra related quantities
-       CALL spectra_init
-
-!
-!--    Initialize ffts
-       CALL fft_init
-
-!
-!--    Reallocate array d in required size
-       IF ( psolver(1:9) == 'multigrid' )  THEN
-          DEALLOCATE( d )
-          ALLOCATE( d(nzb+1:nzt,nys:nyn,nxl:nxr) )
-       ENDIF
-
-       m = 1
-       DO WHILE ( data_output_sp(m) /= ' '  .AND.  m <= 10 )
-!
-!--       Transposition from z --> x  ( y --> x in case of a 1d-decomposition
-!--       along x)
-          IF ( INDEX( spectra_direction(m), 'x' ) /= 0 )  THEN
-
-!
-!--          Calculation of spectra works for cyclic boundary conditions only
-             IF ( .NOT. bc_lr_cyc )  THEN
-
-                message_string = 'non-cyclic lateral boundaries along x do'//  &
-                                 ' not &  allow calculation of spectra along x'
-                CALL message( 'calc_spectra', 'PA0160', 1, 2, 0, 6, 0 )
-             ENDIF
-
-             CALL preprocess_spectra( m, pr )
-
-#if defined( __parallel )
-             IF ( pdims(2) /= 1 )  THEN
-                CALL resort_for_zx( d, tend )
-                CALL transpose_zx( tend, d )
-             ELSE
-                CALL transpose_yxd( d, d )
-             ENDIF
-             CALL calc_spectra_x( d, m )
-#else
-             message_string = 'sorry, calculation of spectra in non paral' //  &
-                              'lel mode& is still not realized'
-             CALL message( 'calc_spectra', 'PA0161', 1, 2, 0, 6, 0 )
-#endif
-
-          ENDIF
-
-!
-!--       Transposition from z --> y (d is rearranged only in case of a
-!--       1d-decomposition along x)
-          IF ( INDEX( spectra_direction(m), 'y' ) /= 0 )  THEN
-
-!
-!--          Calculation of spectra works for cyclic boundary conditions only
-             IF ( .NOT. bc_ns_cyc )  THEN
-                IF ( myid == 0 )  THEN
-                   message_string = 'non-cyclic lateral boundaries along y' // &
-                                    ' do not & allow calculation of spectra' //&
-                                    ' along y'
-                   CALL message( 'calc_spectra', 'PA0162', 1, 2, 0, 6, 0 )
-                ENDIF
-                CALL local_stop
-             ENDIF
-
-             CALL preprocess_spectra( m, pr )
-
-#if defined( __parallel )
-             CALL transpose_zyd( d, d )
-             CALL calc_spectra_y( d, m )
-#else
-             message_string = 'sorry, calculation of spectra in non paral' //  &
-                              'lel mode& is still not realized'
-             CALL message( 'calc_spectra', 'PA0161', 1, 2, 0, 6, 0 )
-#endif
-
-          ENDIF
-
-!
-!--       Increase counter for next spectrum
-          m = m + 1
-          
-       ENDDO
-
-!
-!--    Increase counter for averaging process in routine plot_spectra
-       average_count_sp = average_count_sp + 1
-
-       CALL cpu_log( log_point(30), 'calc_spectra', 'stop' )
-
-    END SUBROUTINE calc_spectra
-
-
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE spectra_header ( io )
+
+    USE control_parameters,                                                                        &
+        ONLY:  dt_averaging_input_pr
+
+!    USE netcdf_interface,                                                                          &
+!        ONLY:  netcdf_data_format_string,                                                          &
+!               netcdf_deflate
+
+    IMPLICIT NONE
+
+!    CHARACTER (LEN=40) ::  output_format !< internal string
+
+    INTEGER(iwp) ::  i               !< internal counter
+    INTEGER(iwp), INTENT(IN) ::  io  !< unit of the output file
+
+!
+!-- Spectra output
+    IF ( dt_dosp /= 9999999.9_wp )  THEN
+       WRITE ( io, 1 )
+
+!       output_format = netcdf_data_format_string
+!       IF ( netcdf_deflate == 0 )  THEN
+!          WRITE ( io, 2 )  output_format
+!       ELSE
+!          WRITE ( io, 3 )  TRIM( output_format ), netcdf_deflate
+!       ENDIF
+       WRITE ( io, 2 )  'see profiles or other quantities'
+       WRITE ( io, 4 )  dt_dosp
+       IF ( skip_time_dosp /= 0.0_wp )  WRITE ( io, 5 )  skip_time_dosp
+       WRITE ( io, 6 )  ( data_output_sp(i), i = 1,10 ),                                           &
+                        ( spectra_direction(i), i = 1,10 ),                                        &
+                        ( comp_spectra_level(i), i = 1,100 ),                                      &
+                        averaging_interval_sp, dt_averaging_input_pr
+    ENDIF
+
+  1 FORMAT ('    Spectra:')
+  2 FORMAT ('       Output format: ',A/)
+!  3 FORMAT ('       Output format: ',A, '   compressed with level: ',I1/)
+  4 FORMAT ('       Output every ',F7.1,' s'/)
+  5 FORMAT ('       No output during initial ',F8.2,' s')
+  6 FORMAT ('       Arrays:     ', 10(A5,',')/                                                     &
+            '       Directions: ', 10(A5,',')/                                                     &
+            '       height levels  k = ', 20(I3,',')/                                              &
+            '                          ', 20(I3,',')/                                              &
+            '                          ', 20(I3,',')/                                              &
+            '                          ', 20(I3,',')/                                              &
+            '                          ', 19(I3,','),I3,'.'/                                       &
+            '       Time averaged over ', F7.1, ' s,' /                                            &
+            '       Profiles for the time averaging are taken every ',                             &
+                 F6.1,' s')
+
+ END SUBROUTINE spectra_header
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE preprocess_spectra( m, pr )
-
-       USE arrays_3d,                                                          &
-           ONLY:  d, pt, q, s, u, v, w
-
-       USE indices,                                                            &
-           ONLY:  ngp_2dh, nxl, nxr, nyn, nys, nzb, nzt
-
-       USE kinds
-
-#if defined( __parallel )
-#if !defined( __mpifh )
-       USE MPI
-#endif
-
-       USE pegrid,                                                             &
-           ONLY:  collective_wait, comm2d, ierr
-#endif
-
-       USE statistics,                                                         &
-           ONLY:  hom
-
-
-       IMPLICIT NONE
-
-#if defined( __parallel )
-#if defined( __mpifh )
-       INCLUDE "mpif.h"
-#endif
-#endif
-
-       INTEGER(iwp) :: i  !<
-       INTEGER(iwp) :: j  !<
-       INTEGER(iwp) :: k  !<
-       INTEGER(iwp) :: m  !<
-       INTEGER(iwp) :: pr !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) :: var_d_l
-
-       SELECT CASE ( TRIM( data_output_sp(m) ) )
-          
-       CASE ( 'u' )
-          pr = 1
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = u(nzb+1:nzt,nys:nyn,nxl:nxr)
-       
-       CASE ( 'v' )
-          pr = 2
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = v(nzb+1:nzt,nys:nyn,nxl:nxr)
-       
-       CASE ( 'w' )
-          pr = 3
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = w(nzb+1:nzt,nys:nyn,nxl:nxr)
-       
-       CASE ( 'theta' )
-          pr = 4
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = pt(nzb+1:nzt,nys:nyn,nxl:nxr)
-       
-       CASE ( 'q' )
-          pr = 41
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = q(nzb+1:nzt,nys:nyn,nxl:nxr)
-          
-       CASE ( 's' )
-          pr = 117
-          d(nzb+1:nzt,nys:nyn,nxl:nxr) = s(nzb+1:nzt,nys:nyn,nxl:nxr)
-       
-       CASE DEFAULT
-!
-!--       The DEFAULT case is reached either if the parameter data_output_sp(m)
-!--       contains a wrong character string or if the user has coded a special
-!--       case in the user interface. There, the subroutine user_spectra
-!--       checks which of these two conditions applies.
-          CALL user_spectra( 'preprocess', m, pr )
-          
-       END SELECT
-
-!
-!--    Subtract horizontal mean from the array, for which spectra have to be
-!--    calculated. Moreover, calculate variance of the respective quantitiy, 
-!--    later used for normalizing spectra output. 
-       var_d_l(:) = 0.0_wp
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                d(k,j,i)   = d(k,j,i) - hom(k,1,pr,0)
-                var_d_l(k) = var_d_l(k) + d(k,j,i) * d(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-!
-!--    Compute total variance from local variances
-       var_d(:) = 0.0_wp
-#if defined( __parallel ) 
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLREDUCE( var_d_l(0), var_d(0), nzt+1-nzb, MPI_REAL, MPI_SUM, &
-                           comm2d, ierr )
+!--------------------------------------------------------------------------------------------------!
+
+ SUBROUTINE calc_spectra
+
+    USE arrays_3d,                                                                                 &
+        ONLY:  d
+#if defined( __parallel )
+    USE arrays_3d,                                                                                 &
+        ONLY:  tend
+#endif
+
+    USE control_parameters,                                                                        &
+        ONLY:  bc_lr_cyc,                                                                          &
+               bc_ns_cyc,                                                                          &
+               message_string,                                                                     &
+               psolver
+
+    USE cpulog,                                                                                    &
+        ONLY:  cpu_log,                                                                            &
+               log_point
+
+    USE fft_xy,                                                                                    &
+        ONLY:  fft_init
+
+    USE indices,                                                                                   &
+        ONLY:  nxl,                                                                                &
+               nxr,                                                                                &
+               nyn,                                                                                &
+               nys,                                                                                &
+               nzb,                                                                                &
+               nzt
+
+    USE kinds
+
+    USE pegrid,                                                                                    &
+        ONLY:  myid
+#if defined( __parallel )
+    USE pegrid,                                                                                    &
+        ONLY:  pdims
+#endif
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  m   !<
+    INTEGER(iwp) ::  pr  !<
+
+
+!
+!-- Check if user gave any levels for spectra to be calculated
+    IF ( comp_spectra_level(1) == 999999 )  RETURN
+
+    CALL cpu_log( log_point(30), 'calc_spectra', 'start' )
+
+!
+!-- Initialize spectra related quantities
+    CALL spectra_init
+
+!
+!-- Initialize ffts
+    CALL fft_init
+
+!
+!-- Reallocate array d in required size
+    IF ( psolver(1:9) == 'multigrid' )  THEN
+       DEALLOCATE( d )
+       ALLOCATE( d(nzb+1:nzt,nys:nyn,nxl:nxr) )
+    ENDIF
+
+    m = 1
+    DO WHILE ( data_output_sp(m) /= ' '  .AND.  m <= 10 )
+!
+!--    Transposition from z --> x  ( y --> x in case of a 1d-decomposition along x)
+       IF ( INDEX( spectra_direction(m), 'x' ) /= 0 )  THEN
+
+!
+!--       Calculation of spectra works for cyclic boundary conditions only
+          IF ( .NOT. bc_lr_cyc )  THEN
+
+             message_string = 'non-cyclic lateral boundaries along x do' //                        &
+                              ' not &  allow calculation of spectra along x'
+             CALL message( 'calc_spectra', 'PA0160', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          CALL preprocess_spectra( m, pr )
+
+#if defined( __parallel )
+          IF ( pdims(2) /= 1 )  THEN
+             CALL resort_for_zx( d, tend )
+             CALL transpose_zx( tend, d )
+          ELSE
+             CALL transpose_yxd( d, d )
+          ENDIF
+          CALL calc_spectra_x( d, m )
 #else
-       var_d(:) = var_d_l(:)
-#endif
-       var_d(:) = var_d(:) / ngp_2dh(0)
-
-    END SUBROUTINE preprocess_spectra
-
-
-!------------------------------------------------------------------------------!
+          message_string = 'sorry, calculation of spectra in non parallel mode& is still not ' //  &
+                           'realized'
+          CALL message( 'calc_spectra', 'PA0161', 1, 2, 0, 6, 0 )
+#endif
+
+       ENDIF
+
+!
+!--    Transposition from z --> y (d is rearranged only in case of a 1d-decomposition along x)
+       IF ( INDEX( spectra_direction(m), 'y' ) /= 0 )  THEN
+
+!
+!--       Calculation of spectra works for cyclic boundary conditions only
+          IF ( .NOT. bc_ns_cyc )  THEN
+             IF ( myid == 0 )  THEN
+                message_string = 'non-cyclic lateral boundaries along y' //                        &
+                                 ' do not & allow calculation of spectra along y'
+                CALL message( 'calc_spectra', 'PA0162', 1, 2, 0, 6, 0 )
+             ENDIF
+             CALL local_stop
+          ENDIF
+
+          CALL preprocess_spectra( m, pr )
+
+#if defined( __parallel )
+          CALL transpose_zyd( d, d )
+          CALL calc_spectra_y( d, m )
+#else
+          message_string = 'sorry, calculation of spectra in non parallel mode& is still not ' //  &
+                           'realized'
+          CALL message( 'calc_spectra', 'PA0161', 1, 2, 0, 6, 0 )
+#endif
+
+       ENDIF
+
+!
+!--    Increase counter for next spectrum
+       m = m + 1
+
+    ENDDO
+
+!
+!-- Increase counter for averaging process in routine plot_spectra
+    average_count_sp = average_count_sp + 1
+
+    CALL cpu_log( log_point(30), 'calc_spectra', 'stop' )
+
+ END SUBROUTINE calc_spectra
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-#if defined( __parallel )
-    SUBROUTINE calc_spectra_x( ddd, m )
-
-       USE fft_xy,                                                             &
-           ONLY:  fft_x_1d
-
-       USE grid_variables,                                                     &
-           ONLY:  dx
-
-       USE indices,                                                            &
-           ONLY:  nx, ny
-
-       USE kinds
-
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE preprocess_spectra( m, pr )
+
+    USE arrays_3d,                                                                                 &
+        ONLY:  d,                                                                                  &
+               pt,                                                                                 &
+               q,                                                                                  &
+               s,                                                                                  &
+               u,                                                                                  &
+               v,                                                                                  &
+               w
+
+    USE indices,                                                                                   &
+        ONLY:  ngp_2dh,                                                                            &
+               nxl,                                                                                &
+               nxr,                                                                                &
+               nyn,                                                                                &
+               nys,                                                                                &
+               nzb,                                                                                &
+               nzt
+
+    USE kinds
+
+#if defined( __parallel )
 #if !defined( __mpifh )
-       USE MPI
-#endif
-
-       USE pegrid,                                                             &
-           ONLY:  comm2d, ierr, myid
-
-       USE transpose_indices,                                                  &
-           ONLY:  nyn_x, nys_x, nzb_x, nzt_x
-
-
-       IMPLICIT NONE
-
+    USE MPI
+#endif
+
+    USE pegrid,                                                                                    &
+        ONLY:  collective_wait,                                                                    &
+               comm2d,                                                                             &
+               ierr
+#endif
+
+    USE statistics,                                                                                &
+        ONLY:  hom
+
+
+    IMPLICIT NONE
+
+#if defined( __parallel )
 #if defined( __mpifh )
-       INCLUDE "mpif.h"
-#endif
-
-       INTEGER(iwp) ::  i         !<
-       INTEGER(iwp) ::  j         !<
-       INTEGER(iwp) ::  k         !<
-       INTEGER(iwp) ::  m         !<
-       INTEGER(iwp) ::  n         !<
-
-       REAL(wp) ::  exponent     !<
-       REAL(wp) ::  sum_spec_dum !< wavenumber-integrated spectrum
-    
-       REAL(wp), DIMENSION(0:nx) ::  work !<
-    
-       REAL(wp), DIMENSION(0:nx/2) ::  sums_spectra_l !<
-    
-       REAL(wp), DIMENSION(0:nx/2,100) ::  sums_spectra !<
-    
-       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::  ddd !<
-
-!
-!--    Exponent for geometric average
-       exponent = 1.0_wp / ( ny + 1.0_wp )
-
-!
-!--    Loop over all levels defined by the user
-       n = 1
-       DO WHILE ( comp_spectra_level(n) /= 999999  .AND.  n <= 100 )
-
-          k = comp_spectra_level(n)
-
-!
-!--       Calculate FFT only if the corresponding level is situated on this PE
-          IF ( k >= nzb_x  .AND.  k <= nzt_x )  THEN
-          
-             DO  j = nys_x, nyn_x
-
-                work = ddd(0:nx,j,k)
-                CALL fft_x_1d( work, 'forward' )
-
-                ddd(0,j,k) = dx * work(0)**2
-                DO  i = 1, nx/2
-                   ddd(i,j,k) = dx * ( work(i)**2 + work(nx+1-i)**2 )
-                ENDDO
-
-             ENDDO
-
-!
-!--          Local sum and geometric average of these spectra
-!--          (WARNING: no global sum should be performed, because floating
-!--          point overflow may occur)
-             DO  i = 0, nx/2
-
-                sums_spectra_l(i) = 1.0_wp
-                DO  j = nys_x, nyn_x
-                   sums_spectra_l(i) = sums_spectra_l(i) * ddd(i,j,k)**exponent
-                ENDDO
-
-             ENDDO
-          
-          ELSE
-
-             sums_spectra_l = 1.0_wp
-
-          ENDIF
-
-!
-!--       Global sum of spectra on PE0 (from where they are written on file)
-          sums_spectra(:,n) = 0.0_wp
-#if defined( __parallel )   
-          CALL MPI_BARRIER( comm2d, ierr )  ! Necessary?
-          CALL MPI_REDUCE( sums_spectra_l(0), sums_spectra(0,n), nx/2+1,       &
-                           MPI_REAL, MPI_PROD, 0, comm2d, ierr )
+    INCLUDE "mpif.h"
+#endif
+#endif
+
+    INTEGER(iwp) ::  i   !<
+    INTEGER(iwp) ::  j   !<
+    INTEGER(iwp) ::  k   !<
+    INTEGER(iwp) ::  m   !<
+    INTEGER(iwp) ::  pr  !<
+
+    REAL(wp), DIMENSION(nzb:nzt+1) ::  var_d_l  !<
+
+    SELECT CASE ( TRIM( data_output_sp(m) ) )
+
+    CASE ( 'u' )
+       pr = 1
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = u(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE ( 'v' )
+       pr = 2
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = v(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE ( 'w' )
+       pr = 3
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = w(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE ( 'theta' )
+       pr = 4
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = pt(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE ( 'q' )
+       pr = 41
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = q(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE ( 's' )
+       pr = 117
+       d(nzb+1:nzt,nys:nyn,nxl:nxr) = s(nzb+1:nzt,nys:nyn,nxl:nxr)
+
+    CASE DEFAULT
+!
+!--    The DEFAULT case is reached either if the parameter data_output_sp(m) contains a wrong
+!--    character string or if the user has coded a special case in the user interface. There, the
+!--    subroutine user_spectra checks which of these two conditions applies.
+       CALL user_spectra( 'preprocess', m, pr )
+
+    END SELECT
+
+!
+!-- Subtract horizontal mean from the array, for which spectra have to be calculated. Moreover,
+!-- calculate variance of the respective quantitiy, later used for normalizing spectra output.
+    var_d_l(:) = 0.0_wp
+    DO  i = nxl, nxr
+       DO  j = nys, nyn
+          DO  k = nzb+1, nzt
+             d(k,j,i)   = d(k,j,i) - hom(k,1,pr,0)
+             var_d_l(k) = var_d_l(k) + d(k,j,i) * d(k,j,i)
+          ENDDO
+       ENDDO
+    ENDDO
+!
+!-- Compute total variance from local variances
+    var_d(:) = 0.0_wp
+#if defined( __parallel )
+    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+    CALL MPI_ALLREDUCE( var_d_l(0), var_d(0), nzt+1-nzb, MPI_REAL, MPI_SUM, comm2d, ierr )
 #else
-          sums_spectra(:,n) = sums_spectra_l
-#endif
-!
-!--       Normalize spectra by variance
-          sum_spec_dum = SUM( sums_spectra(1:nx/2,n) )
-
-          IF ( sum_spec_dum /= 0.0_wp )  THEN
-             sums_spectra(1:nx/2,n) = sums_spectra(1:nx/2,n) *                 &
-                                      var_d(k) / sum_spec_dum
-          ENDIF
-          n = n + 1
-
-       ENDDO
-       n = n - 1
-
-       IF ( myid == 0 )  THEN
-!
-!--       Sum of spectra for later averaging (see routine data_output_spectra)
-          DO  i = 1, nx/2
-             DO k = 1, n
-                spectrum_x(i,k,m) = spectrum_x(i,k,m) + sums_spectra(i,k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-!
-!--    n_sp_x is needed by data_output_spectra_x
-       n_sp_x = n
-
-    END SUBROUTINE calc_spectra_x
-#endif
-
-
-!------------------------------------------------------------------------------!
+    var_d(:) = var_d_l(:)
+#endif
+    var_d(:) = var_d(:) / ngp_2dh(0)
+
+ END SUBROUTINE preprocess_spectra
+
+
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-#if defined( __parallel )
-    SUBROUTINE calc_spectra_y( ddd, m )
-
-       USE fft_xy,                                                             &
-           ONLY:  fft_y_1d
-
-       USE grid_variables,                                                     &
-           ONLY:  dy
-
-       USE indices,                                                            &
-           ONLY:  nx, ny
-
-       USE kinds
+!--------------------------------------------------------------------------------------------------!
+#if defined( __parallel )
+ SUBROUTINE calc_spectra_x( ddd, m )
+
+    USE fft_xy,                                                                                    &
+        ONLY:  fft_x_1d
+
+    USE grid_variables,                                                                            &
+        ONLY:  dx
+
+    USE indices,                                                                                   &
+        ONLY:  nx,                                                                                 &
+               ny
+
+    USE kinds
 
 #if !defined( __mpifh )
-       USE MPI
-#endif
-
-       USE pegrid,                                                             &
-           ONLY:  comm2d, ierr, myid
-
-       USE transpose_indices,                                                  &
-           ONLY:  nxl_yd, nxr_yd, nzb_yd, nzt_yd
-
-
-       IMPLICIT NONE
+    USE MPI
+#endif
+
+    USE pegrid,                                                                                    &
+        ONLY:  comm2d,                                                                             &
+               ierr,                                                                               &
+               myid
+
+    USE transpose_indices,                                                                         &
+        ONLY:  nyn_x,                                                                              &
+               nys_x,                                                                              &
+               nzb_x,                                                                              &
+               nzt_x
+
+
+    IMPLICIT NONE
 
 #if defined( __mpifh )
-       INCLUDE "mpif.h"
-#endif
-
-       INTEGER(iwp) ::  i         !<
-       INTEGER(iwp) ::  j         !<
-       INTEGER(iwp) ::  k         !<
-       INTEGER(iwp) ::  m         !<
-       INTEGER(iwp) ::  n         !<
-
-       REAL(wp) ::  exponent !<
-       REAL(wp) ::  sum_spec_dum !< wavenumber-integrated spectrum
-    
-       REAL(wp), DIMENSION(0:ny) ::  work !<
-    
-       REAL(wp), DIMENSION(0:ny/2) ::  sums_spectra_l !<
-    
-       REAL(wp), DIMENSION(0:ny/2,100) ::  sums_spectra !<
-    
-       REAL(wp), DIMENSION(0:ny,nxl_yd:nxr_yd,nzb_yd:nzt_yd) :: ddd !<
-
-
-!
-!--    Exponent for geometric average
-       exponent = 1.0_wp / ( nx + 1.0_wp )
-
-!
-!--    Loop over all levels defined by the user
-       n = 1
-       DO WHILE ( comp_spectra_level(n) /= 999999  .AND.  n <= 100 )
-
-          k = comp_spectra_level(n)
-
-!
-!--       Calculate FFT only if the corresponding level is situated on this PE
-          IF ( k >= nzb_yd  .AND.  k <= nzt_yd )  THEN
-          
+    INCLUDE "mpif.h"
+#endif
+
+    INTEGER(iwp) ::  i  !<
+    INTEGER(iwp) ::  j  !<
+    INTEGER(iwp) ::  k  !<
+    INTEGER(iwp) ::  m  !<
+    INTEGER(iwp) ::  n  !<
+
+    REAL(wp) ::  exponent      !<
+    REAL(wp) ::  sum_spec_dum  !< wavenumber-integrated spectrum
+
+    REAL(wp), DIMENSION(0:nx) ::  work  !<
+
+    REAL(wp), DIMENSION(0:nx/2) ::  sums_spectra_l  !<
+
+    REAL(wp), DIMENSION(0:nx/2,100) ::  sums_spectra  !<
+
+    REAL(wp), DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::  ddd  !<
+
+!
+!-- Exponent for geometric average
+    exponent = 1.0_wp / ( ny + 1.0_wp )
+
+!
+!-- Loop over all levels defined by the user
+    n = 1
+    DO WHILE ( comp_spectra_level(n) /= 999999  .AND.  n <= 100 )
+
+       k = comp_spectra_level(n)
+
+!
+!--    Calculate FFT only if the corresponding level is situated on this PE
+       IF ( k >= nzb_x  .AND.  k <= nzt_x )  THEN
+
+          DO  j = nys_x, nyn_x
+
+             work = ddd(0:nx,j,k)
+             CALL fft_x_1d( work, 'forward' )
+
+             ddd(0,j,k) = dx * work(0)**2
+             DO  i = 1, nx/2
+                ddd(i,j,k) = dx * ( work(i)**2 + work(nx+1-i)**2 )
+             ENDDO
+
+          ENDDO
+
+!
+!--       Local sum and geometric average of these spectra (WARNING: no global sum should be
+!--       performed, because floating point overflow may occur)
+          DO  i = 0, nx/2
+
+             sums_spectra_l(i) = 1.0_wp
+             DO  j = nys_x, nyn_x
+                sums_spectra_l(i) = sums_spectra_l(i) * ddd(i,j,k)**exponent
+             ENDDO
+
+          ENDDO
+
+       ELSE
+
+          sums_spectra_l = 1.0_wp
+
+       ENDIF
+
+!
+!--    Global sum of spectra on PE0 (from where they are written on file)
+       sums_spectra(:,n) = 0.0_wp
+#if defined( __parallel )
+       CALL MPI_BARRIER( comm2d, ierr )  ! Necessary?
+       CALL MPI_REDUCE( sums_spectra_l(0), sums_spectra(0,n), nx/2+1, MPI_REAL, MPI_PROD, 0,       &
+                        comm2d, ierr )
+#else
+       sums_spectra(:,n) = sums_spectra_l
+#endif
+!
+!--    Normalize spectra by variance
+       sum_spec_dum = SUM( sums_spectra(1:nx/2,n) )
+
+       IF ( sum_spec_dum /= 0.0_wp )  THEN
+          sums_spectra(1:nx/2,n) = sums_spectra(1:nx/2,n) * var_d(k) / sum_spec_dum
+       ENDIF
+       n = n + 1
+
+    ENDDO
+    n = n - 1
+
+    IF ( myid == 0 )  THEN
+!
+!--    Sum of spectra for later averaging (see routine data_output_spectra)
+       DO  i = 1, nx/2
+          DO k = 1, n
+             spectrum_x(i,k,m) = spectrum_x(i,k,m) + sums_spectra(i,k)
+          ENDDO
+       ENDDO
+
+    ENDIF
+!
+!-- n_sp_x is needed by data_output_spectra_x
+    n_sp_x = n
+
+ END SUBROUTINE calc_spectra_x
+#endif
+
+
+!--------------------------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!--------------------------------------------------------------------------------------------------!
+#if defined( __parallel )
+ SUBROUTINE calc_spectra_y( ddd, m )
+
+    USE fft_xy,                                                                                    &
+        ONLY:  fft_y_1d
+
+    USE grid_variables,                                                                            &
+        ONLY:  dy
+
+    USE indices,                                                                                   &
+        ONLY:  nx,                                                                                 &
+               ny
+
+    USE kinds
+
+#if !defined( __mpifh )
+    USE MPI
+#endif
+
+    USE pegrid,                                                                                    &
+        ONLY:  comm2d,                                                                             &
+               ierr,                                                                               &
+               myid
+
+    USE transpose_indices,                                                                         &
+        ONLY:  nxl_yd,                                                                             &
+               nxr_yd,                                                                             &
+               nzb_yd,                                                                             &
+               nzt_yd
+
+
+    IMPLICIT NONE
+
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#endif
+
+    INTEGER(iwp) ::  i  !<
+    INTEGER(iwp) ::  j  !<
+    INTEGER(iwp) ::  k  !<
+    INTEGER(iwp) ::  m  !<
+    INTEGER(iwp) ::  n  !<
+
+    REAL(wp) ::  exponent  !<
+    REAL(wp) ::  sum_spec_dum  !< wavenumber-integrated spectrum
+
+    REAL(wp), DIMENSION(0:ny) ::  work  !<
+
+    REAL(wp), DIMENSION(0:ny/2) ::  sums_spectra_l  !<
+
+    REAL(wp), DIMENSION(0:ny/2,100) ::  sums_spectra  !<
+
+    REAL(wp), DIMENSION(0:ny,nxl_yd:nxr_yd,nzb_yd:nzt_yd) :: ddd  !<
+
+
+!
+!-- Exponent for geometric average
+    exponent = 1.0_wp / ( nx + 1.0_wp )
+
+!
+!-- Loop over all levels defined by the user
+    n = 1
+    DO WHILE ( comp_spectra_level(n) /= 999999  .AND.  n <= 100 )
+
+       k = comp_spectra_level(n)
+
+!
+!--    Calculate FFT only if the corresponding level is situated on this PE
+       IF ( k >= nzb_yd  .AND.  k <= nzt_yd )  THEN
+
+          DO  i = nxl_yd, nxr_yd
+
+             work = ddd(0:ny,i,k)
+             CALL fft_y_1d( work, 'forward' )
+
+             ddd(0,i,k) = dy * work(0)**2
+             DO  j = 1, ny/2
+                ddd(j,i,k) = dy * ( work(j)**2 + work(ny+1-j)**2 )
+             ENDDO
+
+          ENDDO
+
+!
+!--       Local sum and geometric average of these spectra (WARNING: no global sum should be
+!--       performed, because floating point overflow may occur)
+          DO  j = 0, ny/2
+
+             sums_spectra_l(j) = 1.0_wp
              DO  i = nxl_yd, nxr_yd
-
-                work = ddd(0:ny,i,k)
-                CALL fft_y_1d( work, 'forward' )
-
-                ddd(0,i,k) = dy * work(0)**2
-                DO  j = 1, ny/2
-                   ddd(j,i,k) = dy * ( work(j)**2 + work(ny+1-j)**2 )
-                ENDDO
-
+                sums_spectra_l(j) = sums_spectra_l(j) * ddd(j,i,k)**exponent
              ENDDO
 
-!
-!--          Local sum and geometric average of these spectra
-!--          (WARNING: no global sum should be performed, because floating
-!--          point overflow may occur)
-             DO  j = 0, ny/2
-
-                sums_spectra_l(j) = 1.0_wp
-                DO  i = nxl_yd, nxr_yd
-                   sums_spectra_l(j) = sums_spectra_l(j) * ddd(j,i,k)**exponent
-                ENDDO
-
-             ENDDO
-          
-          ELSE
-
-             sums_spectra_l = 1.0_wp
-
-          ENDIF
-
-!
-!--       Global sum of spectra on PE0 (from where they are written on file)
-          sums_spectra(:,n) = 0.0_wp
-#if defined( __parallel )   
-          CALL MPI_BARRIER( comm2d, ierr )  ! Necessary?
-          CALL MPI_REDUCE( sums_spectra_l(0), sums_spectra(0,n), ny/2+1,       &
-                           MPI_REAL, MPI_PROD, 0, comm2d, ierr )
+          ENDDO
+
+       ELSE
+
+          sums_spectra_l = 1.0_wp
+
+       ENDIF
+
+!
+!--    Global sum of spectra on PE0 (from where they are written on file)
+       sums_spectra(:,n) = 0.0_wp
+#if defined( __parallel )
+       CALL MPI_BARRIER( comm2d, ierr )  ! Necessary?
+       CALL MPI_REDUCE( sums_spectra_l(0), sums_spectra(0,n), ny/2+1, MPI_REAL, MPI_PROD, 0,       &
+                        comm2d, ierr )
 #else
-          sums_spectra(:,n) = sums_spectra_l
-#endif
-!
-!--       Normalize spectra by variance
-          sum_spec_dum = SUM( sums_spectra(1:ny/2,n) )
-          IF ( sum_spec_dum /= 0.0_wp )  THEN
-             sums_spectra(1:ny/2,n) = sums_spectra(1:ny/2,n) *                 &
-                                      var_d(k) / sum_spec_dum
-          ENDIF
-          n = n + 1
-
+       sums_spectra(:,n) = sums_spectra_l
+#endif
+!
+!--    Normalize spectra by variance
+       sum_spec_dum = SUM( sums_spectra(1:ny/2,n) )
+       IF ( sum_spec_dum /= 0.0_wp )  THEN
+          sums_spectra(1:ny/2,n) = sums_spectra(1:ny/2,n) * var_d(k) / sum_spec_dum
+       ENDIF
+       n = n + 1
+
+    ENDDO
+    n = n - 1
+
+
+    IF ( myid == 0 )  THEN
+!
+!--    Sum of spectra for later averaging (see routine data_output_spectra)
+       DO  j = 1, ny/2
+          DO k = 1, n
+             spectrum_y(j,k,m) = spectrum_y(j,k,m) + sums_spectra(j,k)
+          ENDDO
        ENDDO
-       n = n - 1
-
-
-       IF ( myid == 0 )  THEN
-!
-!--       Sum of spectra for later averaging (see routine data_output_spectra)
-          DO  j = 1, ny/2
-             DO k = 1, n
-                spectrum_y(j,k,m) = spectrum_y(j,k,m) + sums_spectra(j,k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    n_sp_y is needed by data_output_spectra_y
-       n_sp_y = n
-
-    END SUBROUTINE calc_spectra_y
+
+    ENDIF
+
+!
+!-- n_sp_y is needed by data_output_spectra_y
+    n_sp_y = n
+
+ END SUBROUTINE calc_spectra_y
 #endif
 
Index: /palm/trunk/SOURCE/subsidence_mod.f90
===================================================================
--- /palm/trunk/SOURCE/subsidence_mod.f90	(revision 4590)
+++ /palm/trunk/SOURCE/subsidence_mod.f90	(revision 4591)
@@ -1,51 +1,54 @@
 !> @file subsidence_mod.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
 ! -----------------
-! 
-! 
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
-! Introduction of wall_flags_total_0, which currently sets bits based on static
-! topography information used in wall_flags_static_0
-! 
+! File re-formatted to follow the PALM coding standard
+!
+!
+! 4360 2020-01-07 11:25:50Z suehring
+! Introduction of wall_flags_total_0, which currently sets bits based on static topography
+! information used in wall_flags_static_0
+!
 ! 4329 2019-12-10 15:46:36Z motisi
 ! Renamed wall_flags_0 to wall_flags_static_0
-! 
+!
 ! 4182 2019-08-22 15:20:23Z scharf
 ! Corrected "Former revisions" section
-! 
+!
 ! 3655 2019-01-07 16:51:22Z knoop
-! add subroutine and variable description
+! Add subroutine and variable description
 !
 ! Revision 3.7 2009-12-11 14:15:58Z heinze
-! Initial revision 
+! Initial revision
 !
 ! Description:
 ! ------------
-!> Impact of large-scale subsidence or ascent as tendency term for use 
-!> in the prognostic equation of potential temperature. This enables the 
-!> construction of a constant boundary layer height z_i with time.
-!-----------------------------------------------------------------------------!
+!> Impact of large-scale subsidence or ascent as tendency term for use in the prognostic equation of
+!> potential temperature. This enables the construction of a constant boundary layer height z_i with
+!> time.
+!--------------------------------------------------------------------------------------------------!
  MODULE subsidence_mod
- 
 
 
@@ -66,20 +69,26 @@
  CONTAINS
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Initialize vertical subsidence velocity w_subs.
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_w_subsidence 
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzu, w_subs, zu
-
-       USE control_parameters,                                                 &
-           ONLY:  message_string, ocean_mode, subs_vertical_gradient,          &
-                  subs_vertical_gradient_level, subs_vertical_gradient_level_i
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
+!--------------------------------------------------------------------------------------------------!
+    SUBROUTINE init_w_subsidence
+
+       USE arrays_3d,                                                                              &
+           ONLY:  dzu,                                                                             &
+                  w_subs,                                                                          &
+                  zu
+
+       USE control_parameters,                                                                     &
+           ONLY:  message_string,                                                                  &
+                  ocean_mode,                                                                      &
+                  subs_vertical_gradient,                                                          &
+                  subs_vertical_gradient_level,                                                    &
+                  subs_vertical_gradient_level_i
+
+       USE indices,                                                                                &
+           ONLY:  nzb,                                                                             &
+                  nzt
 
        USE kinds
@@ -87,33 +96,31 @@
        IMPLICIT NONE
 
-       INTEGER(iwp) ::  i !< loop index
-       INTEGER(iwp) ::  k !< loop index
-
-       REAL(wp)     ::  gradient   !< vertical gradient of subsidence velocity
-       REAL(wp)     ::  ws_surface !< subsidence velocity at the surface
+       INTEGER(iwp) ::  i  !< loop index
+       INTEGER(iwp) ::  k  !< loop index
+
+       REAL(wp) ::  gradient    !< vertical gradient of subsidence velocity
+       REAL(wp) ::  ws_surface  !< subsidence velocity at the surface
 
        IF ( .NOT. ALLOCATED( w_subs ) )  THEN
           ALLOCATE( w_subs(nzb:nzt+1) )
           w_subs = 0.0_wp
-       ENDIF 
+       ENDIF
 
        IF ( ocean_mode )  THEN
-          message_string = 'applying large scale vertical motion is not ' //   &
-                           'allowed for ocean mode'
+          message_string = 'applying large scale vertical motion is not allowed for ocean mode'
           CALL message( 'init_w_subsidence', 'PA0324', 2, 2, 0, 6, 0 )
        ENDIF
 
 !
-!--   Compute the profile of the subsidence/ascent velocity 
-!--   using the given gradients
+!--   Compute the profile of the subsidence/ascent velocity using the given gradients
       i = 1
       gradient = 0.0_wp
       ws_surface = 0.0_wp
-      
+
 
       subs_vertical_gradient_level_i(1) = 0
       DO  k = 1, nzt+1
          IF ( i < 11 )  THEN
-            IF ( subs_vertical_gradient_level(i) < zu(k)  .AND. &
+            IF ( subs_vertical_gradient_level(i) < zu(k)  .AND.                                    &
                  subs_vertical_gradient_level(i) >= 0.0_wp )  THEN
                gradient = subs_vertical_gradient(i) / 100.0_wp
@@ -134,6 +141,5 @@
 
 !
-!--   In case of no given gradients for the subsidence/ascent velocity,
-!--   choose zero gradient
+!--   In case of no given gradients for the subsidence/ascent velocity, choose zero gradient
       IF ( subs_vertical_gradient_level(1) == -9999999.9_wp )  THEN
          subs_vertical_gradient_level(1) = 0.0_wp
@@ -143,41 +149,54 @@
 
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Add effect of large-scale subsidence to variable.
-!------------------------------------------------------------------------------!
-    SUBROUTINE subsidence( tendency, var, var_init, ls_index ) 
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, w_subs
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
+!--------------------------------------------------------------------------------------------------!
+    SUBROUTINE subsidence( tendency, var, var_init, ls_index )
+
+       USE arrays_3d,                                                                              &
+           ONLY:  ddzu,                                                                            &
+                  w_subs
+
+       USE control_parameters,                                                                     &
+           ONLY:  dt_3d,                                                                           &
+                  intermediate_timestep_count,                                                     &
+                  large_scale_forcing,                                                             &
                   scalar_rayleigh_damping
 
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt,        &
+       USE indices,                                                                                &
+           ONLY:  nxl,                                                                             &
+                  nxlg,                                                                            &
+                  nxr,                                                                             &
+                  nxrg,                                                                            &
+                  nyn,                                                                             &
+                  nyng,                                                                            &
+                  nys,                                                                             &
+                  nysg,                                                                            &
+                  nzb,                                                                             &
+                  nzt,                                                                             &
                   wall_flags_total_0
 
        USE kinds
 
-       USE statistics,                                                         &
-           ONLY:  sums_ls_l, weight_substep
+       USE statistics,                                                                             &
+           ONLY:  sums_ls_l,                                                                       &
+                  weight_substep
 
        IMPLICIT NONE
- 
-       INTEGER(iwp) ::  i        !< loop index
-       INTEGER(iwp) ::  j        !< loop index
-       INTEGER(iwp) ::  k        !< loop index
-       INTEGER(iwp) ::  ls_index !< index of large-scale subsidence in sums_ls_l
-
-       REAL(wp)     ::  tmp_tend !< temporary tendency
-       REAL(wp)     ::  tmp_grad !< temporary gradient 
-    
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< variable where to add subsidence
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< tendency of var
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< initialization profile of var
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< modified profile of var
+
+       INTEGER(iwp) ::  i         !< loop index
+       INTEGER(iwp) ::  j         !< loop index
+       INTEGER(iwp) ::  k         !< loop index
+       INTEGER(iwp) ::  ls_index  !< index of large-scale subsidence in sums_ls_l
+
+       REAL(wp) ::  tmp_tend  !< temporary tendency
+       REAL(wp) ::  tmp_grad  !< temporary gradient
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var       !< variable where to add subsidence
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency  !< tendency of var
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                      !< initialization profile of var
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                       !< modified profile of var
 
        var_mod = var_init
@@ -188,15 +207,11 @@
           DO  j = nys, nyn
 
-             DO  k = nzb+1, nzt 
+             DO  k = nzb+1, nzt
                 IF ( w_subs(k) < 0.0_wp )  THEN    ! large-scale subsidence
-                   tmp_tend = - w_subs(k) *                                    &
-                              ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1) *      &
-                                        MERGE( 1.0_wp, 0.0_wp,                 &
-                                        BTEST( wall_flags_total_0(k,j,i), 0 ) )
-                ELSE                               ! large-scale ascent
-                   tmp_tend = - w_subs(k) *                                    &
-                              ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k) *        &
-                                        MERGE( 1.0_wp, 0.0_wp,                 &
-                                        BTEST( wall_flags_total_0(k,j,i), 0 ) )
+                   tmp_tend = - w_subs(k) * ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1) *            &
+                              MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
+                ELSE   ! large-scale ascent
+                   tmp_tend = - w_subs(k) * ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k) *              &
+                              MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
                 ENDIF
 
@@ -204,8 +219,8 @@
 
                 IF ( large_scale_forcing )  THEN
-                   sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend    &
-                                 * weight_substep(intermediate_timestep_count) &
-                                 * MERGE( 1.0_wp, 0.0_wp,                      &
-                                   BTEST( wall_flags_total_0(k,j,i), 0 ) )
+                   sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend                        &
+                                           * weight_substep(intermediate_timestep_count)           &
+                                           * MERGE( 1.0_wp, 0.0_wp,                                &
+                                                    BTEST( wall_flags_total_0(k,j,i), 0 ) )
                 ENDIF
              ENDDO
@@ -219,33 +234,30 @@
 
 !
-!--    Shifting of the initial profile is especially necessary with Rayleigh 
-!--    damping switched on
-       IF ( scalar_rayleigh_damping .AND.                                      &
-            intermediate_timestep_count == 1 )  THEN
+!--    Shifting of the initial profile is especially necessary with Rayleigh damping switched on
+       IF ( scalar_rayleigh_damping  .AND.  intermediate_timestep_count == 1 )  THEN
           DO  k = nzb, nzt
              IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-                var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                  ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
+                var_mod(k) = var_init(k) - dt_3d * w_subs(k) *                                     &
+                             ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
              ENDIF
           ENDDO
 !
-!--      At the upper boundary, the initial profile is shifted with aid of 
-!--      the gradient tmp_grad. (This is ok if the gradients are linear.)
+!--      At the upper boundary, the initial profile is shifted with aid of the gradient tmp_grad.
+!--      (This is ok if the gradients are linear.)
          IF ( w_subs(nzt) < 0.0_wp )  THEN
             tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
-            var_mod(nzt+1) = var_init(nzt+1) -  &
-                                 dt_3d * w_subs(nzt+1) * tmp_grad
+            var_mod(nzt+1) = var_init(nzt+1) - dt_3d * w_subs(nzt+1) * tmp_grad
          ENDIF
-       
+
 
          DO  k = nzt+1, nzb+1, -1
             IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
-               var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                  ( var_init(k) - var_init(k-1) ) * ddzu(k) 
+               var_mod(k) = var_init(k) - dt_3d * w_subs(k) *                                      &
+                            ( var_init(k) - var_init(k-1) ) * ddzu(k)
             ENDIF
          ENDDO
 !
-!--      At the lower boundary shifting is not necessary because the 
-!--      subsidence velocity w_subs(nzb) vanishes.
+!--      At the lower boundary shifting is not necessary because the subsidence velocity w_subs(nzb)
+!--      vanishes.
          IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
             var_mod(nzb) = var_init(nzb)
@@ -258,41 +270,52 @@
  END SUBROUTINE subsidence
 
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! Description:
 ! ------------
 !> Add effect of large-scale subsidence to variable.
-!------------------------------------------------------------------------------!
- SUBROUTINE subsidence_ij( i, j, tendency, var, var_init, ls_index ) 
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, w_subs
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
+!--------------------------------------------------------------------------------------------------!
+ SUBROUTINE subsidence_ij( i, j, tendency, var, var_init, ls_index )
+
+       USE arrays_3d,                                                                              &
+           ONLY:  ddzu,                                                                            &
+                  w_subs
+
+       USE control_parameters,                                                                     &
+           ONLY:  dt_3d,                                                                           &
+                  intermediate_timestep_count,                                                     &
+                  large_scale_forcing,                                                             &
                   scalar_rayleigh_damping
 
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxrg, nyng, nys, nysg, nzb, nzt,                  &
+       USE indices,                                                                                &
+           ONLY:  nxl,                                                                             &
+                  nxlg,                                                                            &
+                  nxrg,                                                                            &
+                  nyng,                                                                            &
+                  nys,                                                                             &
+                  nysg,                                                                            &
+                  nzb,                                                                             &
+                  nzt,                                                                             &
                   wall_flags_total_0
 
        USE kinds
 
-       USE statistics,                                                         &
-           ONLY:  sums_ls_l, weight_substep
+       USE statistics,                                                                             &
+           ONLY:  sums_ls_l,                                                                       &
+                  weight_substep
 
        IMPLICIT NONE
- 
-       INTEGER(iwp) ::  i        !< loop variable
-       INTEGER(iwp) ::  j        !< loop variable
-       INTEGER(iwp) ::  k        !< loop variable
-       INTEGER(iwp) ::  ls_index !< index of large-scale subsidence in sums_ls_l
-
-       REAL(wp)     ::  tmp_tend !< temporary tendency
-       REAL(wp)     ::  tmp_grad !< temporary gradient
-    
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< variable where to add subsidence
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< tendency of var
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< initialization profile of var
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< modified profile of var
+
+       INTEGER(iwp) ::  i         !< loop variable
+       INTEGER(iwp) ::  j         !< loop variable
+       INTEGER(iwp) ::  k         !< loop variable
+       INTEGER(iwp) ::  ls_index  !< index of large-scale subsidence in sums_ls_l
+
+       REAL(wp) ::  tmp_tend  !< temporary tendency
+       REAL(wp) ::  tmp_grad  !< temporary gradient
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var       !< variable where to add subsidence
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency  !< tendency of var
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                      !< initialization profile of var
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                       !< modified profile of var
 
        var_mod = var_init
@@ -300,14 +323,11 @@
 !
 !--    Influence of w_subsidence on the current tendency term
-       DO  k = nzb+1, nzt 
+       DO  k = nzb+1, nzt
           IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-             tmp_tend = - w_subs(k) * ( var(k+1,j,i) - var(k,j,i) )            &
-                                    * ddzu(k+1)                                &
-                                    * MERGE( 1.0_wp, 0.0_wp,                   &
-                                      BTEST( wall_flags_total_0(k,j,i), 0 ) )
+             tmp_tend = - w_subs(k) * ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1)                    &
+                        * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
           ELSE                                 ! large-scale ascent
-             tmp_tend = - w_subs(k) * ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)  &
-                                    * MERGE( 1.0_wp, 0.0_wp,                   &
-                                      BTEST( wall_flags_total_0(k,j,i), 0 ) )
+             tmp_tend = - w_subs(k) * ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)                      &
+                        * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
           ENDIF
 
@@ -315,8 +335,7 @@
 
           IF ( large_scale_forcing )  THEN
-             sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend          &
-                                  * weight_substep(intermediate_timestep_count)&
-                                  * MERGE( 1.0_wp, 0.0_wp,                     &
-                                    BTEST( wall_flags_total_0(k,j,i), 0 ) )
+             sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend                              &
+                                     * weight_substep(intermediate_timestep_count)                 &
+                                     * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
           ENDIF
        ENDDO
@@ -327,40 +346,37 @@
 
 !
-!--    Shifting of the initial profile is especially necessary with Rayleigh 
-!--    damping switched on
-       IF ( scalar_rayleigh_damping .AND.                                      &
-            intermediate_timestep_count == 1 )  THEN
-          IF ( i == nxl .AND. j == nys )  THEN ! shifting only once per PE 
+!--    Shifting of the initial profile is especially necessary with Rayleigh damping switched on
+       IF ( scalar_rayleigh_damping  .AND.  intermediate_timestep_count == 1 )  THEN
+          IF ( i == nxl .AND. j == nys )  THEN ! shifting only once per PE
 
              DO  k = nzb, nzt
                 IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                     ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
+                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *                                  &
+                               ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
                 ENDIF
              ENDDO
 !
-!--          At the upper boundary, the initial profile is shifted with aid of 
-!--          the gradient tmp_grad. (This is ok if the gradients are linear.)
+!--          At the upper boundary, the initial profile is shifted with aid of the gradient
+!--          tmp_grad. (This is ok if the gradients are linear.)
              IF ( w_subs(nzt) < 0.0_wp )  THEN
                 tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
-                var_mod(nzt+1) = var_init(nzt+1) -  &
-                                     dt_3d * w_subs(nzt+1) * tmp_grad
+                var_mod(nzt+1) = var_init(nzt+1) - dt_3d * w_subs(nzt+1) * tmp_grad
              ENDIF
-       
+
 
              DO  k = nzt+1, nzb+1, -1
                 IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
-                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                      ( var_init(k) - var_init(k-1) ) * ddzu(k)
+                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *                                  &
+                                ( var_init(k) - var_init(k-1) ) * ddzu(k)
                 ENDIF
              ENDDO
 !
-!--          At the lower boundary shifting is not necessary because the 
-!--          subsidence velocity w_subs(nzb) vanishes.
+!--          At the lower boundary shifting is not necessary because the subsidence velocity
+!--          w_subs(nzb) vanishes.
              IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
                 var_mod(nzb) = var_init(nzb)
              ENDIF
 
-             var_init = var_mod 
+             var_init = var_mod
 
           ENDIF
Index: /palm/trunk/SOURCE/sum_up_3d_data.f90
===================================================================
--- /palm/trunk/SOURCE/sum_up_3d_data.f90	(revision 4590)
+++ /palm/trunk/SOURCE/sum_up_3d_data.f90	(revision 4591)
@@ -1,64 +1,66 @@
 !> @file sum_up_3d_data.f90
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
 ! This file is part of the PALM model system.
 !
-! PALM is free software: you can redistribute it and/or modify it under the
-! terms of the GNU General Public License as published by the Free Software
-! Foundation, either version 3 of the License, or (at your option) any later
-! version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
+! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
+! Public License as published by the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
+! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+! Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with PALM. If not, see
+! <http://www.gnu.org/licenses/>.
 !
 ! Copyright 1997-2020 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
+!--------------------------------------------------------------------------------------------------!
+!
 !
 ! Current revisions:
-! ------------------
-! 
-! 
+! -----------------
+!
+!
 ! Former revisions:
 ! -----------------
 ! $Id$
-! remove double index
-! 
+! File re-formatted to follow the PALM coding standard
+!
+! 4516 2020-04-30 16:55:10Z suehring
+! Remove double index
+!
 ! 4514 2020-04-30 16:29:59Z suehring
 ! Enable output of qsurf and ssurf
-! 
+!
 ! 4442 2020-03-04 19:21:13Z suehring
-! Change order of dimension in surface array %frac to allow for better 
-! vectorization.
-! 
+! Change order of dimension in surface array %frac to allow for better vectorization.
+!
 ! 4441 2020-03-04 19:20:35Z suehring
 ! Move 2-m potential temperature output to diagnostic_output_quantities
-! 
+!
 ! 4182 2019-08-22 15:20:23Z scharf
 ! Corrected "Former revisions" section
-! 
+!
 ! 4048 2019-06-21 21:00:21Z knoop
 ! Moved tcm_3d_data_averaging to module_interface
-! 
+!
 ! 4039 2019-06-18 10:32:41Z suehring
 ! Modularize diagnostic output
-! 
+!
 ! 3994 2019-05-22 18:08:09Z suehring
-! output of turbulence intensity added
-! 
+! Output of turbulence intensity added
+!
 ! 3943 2019-05-02 09:50:41Z maronga
 ! Added output of qsws_av for green roofs.
-! 
+!
 ! 3933 2019-04-25 12:33:20Z kanani
 ! Formatting
-! 
+!
 ! 3773 2019-03-01 08:56:57Z maronga
 ! Added output of theta_2m*_xy_av
-! 
+!
 ! 3761 2019-02-25 15:31:42Z raasch
 ! unused variables removed
-! 
+!
 ! 3655 2019-01-07 16:51:22Z knoop
 ! Implementation of the PALM module interface
@@ -70,52 +72,114 @@
 ! Description:
 ! ------------
-!> Sum-up the values of 3d-arrays. The real averaging is later done in routine
-!> average_3d_data. 
-!------------------------------------------------------------------------------!
+!> Sum-up the values of 3d-arrays. The real averaging is later done in routine average_3d_data.
+!--------------------------------------------------------------------------------------------------!
  SUBROUTINE sum_up_3d_data
- 
-
-    USE arrays_3d,                                                             &
-        ONLY:  dzw, d_exner, e, heatflux_output_conversion, p,                 &
-               pt, q, ql, ql_c, ql_v, s, u, v, vpt, w,                         &
+
+
+    USE arrays_3d,                                                                                 &
+        ONLY:  dzw,                                                                                &
+               d_exner,                                                                            &
+               e,                                                                                  &
+               heatflux_output_conversion,                                                         &
+               p,                                                                                  &
+               pt,                                                                                 &
+               q,                                                                                  &
+               ql,                                                                                 &
+               ql_c,                                                                               &
+               ql_v,                                                                               &
+               s,                                                                                  &
+               u,                                                                                  &
+               v,                                                                                  &
+               vpt,                                                                                &
+               w,                                                                                  &
                waterflux_output_conversion
 
-    USE averaging,                                                             &
-        ONLY:  e_av, ghf_av, lpt_av, lwp_av, ol_av, p_av, pc_av, pr_av, pt_av, &
-               q_av, ql_av, ql_c_av, ql_v_av, ql_vp_av, qsurf_av, qsws_av,     &
-               qv_av, r_a_av, s_av, shf_av, ssurf_av,                          &
-               ssws_av, ts_av, tsurf_av, u_av,                                 &
-               us_av, v_av, vpt_av, w_av, z0_av, z0h_av, z0q_av
-
-    USE basic_constants_and_equations_mod,                                     &
-        ONLY:  c_p, lv_d_cp, l_v
-
-    USE bulk_cloud_model_mod,                                                  &
+    USE averaging,                                                                                 &
+        ONLY:  e_av,                                                                               &
+               ghf_av,                                                                             &
+               lpt_av,                                                                             &
+               lwp_av,                                                                             &
+               ol_av,                                                                              &
+               p_av,                                                                               &
+               pc_av,                                                                              &
+               pr_av,                                                                              &
+               pt_av,                                                                              &
+               q_av,                                                                               &
+               ql_av,                                                                              &
+               ql_c_av,                                                                            &
+               ql_v_av,                                                                            &
+               ql_vp_av,                                                                           &
+               qsurf_av,                                                                           &
+               qsws_av,                                                                            &
+               qv_av,                                                                              &
+               r_a_av,                                                                             &
+               s_av,                                                                               &
+               shf_av,                                                                             &
+               ssurf_av,                                                                           &
+               ssws_av,                                                                            &
+               ts_av,                                                                              &
+               tsurf_av,                                                                           &
+               u_av,                                                                               &
+               us_av,                                                                              &
+               v_av,                                                                               &
+               vpt_av,                                                                             &
+               w_av,                                                                               &
+               z0_av,                                                                              &
+               z0h_av,                                                                             &
+               z0q_av
+
+    USE basic_constants_and_equations_mod,                                                         &
+        ONLY:  c_p,                                                                                &
+               lv_d_cp,                                                                            &
+               l_v
+
+    USE bulk_cloud_model_mod,                                                                      &
         ONLY:  bulk_cloud_model
 
-    USE control_parameters,                                                    &
-        ONLY:  average_count_3d, doav, doav_n, rho_surface, urban_surface,     &
+    USE control_parameters,                                                                        &
+        ONLY:  average_count_3d,                                                                   &
+               doav,                                                                               &
+               doav_n,                                                                             &
+               rho_surface,                                                                        &
+               urban_surface,                                                                      &
                varnamelength
 
-    USE cpulog,                                                                &
-        ONLY:  cpu_log, log_point
-
-    USE indices,                                                               &
-        ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt,           &
+    USE cpulog,                                                                                    &
+        ONLY:  cpu_log,                                                                            &
+               log_point
+
+    USE indices,                                                                                   &
+        ONLY:  nxl,                                                                                &
+               nxlg,                                                                               &
+               nxr,                                                                                &
+               nxrg,                                                                               &
+               nyn,                                                                                &
+               nyng,                                                                               &
+               nys,                                                                                &
+               nysg,                                                                               &
+               nzb,                                                                                &
+               nzt,                                                                                &
                topo_top_ind
 
     USE kinds
 
-    USE module_interface,                                                      &
+    USE module_interface,                                                                          &
         ONLY:  module_interface_3d_data_averaging
 
-    USE particle_attributes,                                                   &
-        ONLY:  grid_particles, number_of_particles, particles, prt_count
-
-    USE surface_mod,                                                           &
-        ONLY:  ind_pav_green, ind_veg_wall, ind_wat_win,                       &
-               surf_def_h, surf_lsm_h, surf_usm_h
-
-    USE urban_surface_mod,                                                     &
+    USE particle_attributes,                                                                       &
+        ONLY:  grid_particles,                                                                     &
+               number_of_particles,                                                                &
+               particles,                                                                          &
+               prt_count
+
+    USE surface_mod,                                                                               &
+        ONLY:  ind_pav_green,                                                                      &
+               ind_veg_wall,                                                                       &
+               ind_wat_win,                                                                        &
+               surf_def_h,                                                                         &
+               surf_lsm_h,                                                                         &
+               surf_usm_h
+
+    USE urban_surface_mod,                                                                         &
         ONLY:  usm_3d_data_averaging
 
@@ -123,8 +187,6 @@
     IMPLICIT NONE
 
-    LOGICAL      ::  match_def !< flag indicating default-type surface
-    LOGICAL      ::  match_lsm !< flag indicating natural-type surface
-    LOGICAL      ::  match_usm !< flag indicating urban-type surface
-    
+    CHARACTER(LEN=varnamelength) ::  trimvar  !< TRIM of output-variable string
+
     INTEGER(iwp) ::  i   !< grid index x direction
     INTEGER(iwp) ::  ii  !< running index
@@ -134,9 +196,12 @@
     INTEGER(iwp) ::  n   !< running index over number of particles per grid box
 
-    REAL(wp)     ::  mean_r !< mean-particle radius witin grid box
-    REAL(wp)     ::  s_r2   !< mean-particle radius witin grid box to the power of two
-    REAL(wp)     ::  s_r3   !< mean-particle radius witin grid box to the power of three
-
-    CHARACTER (LEN=varnamelength) ::  trimvar  !< TRIM of output-variable string
+    LOGICAL ::  match_def  !< flag indicating default-type surface
+    LOGICAL ::  match_lsm  !< flag indicating natural-type surface
+    LOGICAL ::  match_usm  !< flag indicating urban-type surface
+
+    REAL(wp) ::  mean_r  !< mean-particle radius witin grid box
+    REAL(wp) ::  s_r2    !< mean-particle radius witin grid box to the power of two
+    REAL(wp) ::  s_r3    !< mean-particle radius witin grid box to the power of three
+
 
 
@@ -144,7 +209,6 @@
 
 !
-!-- Allocate and initialize the summation arrays if called for the very first
-!-- time or the first time after average_3d_data has been called 
-!-- (some or all of the arrays may have been already allocated
+!-- Allocate and initialize the summation arrays if called for the very first time or the first time
+!-- after average_3d_data has been called (some or all of the arrays may have been already allocated
 !-- in rrd_local)
     IF ( average_count_3d == 0 )  THEN
@@ -286,5 +350,5 @@
                    ALLOCATE( ssws_av(nysg:nyng,nxlg:nxrg) )
                 ENDIF
-                ssws_av = 0.0_wp                
+                ssws_av = 0.0_wp
 
              CASE ( 't*' )
@@ -376,29 +440,23 @@
                    DO  j = nys, nyn
 !
-!--                   Check whether grid point is a natural- or urban-type 
-!--                   surface.
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
-!
-!--                   In order to avoid double-counting of surface properties,
-!--                   always assume that natural-type surfaces are below urban-
-!--                   type surfaces, e.g. in case of bridges.
-!--                   Further, take only the last suface element, i.e. the
-!--                   uppermost surface which would be visible from above
+!--                   Check whether grid point is a natural- or urban-type surface.
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
+!
+!--                   In order to avoid double-counting of surface properties, always assume that
+!--                   natural-type surfaces are below urban type surfaces, e.g. in case of bridges.
+!--                   Further, take only the last suface element, i.e. the uppermost surface which
+!--                   would be visible from above
                       IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         ghf_av(j,i) = ghf_av(j,i) +                           &
-                                         surf_lsm_h%ghf(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         ghf_av(j,i) = ghf_av(j,i) +                           &
-                                         surf_usm_h%frac(m,ind_veg_wall)  *    &
-                                         surf_usm_h%wghf_eb(m)        +        &
-                                         surf_usm_h%frac(m,ind_pav_green) *    &
-                                         surf_usm_h%wghf_eb_green(m)  +        &
-                                         surf_usm_h%frac(m,ind_wat_win)   *    &
-                                         surf_usm_h%wghf_eb_window(m)
+                         ghf_av(j,i) = ghf_av(j,i) + surf_lsm_h%ghf(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         ghf_av(j,i) = ghf_av(j,i) + surf_usm_h%frac(m,ind_veg_wall)  *            &
+                                                     surf_usm_h%wghf_eb(m)        +                &
+                                                     surf_usm_h%frac(m,ind_pav_green) *            &
+                                                     surf_usm_h%wghf_eb_green(m)  +                &
+                                                     surf_usm_h%frac(m,ind_wat_win)   *            &
+                                                     surf_usm_h%wghf_eb_window(m)
                       ENDIF
                    ENDDO
@@ -432,6 +490,6 @@
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
-                      lwp_av(j,i) = lwp_av(j,i) + SUM( ql(nzb:nzt,j,i)            &
-                                                  * dzw(1:nzt+1) ) * rho_surface
+                      lwp_av(j,i) = lwp_av(j,i) + SUM( ql(nzb:nzt,j,i) * dzw(1:nzt+1) )            &
+                                                                       * rho_surface
                    ENDDO
                 ENDDO
@@ -442,23 +500,17 @@
                 DO  i = nxl, nxr
                    DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         ol_av(j,i) = ol_av(j,i) +                             &
-                                         surf_def_h(0)%ol(m)
+                         ol_av(j,i) = ol_av(j,i) + surf_def_h(0)%ol(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         ol_av(j,i) = ol_av(j,i) +                             &
-                                         surf_lsm_h%ol(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         ol_av(j,i) = ol_av(j,i) +                             &
-                                         surf_usm_h%ol(m)
+                         ol_av(j,i) = ol_av(j,i) + surf_lsm_h%ol(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         ol_av(j,i) = ol_av(j,i) + surf_usm_h%ol(m)
                       ENDIF
                    ENDDO
@@ -495,6 +547,5 @@
                          number_of_particles = prt_count(k,j,i)
                          IF ( number_of_particles <= 0 )  CYCLE
-                         particles =>                                          &
-                         grid_particles(k,j,i)%particles(1:number_of_particles)
+                         particles => grid_particles(k,j,i)%particles(1:number_of_particles)
                          s_r2 = 0.0_wp
                          s_r3 = 0.0_wp
@@ -502,8 +553,6 @@
                          DO  n = 1, number_of_particles
                             IF ( particles(n)%particle_mask )  THEN
-                               s_r2 = s_r2 + particles(n)%radius**2 *          &
-                                   particles(n)%weight_factor
-                               s_r3 = s_r3 + particles(n)%radius**3 *          &
-                                   particles(n)%weight_factor
+                               s_r2 = s_r2 + particles(n)%radius**2 * particles(n)%weight_factor
+                               s_r3 = s_r3 + particles(n)%radius**3 * particles(n)%weight_factor
                             ENDIF
                          ENDDO
@@ -534,6 +583,6 @@
                    DO  j = nysg, nyng
                       DO  k = nzb, nzt+1
-                            pt_av(k,j,i) = pt_av(k,j,i) + pt(k,j,i) + lv_d_cp * &
-                                                          d_exner(k) * ql(k,j,i)
+                            pt_av(k,j,i) = pt_av(k,j,i) + pt(k,j,i) + lv_d_cp * d_exner(k)         &
+                                                                              * ql(k,j,i)
                          ENDDO
                       ENDDO
@@ -565,5 +614,5 @@
 
           CASE ( 'ql_c' )
-             IF ( ALLOCATED( ql_c_av ) ) THEN 
+             IF ( ALLOCATED( ql_c_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -576,5 +625,5 @@
 
           CASE ( 'ql_v' )
-             IF ( ALLOCATED( ql_v_av ) ) THEN 
+             IF ( ALLOCATED( ql_v_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -587,5 +636,5 @@
 
           CASE ( 'ql_vp' )
-             IF ( ALLOCATED( ql_vp_av ) ) THEN 
+             IF ( ALLOCATED( ql_vp_av ) ) THEN
                 DO  i = nxl, nxr
                    DO  j = nys, nyn
@@ -593,11 +642,9 @@
                          number_of_particles = prt_count(k,j,i)
                          IF ( number_of_particles <= 0 )  CYCLE
-                         particles =>                                          & 
-                         grid_particles(k,j,i)%particles(1:number_of_particles)
+                         particles => grid_particles(k,j,i)%particles(1:number_of_particles)
                          DO  n = 1, number_of_particles
                             IF ( particles(n)%particle_mask )  THEN
-                               ql_vp_av(k,j,i) = ql_vp_av(k,j,i) + &
-                                                 particles(n)%weight_factor /  &
-                                                 number_of_particles
+                               ql_vp_av(k,j,i) = ql_vp_av(k,j,i) +                                 &
+                                                 particles(n)%weight_factor / number_of_particles
                             ENDIF
                          ENDDO
@@ -611,23 +658,17 @@
                 DO  i = nxl, nxr
                    DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         qsurf_av(j,i) = qsurf_av(j,i) +                       &
-                                         surf_def_h(0)%q_surface(m)
+                         qsurf_av(j,i) = qsurf_av(j,i) + surf_def_h(0)%q_surface(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         qsurf_av(j,i) = qsurf_av(j,i) +                       &
-                                         surf_lsm_h%q_surface(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         qsurf_av(j,i) = qsurf_av(j,i) +                       &
-                                         surf_usm_h%q_surface(m)
+                         qsurf_av(j,i) = qsurf_av(j,i) + surf_lsm_h%q_surface(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         qsurf_av(j,i) = qsurf_av(j,i) + surf_usm_h%q_surface(m)
                       ENDIF
                    ENDDO
@@ -638,30 +679,23 @@
 !
 !--          In case of default surfaces, clean-up flux by density.
-!--          In case of land- and urban-surfaces, convert fluxes into
-!--          dynamic units.
+!--          In case of land- and urban-surfaces, convert fluxes into dynamic units.
 !--          Question (maronga): are the .NOT. statements really required?
-             IF ( ALLOCATED( qsws_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( qsws_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         qsws_av(j,i) = qsws_av(j,i) +                         &
-                                         surf_def_h(0)%qsws(m) *               &
-                                         waterflux_output_conversion(nzb)
+                         qsws_av(j,i) = qsws_av(j,i) + surf_def_h(0)%qsws(m) *                     &
+                                        waterflux_output_conversion(nzb)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         qsws_av(j,i) = qsws_av(j,i) +                         &
-                                         surf_lsm_h%qsws(m) * l_v
+                         qsws_av(j,i) = qsws_av(j,i) + surf_lsm_h%qsws(m) * l_v
                       ELSEIF ( match_usm  .AND.  .NOT. match_lsm )  THEN
                          m = surf_usm_h%end_index(j,i)
-                         qsws_av(j,i) = qsws_av(j,i) +                         &
-                                         surf_usm_h%qsws(m) * l_v
+                         qsws_av(j,i) = qsws_av(j,i) + surf_usm_h%qsws(m) * l_v
                       ENDIF
                    ENDDO
@@ -670,5 +704,5 @@
 
           CASE ( 'qv' )
-             IF ( ALLOCATED( qv_av ) ) THEN 
+             IF ( ALLOCATED( qv_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -681,25 +715,21 @@
 
           CASE ( 'r_a*' )
-             IF ( ALLOCATED( r_a_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( r_a_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         r_a_av(j,i) = r_a_av(j,i) +                           &
-                                         surf_lsm_h%r_a(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         r_a_av(j,i) = r_a_av(j,i) +                           &
-                                         surf_usm_h%frac(m,ind_veg_wall)  *    &
-                                         surf_usm_h%r_a(m)       +             & 
-                                         surf_usm_h%frac(m,ind_pav_green) *    &
-                                         surf_usm_h%r_a_green(m) +             & 
-                                         surf_usm_h%frac(m,ind_wat_win)   *    &
-                                         surf_usm_h%r_a_window(m)
+                         r_a_av(j,i) = r_a_av(j,i) + surf_lsm_h%r_a(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         r_a_av(j,i) = r_a_av(j,i) + surf_usm_h%frac(m,ind_veg_wall)  *            &
+                                                     surf_usm_h%r_a(m)       +                     &
+                                                     surf_usm_h%frac(m,ind_pav_green) *            &
+                                                     surf_usm_h%r_a_green(m) +                     &
+                                                     surf_usm_h%frac(m,ind_wat_win)   *            &
+                                                     surf_usm_h%r_a_window(m)
                       ENDIF
                    ENDDO
@@ -708,5 +738,5 @@
 
           CASE ( 's' )
-             IF ( ALLOCATED( s_av ) ) THEN 
+             IF ( ALLOCATED( s_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -721,29 +751,22 @@
 !
 !--          In case of default surfaces, clean-up flux by density.
-!--          In case of land- and urban-surfaces, convert fluxes into
-!--          dynamic units.
-             IF ( ALLOCATED( shf_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+!--          In case of land- and urban-surfaces, convert fluxes into dynamic units.
+             IF ( ALLOCATED( shf_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         shf_av(j,i) = shf_av(j,i) +                           &
-                                         surf_def_h(0)%shf(m)  *               &
-                                         heatflux_output_conversion(nzb)
+                         shf_av(j,i) = shf_av(j,i) + surf_def_h(0)%shf(m)  *                       &
+                                       heatflux_output_conversion(nzb)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         shf_av(j,i) = shf_av(j,i) +                           &
-                                         surf_lsm_h%shf(m) * c_p
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         shf_av(j,i) = shf_av(j,i) +                           &
-                                         surf_usm_h%shf(m) * c_p
+                         shf_av(j,i) = shf_av(j,i) + surf_lsm_h%shf(m) * c_p
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         shf_av(j,i) = shf_av(j,i) + surf_usm_h%shf(m) * c_p
                       ENDIF
                    ENDDO
@@ -762,26 +785,20 @@
 
           CASE ( 'ssws*' )
-             IF ( ALLOCATED( ssws_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( ssws_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         ssws_av(j,i) = ssws_av(j,i) +                         &
-                                         surf_def_h(0)%ssws(m)
+                         ssws_av(j,i) = ssws_av(j,i) + surf_def_h(0)%ssws(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         ssws_av(j,i) = ssws_av(j,i) +                         &
-                                         surf_lsm_h%ssws(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         ssws_av(j,i) = ssws_av(j,i) +                         &
-                                         surf_usm_h%ssws(m)
+                         ssws_av(j,i) = ssws_av(j,i) + surf_lsm_h%ssws(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         ssws_av(j,i) = ssws_av(j,i) + surf_usm_h%ssws(m)
                       ENDIF
                    ENDDO
@@ -790,26 +807,20 @@
 
           CASE ( 't*' )
-             IF ( ALLOCATED( ts_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( ts_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         ts_av(j,i) = ts_av(j,i) +                             &
-                                         surf_def_h(0)%ts(m)
+                         ts_av(j,i) = ts_av(j,i) + surf_def_h(0)%ts(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         ts_av(j,i) = ts_av(j,i) +                             &
-                                         surf_lsm_h%ts(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         ts_av(j,i) = ts_av(j,i) +                             &
-                                         surf_usm_h%ts(m)
+                         ts_av(j,i) = ts_av(j,i) + surf_lsm_h%ts(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         ts_av(j,i) = ts_av(j,i) + surf_usm_h%ts(m)
                       ENDIF
                    ENDDO
@@ -818,26 +829,20 @@
 
           CASE ( 'tsurf*' )
-             IF ( ALLOCATED( tsurf_av ) ) THEN    
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( tsurf_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         tsurf_av(j,i) = tsurf_av(j,i) +                       &
-                                         surf_def_h(0)%pt_surface(m)
+                         tsurf_av(j,i) = tsurf_av(j,i) + surf_def_h(0)%pt_surface(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         tsurf_av(j,i) = tsurf_av(j,i) +                       &
-                                         surf_lsm_h%pt_surface(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         tsurf_av(j,i) = tsurf_av(j,i) +                       &
-                                         surf_usm_h%pt_surface(m)
+                         tsurf_av(j,i) = tsurf_av(j,i) + surf_lsm_h%pt_surface(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         tsurf_av(j,i) = tsurf_av(j,i) + surf_usm_h%pt_surface(m)
                       ENDIF
                    ENDDO
@@ -857,26 +862,20 @@
 
           CASE ( 'us*' )
-             IF ( ALLOCATED( us_av ) ) THEN   
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( us_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         us_av(j,i) = us_av(j,i) +                             &
-                                         surf_def_h(0)%us(m)
+                         us_av(j,i) = us_av(j,i) + surf_def_h(0)%us(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         us_av(j,i) = us_av(j,i) +                             &
-                                         surf_lsm_h%us(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         us_av(j,i) = us_av(j,i) +                             &
-                                         surf_usm_h%us(m)
+                         us_av(j,i) = us_av(j,i) + surf_lsm_h%us(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         us_av(j,i) = us_av(j,i) + surf_usm_h%us(m)
                       ENDIF
                    ENDDO
@@ -885,5 +884,5 @@
 
           CASE ( 'v' )
-             IF ( ALLOCATED( v_av ) ) THEN 
+             IF ( ALLOCATED( v_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -896,5 +895,5 @@
 
           CASE ( 'thetav' )
-             IF ( ALLOCATED( vpt_av ) ) THEN 
+             IF ( ALLOCATED( vpt_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -907,5 +906,5 @@
 
           CASE ( 'w' )
-             IF ( ALLOCATED( w_av ) ) THEN 
+             IF ( ALLOCATED( w_av ) ) THEN
                 DO  i = nxlg, nxrg
                    DO  j = nysg, nyng
@@ -918,82 +917,64 @@
 
           CASE ( 'z0*' )
-             IF ( ALLOCATED( z0_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( z0_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         z0_av(j,i) = z0_av(j,i) +                             &
-                                         surf_def_h(0)%z0(m)
+                         z0_av(j,i) = z0_av(j,i) + surf_def_h(0)%z0(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         z0_av(j,i) = z0_av(j,i) +                             &
-                                         surf_lsm_h%z0(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         z0_av(j,i) = z0_av(j,i) +                             &
-                                         surf_usm_h%z0(m)
-                      ENDIF
-                   ENDDO
-                ENDDO   
+                         z0_av(j,i) = z0_av(j,i) + surf_lsm_h%z0(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         z0_av(j,i) = z0_av(j,i) + surf_usm_h%z0(m)
+                      ENDIF
+                   ENDDO
+                ENDDO
              ENDIF
 
           CASE ( 'z0h*' )
-             IF ( ALLOCATED( z0h_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( z0h_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         z0h_av(j,i) = z0h_av(j,i) +                           &
-                                         surf_def_h(0)%z0h(m)
+                         z0h_av(j,i) = z0h_av(j,i) + surf_def_h(0)%z0h(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         z0h_av(j,i) = z0h_av(j,i) +                           &
-                                         surf_lsm_h%z0h(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         z0h_av(j,i) = z0h_av(j,i) +                           &
-                                         surf_usm_h%z0h(m)
-                      ENDIF
-                   ENDDO
-                ENDDO
-             ENDIF
-   
+                         z0h_av(j,i) = z0h_av(j,i) + surf_lsm_h%z0h(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         z0h_av(j,i) = z0h_av(j,i) + surf_usm_h%z0h(m)
+                      ENDIF
+                   ENDDO
+                ENDDO
+             ENDIF
+
           CASE ( 'z0q*' )
-             IF ( ALLOCATED( z0q_av ) ) THEN 
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      match_def = surf_def_h(0)%start_index(j,i) <=            &
-                                  surf_def_h(0)%end_index(j,i)
-                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
-                                  surf_lsm_h%end_index(j,i)
-                      match_usm = surf_usm_h%start_index(j,i) <=               &
-                                  surf_usm_h%end_index(j,i)
+             IF ( ALLOCATED( z0q_av ) ) THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      match_def = surf_def_h(0)%start_index(j,i) <= surf_def_h(0)%end_index(j,i)
+                      match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i)
+                      match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i)
 
                       IF ( match_def )  THEN
                          m = surf_def_h(0)%end_index(j,i)
-                         z0q_av(j,i) = z0q_av(j,i) +                           &
-                                         surf_def_h(0)%z0q(m)
+                         z0q_av(j,i) = z0q_av(j,i) + surf_def_h(0)%z0q(m)
                       ELSEIF ( match_lsm  .AND.  .NOT. match_usm )  THEN
                          m = surf_lsm_h%end_index(j,i)
-                         z0q_av(j,i) = z0q_av(j,i) +                           &
-                                         surf_lsm_h%z0q(m)
-                      ELSEIF ( match_usm )  THEN
-                         m = surf_usm_h%end_index(j,i)
-                         z0q_av(j,i) = z0q_av(j,i) +                           &
-                                         surf_usm_h%z0q(m)
+                         z0q_av(j,i) = z0q_av(j,i) + surf_lsm_h%z0q(m)
+                      ELSEIF ( match_usm )  THEN
+                         m = surf_usm_h%end_index(j,i)
+                         z0q_av(j,i) = z0q_av(j,i) + surf_usm_h%z0q(m)
                       ENDIF
                    ENDDO
@@ -1003,7 +984,7 @@
           CASE DEFAULT
 
-!--          In case of urban surface variables it should be always checked
-!--          if respective arrays are allocated, at least in case of a restart
-!--          run, as averaged usm arrays are not read from file at the moment.
+!--          In case of urban surface variables it should be always checked if respective arrays are
+!--          allocated, at least in case of a restart run, as averaged usm arrays are not read from
+!--          file at the moment.
              IF ( urban_surface )  THEN
                 CALL usm_3d_data_averaging( 'allocate', trimvar )
