Changeset 1764 for palm/trunk/SOURCE

Timestamp:

Feb 28, 2016 12:45:19 PM (8 years ago)

Author:

raasch

Message:

update of the nested domain system + some bugfixes

Location:

palm/trunk/SOURCE

Files:

• Makefile (modified) (6 diffs)
• boundary_conds.f90 (modified) (2 diffs)
• check_parameters.f90 (modified) (5 diffs)
• header.f90 (modified) (6 diffs)
• init_3d_model.f90 (modified) (2 diffs)
• init_pegrid.f90 (modified) (7 diffs)
• local_stop.f90 (modified) (3 diffs)
• message.f90 (modified) (9 diffs)
• modules.f90 (modified) (2 diffs)
• palm.f90 (modified) (4 diffs)
• parin.f90 (modified) (5 diffs)
• pmc_client.f90 (modified) (7 diffs)
• pmc_general.f90 (modified) (6 diffs)
• pmc_handle_communicator.f90 (modified) (6 diffs)
• pmc_interface.f90 (modified) (83 diffs)
• pmc_mpi_wrapper.f90 (modified) (6 diffs)
• pmc_server.f90 (modified) (9 diffs)
• time_integration.f90 (modified) (8 diffs)

palm/trunk/SOURCE/Makefile

@@ -20 +20 @@
 # Current revisions:
 # ------------------
-#
+# update dependency of check_parameters, header, local_stop,
+# pmc_handle_communicator
 # 
 # Former revisions:
@@ -327 +328 @@
 check_for_restart.o: modules.o mod_kinds.o
 check_open.o: modules.o mod_kinds.o mod_particle_attributes.o
-check_parameters.o: modules.o mod_kinds.o subsidence.o land_surface_model.o\
-        plant_canopy_model.o radiation_model.o
+check_parameters.o: modules.o mod_kinds.o land_surface_model.o\
+        plant_canopy_model.o pmc_interface.o radiation_model.o subsidence.o
 close_file.o: modules.o mod_kinds.o
 compute_vpt.o: modules.o mod_kinds.o
@@ -363 +364 @@
 global_min_max.o: modules.o mod_kinds.o
 header.o: modules.o cpulog.o mod_kinds.o land_surface_model.o\
-          plant_canopy_model.o radiation_model.o subsidence.o 
+          plant_canopy_model.o pmc_interface.o radiation_model.o subsidence.o 
 impact_of_latent_heat.o: modules.o mod_kinds.o
 inflow_turbulence.o: modules.o cpulog.o mod_kinds.o
@@ -385 +386 @@
 local_flush.o: mod_kinds.o
 local_getenv.o: modules.o mod_kinds.o
-local_stop.o: modules.o mod_kinds.o
+local_stop.o: modules.o mod_kinds.o pmc_interface.o
 local_tremain.o: modules.o cpulog.o mod_kinds.o
 local_tremain_ini.o: modules.o cpulog.o mod_kinds.o
@@ -419 +420 @@
 lpm_write_restart_file.o: modules.o mod_kinds.o mod_particle_attributes.o
 ls_forcing.o: modules.o cpulog.o mod_kinds.o
-message.o: modules.o mod_kinds.o
+message.o: modules.o mod_kinds.o pmc_interface.o
 microphysics.o: modules.o cpulog.o mod_kinds.o
 modules.o: modules.f90 mod_kinds.o
@@ -430 +431 @@
 palm.o: modules.o cpulog.o ls_forcing.o mod_kinds.o nudging.o\
         pmc_interface.o surface_layer_fluxes.o
-parin.o: modules.o cpulog.o mod_kinds.o progress_bar.o
+parin.o: modules.o cpulog.o mod_kinds.o pmc_interface.o progress_bar.o
 plant_canopy_model.o: modules.o mod_kinds.o
 pmc_interface.o: modules.o mod_kinds.o pmc_client.o pmc_general.o\
         pmc_handle_communicator.o pmc_mpi_wrapper.o pmc_server.o
-pmc_client.o: pmc_general.o pmc_handle_communicator.o pmc_mpi_wrapper.o
-pmc_handle_communicator.o: pmc_general.o
+pmc_client.o: mod_kinds.o pmc_general.o pmc_handle_communicator.o\
+   pmc_mpi_wrapper.o
+pmc_general.o: mod_kinds.o
+pmc_handle_communicator.o: modules.o mod_kinds.o pmc_general.o
 pmc_mpi_wrapper.o: pmc_handle_communicator.o
 pmc_server.o: pmc_general.o pmc_handle_communicator.o pmc_mpi_wrapper.o

palm/trunk/SOURCE/boundary_conds.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! index bug for u_p at left outflow removed
 !
 ! Former revisions:
@@ -820 +820 @@
 !--       Top boundary at the outflow
           IF ( ibc_uv_t == 0 )  THEN
-             u_p(nzt+1,:,-1) = u_init(nzt+1)
+             u_p(nzt+1,:,0)  = u_init(nzt+1)
              v_p(nzt+1,:,-1) = v_init(nzt+1)
           ELSE
-             u_p(nzt+1,:,-1) = u_p(nzt,:,-1)
+             u_p(nzt+1,:,0)  = u_p(nzt,:,0)
              v_p(nzt+1,:,-1) = v_p(nzt,:,-1)
           ENDIF

palm/trunk/SOURCE/check_parameters.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! output of nest id in run description header,
+! bugfix: check of validity of lateral boundary conditions moved to parin
 ! 
 ! Former revisions:
@@ -312 +313 @@
     USE pegrid
     USE plant_canopy_model_mod
+    USE pmc_interface,                                                         &
+        ONLY:  cpl_id, nested_run
     USE profil_parameter
     USE radiation_model_mod
@@ -328 +331 @@
     CHARACTER (LEN=8)   ::  date                     !< 
     CHARACTER (LEN=10)  ::  time                     !< 
+    CHARACTER (LEN=10)  ::  ensemble_string          !<
+    CHARACTER (LEN=15)  ::  nest_string              !<
     CHARACTER (LEN=40)  ::  coupling_string          !< 
     CHARACTER (LEN=100) ::  action                   !< 
@@ -583 +588 @@
     ELSEIF ( coupling_mode == 'ocean_to_atmosphere' )  THEN
        coupling_string = ' coupled (ocean)'
-    ENDIF       
-
+    ENDIF
     IF ( ensemble_member_nr /= 0 )  THEN
-       WRITE ( run_description_header,                                         &
-                  '(A,2X,A,2X,A,A,A,I2.2,A,2X,A,I2.2,2X,A,A,2X,A,1X,A)' )      &
-              TRIM( version ), TRIM( revision ), 'run: ',                      &
-              TRIM( run_identifier ), '.', runnr, TRIM( coupling_string ),     &
-              'en-no: ', ensemble_member_nr,'host: ', TRIM( host ),            &
-              run_date, run_time
+       WRITE( ensemble_string, '(2X,A,I2.2)' )  'en-no: ', ensemble_member_nr
     ELSE
-       WRITE ( run_description_header,                                         &
-                  '(A,2X,A,2X,A,A,A,I2.2,A,2X,A,A,2X,A,1X,A)' )                &
-              TRIM( version ), TRIM( revision ), 'run: ',                      &
-              TRIM( run_identifier ), '.', runnr, TRIM( coupling_string ),     &
-              'host: ', TRIM( host ), run_date, run_time
-    ENDIF
+       ensemble_string = ''
+    ENDIF
+    IF ( nested_run )  THEN
+       WRITE( nest_string, '(2X,A,I2.2)' )  'nest-id: ', cpl_id
+    ELSE
+       nest_string = ''
+    ENDIF
+
+    WRITE ( run_description_header,                                            &
+            '(A,2X,A,2X,A,A,A,I2.2,A,A,A,2X,A,A,2X,A,1X,A)' )                  &
+          TRIM( version ), TRIM( revision ), 'run: ',                          &
+          TRIM( run_identifier ), '.', runnr, TRIM( coupling_string ),         &
+          TRIM( nest_string ), TRIM( ensemble_string), 'host: ', TRIM( host ), &
+          run_date, run_time
+
 !
 !-- Check the general loop optimization method
@@ -1756 +1764 @@
 !
 !-- Check boundary conditions and set internal variables:
-!-- Lateral boundary conditions
-    IF ( bc_lr /= 'cyclic'  .AND.  bc_lr /= 'dirichlet/radiation'  .AND. &
-         bc_lr /= 'radiation/dirichlet'  .AND.  bc_lr /= 'nested' )  THEN
-       message_string = 'unknown boundary condition: bc_lr = "' // &
-                        TRIM( bc_lr ) // '"'
-       CALL message( 'check_parameters', 'PA0049', 1, 2, 0, 6, 0 )
-    ENDIF
-    IF ( bc_ns /= 'cyclic'  .AND.  bc_ns /= 'dirichlet/radiation'  .AND. &
-         bc_ns /= 'radiation/dirichlet'  .AND.  bc_ns /= 'nested' )  THEN
-       message_string = 'unknown boundary condition: bc_ns = "' // &
-                        TRIM( bc_ns ) // '"'
-       CALL message( 'check_parameters', 'PA0050', 1, 2, 0, 6, 0 )
-    ENDIF
-
-!
-!-- Internal variables used for speed optimization in if clauses
-    IF ( bc_lr /= 'cyclic' )               bc_lr_cyc    = .FALSE.
-    IF ( bc_lr == 'dirichlet/radiation' )  bc_lr_dirrad = .TRUE.
-    IF ( bc_lr == 'radiation/dirichlet' )  bc_lr_raddir = .TRUE.
-    IF ( bc_ns /= 'cyclic' )               bc_ns_cyc    = .FALSE.
-    IF ( bc_ns == 'dirichlet/radiation' )  bc_ns_dirrad = .TRUE.
-    IF ( bc_ns == 'radiation/dirichlet' )  bc_ns_raddir = .TRUE.
-
+!-- Attention: the lateral boundary conditions have been already checked in
+!-- parin
 !
 !-- Non-cyclic lateral boundaries require the multigrid method and Piascek-

palm/trunk/SOURCE/header.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! output of nesting informations
 !
 ! Former revisions:
@@ -205 +205 @@
 ! Description:
 ! ------------
-!> Writing a header with all important information about the actual run.
+!> Writing a header with all important information about the current run.
 !> This subroutine is called three times, two times at the beginning 
 !> (writing information on files RUN_CONTROL and HEADER) and one time at the
@@ -269 +269 @@
                plant_canopy
 
+    USE pmc_interface,                                                         &
+        ONLY:  cpl_id, cpl_parent_id, cpl_name, lower_left_coord_x,            &
+               lower_left_coord_y, nested_run, nesting_mode
+
     USE radiation_model_mod,                                                   &
         ONLY:  albedo, albedo_type, albedo_type_name, constant_albedo,         &
@@ -366 +370 @@
 !-- Determine kind of model run
     IF ( TRIM( initializing_actions ) == 'read_restart_data' )  THEN
-       run_classification = '3D - restart run'
+       run_classification = 'restart run'
     ELSEIF ( TRIM( initializing_actions ) == 'cyclic_fill' )  THEN
-       run_classification = '3D - run with cyclic fill of 3D - prerun data'
+       run_classification = 'run with cyclic fill of 3D - prerun data'
     ELSEIF ( INDEX( initializing_actions, 'set_constant_profiles' ) /= 0 )  THEN
-       run_classification = '3D - run without 1D - prerun'
+       run_classification = 'run without 1D - prerun'
     ELSEIF ( INDEX( initializing_actions, 'set_1d-model_profiles' ) /= 0 )  THEN
-       run_classification = '3D - run with 1D - prerun'
+       run_classification = 'run with 1D - prerun'
     ELSEIF ( INDEX( initializing_actions, 'by_user' ) /=0 )  THEN
-       run_classification = '3D - run initialized by user'
+       run_classification = 'run initialized by user'
     ELSE
        message_string = ' unknown action(s): ' // TRIM( initializing_actions )
        CALL message( 'header', 'PA0191', 0, 0, 0, 6, 0 )
     ENDIF
+    IF ( nested_run )  run_classification = 'nested ' // run_classification
     IF ( ocean )  THEN
        run_classification = 'ocean - ' // run_classification
@@ -444 +449 @@
     IF ( num_acc_per_node /= 0 )  WRITE ( io, 120 )  num_acc_per_node
 #endif
+
+!
+!-- Nesting informations
+    IF ( nested_run )  THEN
+       WRITE ( io, 600 )  cpl_id, TRIM( cpl_name ), cpl_parent_id,             &
+                          nesting_mode, lower_left_coord_x, lower_left_coord_y
+    ENDIF
     WRITE ( io, 99 )
 
@@ -2399 +2411 @@
 513 FORMAT (' --> Scalar advection via Wicker-Skamarock-Scheme 5th order ' // & 
             '+ monotonic adjustment')
-
+600 FORMAT (/' Nesting informations:'/                                        &
+            ' Nest id / name:                   ',I2.2,' / ',A,' (parent id: ',I2.2,')'/ &
+            ' Nesting mode:                     ',A/ &
+            ' Lower left corner coordinates:    ','x = ',F8.2,' m, y = ',F8.2,' m'/)
 
  END SUBROUTINE header

palm/trunk/SOURCE/init_3d_model.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-! 
+! bugfix: increase size of volume_flow_area_l and volume_flow_initial_l by 1
 !
 ! Former revisions:
@@ -302 +302 @@
     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  ngp_2dh_s_inner_l  !<
 
-    REAL(wp), DIMENSION(1:2) ::  volume_flow_area_l     !<
-    REAL(wp), DIMENSION(1:2) ::  volume_flow_initial_l  !<
+    REAL(wp), DIMENSION(1:3) ::  volume_flow_area_l     !<
+    REAL(wp), DIMENSION(1:3) ::  volume_flow_initial_l  !<
 
     REAL(wp), DIMENSION(:), ALLOCATABLE ::  mean_surface_level_height_l    !<

palm/trunk/SOURCE/init_pegrid.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-!
+! cpp-statements for nesting removed
 ! 
 ! Former revisions:
@@ -151 +151 @@
     USE pegrid
  
-#if defined( PMC_ACTIVE )
     USE pmc_interface,                                                         &
-        ONLY:  cpl_npex,cpl_npey
-#endif
+        ONLY:  cpl_npex, cpl_npey, nested_run
 
     USE transpose_indices,                                                     &
@@ -215 +213 @@
     CALL location_message( 'creating virtual PE grids + MPI derived data types', &
                            .FALSE. )
-#if defined( PMC_ACTIVE )
-!
-!-- In case of nested-domain runs, the processor grid is explicitly given
-!-- by the user in the nestpar-NAMELIST
-    pdims(1) = cpl_npex
-    pdims(2) = cpl_npey
-#else
-!
-!-- Determine the processor topology or check it, if prescribed by the user
-    IF ( npex == -1  .AND.  npey == -1 )  THEN
-
-!
-!--    Automatic determination of the topology
-       numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
-       pdims(1)    = MAX( numproc_sqr , 1 )
-       DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
-          pdims(1) = pdims(1) - 1
-       ENDDO
-       pdims(2) = numprocs / pdims(1)
-
-    ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
-
-!
-!--    Prescribed by user. Number of processors on the prescribed topology
-!--    must be equal to the number of PEs available to the job
-       IF ( ( npex * npey ) /= numprocs )  THEN
-          WRITE( message_string, * ) 'number of PEs of the prescribed ',      & 
+
+    IF ( nested_run )  THEN
+!
+!--    In case of nested-domain runs, the processor grid is explicitly given
+!--    by the user in the nestpar-NAMELIST
+       pdims(1) = cpl_npex
+       pdims(2) = cpl_npey
+
+    ELSE
+!
+!--    Determine the processor topology or check it, if prescribed by the user
+       IF ( npex == -1  .AND.  npey == -1 )  THEN
+
+!
+!--       Automatic determination of the topology
+          numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
+          pdims(1)    = MAX( numproc_sqr , 1 )
+          DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
+             pdims(1) = pdims(1) - 1
+          ENDDO
+          pdims(2) = numprocs / pdims(1)
+
+       ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
+
+!
+!--       Prescribed by user. Number of processors on the prescribed topology
+!--       must be equal to the number of PEs available to the job
+          IF ( ( npex * npey ) /= numprocs )  THEN
+             WRITE( message_string, * ) 'number of PEs of the prescribed ',   &
                  'topology (', npex*npey,') does not match & the number of ', & 
                  'PEs available to the job (', numprocs, ')'
-          CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
-       ENDIF
-       pdims(1) = npex
-       pdims(2) = npey
-
-    ELSE
-!
-!--    If the processor topology is prescribed by the user, the number of
-!--    PEs must be given in both directions
-       message_string = 'if the processor topology is prescribed by the, ' //  &
-                   ' user& both values of "npex" and "npey" must be given ' // &
-                   'in the &NAMELIST-parameter file'
-       CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
-
-    ENDIF
-#endif
+             CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
+          ENDIF
+          pdims(1) = npex
+          pdims(2) = npey
+
+       ELSE
+!
+!--       If the processor topology is prescribed by the user, the number of
+!--       PEs must be given in both directions
+          message_string = 'if the processor topology is prescribed by th' //  &
+                   'e user& both values of "npex" and "npey" must be given' // &
+                   ' in the &NAMELIST-parameter file'
+          CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    ENDIF
+
 
 !
@@ -1082 +1084 @@
        ELSEIF ( bc_lr == 'radiation/dirichlet' )  THEN
           outflow_l = .TRUE.
-#if defined( PMC_ACTIVE )
        ELSEIF ( bc_lr == 'nested' )  THEN
           nest_bound_l = .TRUE.
-#endif
        ENDIF
     ENDIF
@@ -1094 +1094 @@
        ELSEIF ( bc_lr == 'radiation/dirichlet' )  THEN
           inflow_r  = .TRUE.
-#if defined( PMC_ACTIVE )
        ELSEIF ( bc_lr == 'nested' )  THEN
           nest_bound_r = .TRUE.
-#endif
        ENDIF
     ENDIF
@@ -1106 +1104 @@
        ELSEIF ( bc_ns == 'radiation/dirichlet' )  THEN
           inflow_s  = .TRUE.
-#if defined( PMC_ACTIVE )
        ELSEIF ( bc_ns == 'nested' )  THEN
           nest_bound_s = .TRUE.
-#endif
        ENDIF
     ENDIF
@@ -1118 +1114 @@
        ELSEIF ( bc_ns == 'radiation/dirichlet' )  THEN
           outflow_n = .TRUE.
-#if defined( PMC_ACTIVE )
        ELSEIF ( bc_ns == 'nested' )  THEN
           nest_bound_n = .TRUE.
-#endif
        ENDIF
     ENDIF

palm/trunk/SOURCE/local_stop.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! abort with MPI_COMM_WORLD added, nested runs always abort with MPI_ABORT
 ! 
 ! Former revisions:
@@ -55 +55 @@
  
 
-    USE pegrid
-    
     USE control_parameters,                                                    &
         ONLY:  abort_mode, coupling_mode, coupling_mode_remote, dt_restart,    &
@@ -62 +60 @@
                terminate_run, time_restart
 
+    USE pegrid
+
+    USE pmc_interface,                                                         &
+        ONLY:  nested_run
 
 #if defined( __parallel ) && ! defined ( __check )
     IF ( coupling_mode == 'uncoupled' )  THEN
-       IF ( abort_mode == 1 )  THEN
-          CALL MPI_FINALIZE( ierr )
-          STOP
-       ELSEIF ( abort_mode == 2 )  THEN
-          CALL MPI_ABORT( comm2d, 9999, ierr )
+       IF ( nested_run )  THEN
+!
+!--       Workaround: If any of the nested model crashes, it aborts the whole
+!--       run with MPI_ABORT, regardless of the reason given by abort_mode
+          CALL MPI_ABORT( MPI_COMM_WORLD, 9999, ierr )
+       ELSE
+          IF ( abort_mode == 1 )  THEN
+             CALL MPI_FINALIZE( ierr )
+             STOP
+          ELSEIF ( abort_mode == 2 )  THEN
+             CALL MPI_ABORT( comm2d, 9999, ierr )
+          ELSEIF ( abort_mode == 3 )  THEN
+             CALL MPI_ABORT( MPI_COMM_WORLD, 9999, ierr )
+          ENDIF
        ENDIF
     ELSE

palm/trunk/SOURCE/message.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! nest id added to header string, add linefeed to stdout to get messages better
+! seperatedvfrom the location messages,
+! in case of nested runs, location messages are given only by the root domain
 ! 
 ! Former revisions:
@@ -55 +57 @@
 !> Meaning of formal parameters:
 !> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort
+!>                   3 - abort by mpi_abort using MPI_COMM_WORLD
 !> message_level: 0 - informative, 1 - warning, 2 - error
 !> output_on_pe: -1 - all, else - output on specified PE
@@ -63 +66 @@
                      message_level, output_on_pe, file_id, flush )
  
-
     USE control_parameters,                                                    &
         ONLY:  abort_mode, message_string
@@ -71 +73 @@
     USE pegrid
 
+    USE pmc_interface,                                                         &
+        ONLY:  cpl_id, nested_run
+
     IMPLICIT NONE
 
     CHARACTER(LEN=6)   ::  message_identifier            !<
+    CHARACTER(LEN=20)  ::  nest_string                   !< nest id information
     CHARACTER(LEN=*)   ::  routine_name                  !<
     CHARACTER(LEN=200) ::  header_string                 !<
@@ -94 +100 @@
 
 !
+!-- In case of nested runs create the nest id informations
+    IF ( nested_run )  THEN
+       WRITE( nest_string, '(1X,A,I2.2)' )  'from nest-id ', cpl_id
+    ELSE
+       nest_string = ''
+    ENDIF
+!
 !-- Create the complete output string, starting with the message level
     IF ( message_level == 0 )  THEN
-       header_string = '--- informative message ---  ID:'
+       header_string = '--- informative message' // TRIM(nest_string) //       &
+                       ' ---  ID:'
     ELSEIF ( message_level == 1 )  THEN
-       header_string = '+++ warning message ---  ID:'
+       header_string = '+++ warning message' // TRIM(nest_string) // ' ---  ID:'
     ELSEIF ( message_level == 2 )  THEN
-       header_string = '+++ error message ---  ID:'
+       header_string = '+++ error message' // TRIM(nest_string) // ' ---  ID:'
     ELSE
-       WRITE( header_string,'(A,I2)' )  '+++ unknown message level: ', &
+       WRITE( header_string,'(A,I2)' )  '+++ unknown message level' //         &
+                                        TRIM(nest_string) // ': ',             &
                                         message_level
     ENDIF
@@ -118 +133 @@
        information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc' // &
                               '/app/errmsg#' // message_identifier
-    END IF
+    ENDIF
     
 
@@ -147 +162 @@
 !
 !--       Output on stdout
-          WRITE( *, '(A/)' )  TRIM( header_string )
+          WRITE( *, '(//A/)' )  TRIM( header_string )
 !
 !--       Cut message string into pieces and output one piece per line.
@@ -219 +234 @@
 
     USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
-        ONLY :  OUTPUT_UNIT
+        ONLY:  OUTPUT_UNIT
 
     USE pegrid,                                                                &
-        ONLY :  myid
+        ONLY:  myid
+
+    USE pmc_interface,                                                         &
+        ONLY:  cpl_id
 
     IMPLICIT NONE
@@ -229 +247 @@
     LOGICAL          ::  advance  !< switch for advancing/noadvancing I/O
 
+!
+!-- Output for nested runs only on the root domain
+    IF ( cpl_id /= 1 )  RETURN
 
     IF ( myid == 0 )  THEN

palm/trunk/SOURCE/modules.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-! 
+! some reformatting
 !
 ! Former revisions:
@@ -713 +713 @@
                 lunudge = .FALSE., lvnudge = .FALSE., lwnudge = .FALSE., &
                 masking_method = .FALSE., mg_switch_to_pe0 = .FALSE., &
-                monotonic_adjustment = .FALSE., &
-                nest_bound_l = .FALSE., nest_bound_n = .FALSE., &
-                nest_bound_r = .FALSE., nest_bound_s = .FALSE., &
-                nest_domain = .FALSE., &
-                neutral = .FALSE., nudging = .FALSE., &
+                monotonic_adjustment = .FALSE.
+    LOGICAL ::  nest_bound_l = .FALSE. !< nested boundary on left side
+    LOGICAL ::  nest_bound_n = .FALSE. !< nested boundary on north side
+    LOGICAL ::  nest_bound_r = .FALSE. !< nested boundary on right side
+    LOGICAL ::  nest_bound_s = .FALSE. !< nested boundary on south side
+    LOGICAL ::  nest_domain  = .FALSE. !< domain is nested into a parent domain
+    LOGICAL ::  neutral = .FALSE., nudging = .FALSE., &
                 ocean = .FALSE., on_device = .FALSE., &
                 outflow_l = .FALSE., outflow_n = .FALSE., outflow_r = .FALSE., &

palm/trunk/SOURCE/palm.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-!
+! cpp-statements for nesting removed, communicator settings cleaned up
 !
 ! Former revisions:
@@ -148 +148 @@
     USE pegrid
 
-#if defined( PMC_ACTIVE )
     USE pmc_interface,                                                         &
-        ONLY:  cpl_id, pmci_init, pmci_modelconfiguration
-#endif
+        ONLY:  cpl_id, nested_run, pmci_init, pmci_modelconfiguration
 
     USE statistics,                                                            &
@@ -185 +183 @@
     CALL MPI_INIT( ierr )
 
-#if defined( PMC_ACTIVE )
 !
 !-- Initialize the coupling for nested-domain runs
+!-- comm_palm is the communicator which includes all PEs (MPI processes)
+!-- available for this (nested) model. If it is not a nested run, comm_palm
+!-- is returned as MPI_COMM_WORLD
     CALL pmci_init( comm_palm )
     comm2d = comm_palm
-
-    IF ( cpl_id >= 2 )  THEN
-       nest_domain = .TRUE.
-       WRITE( coupling_char, '(A1,I1.1)') '_', cpl_id
-    ENDIF
-
-    CALL MPI_COMM_SIZE( comm_palm, numprocs, ierr )
-    CALL MPI_COMM_RANK( comm_palm, myid, ierr )
-#else
-    CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
-    CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
-    comm_palm = MPI_COMM_WORLD
-    comm2d    = MPI_COMM_WORLD
-!
-!-- Initialize PE topology in case of coupled atmosphere-ocean runs (comm_palm
-!-- will be splitted in init_coupling)
-    CALL init_coupling
-#endif
+!
+!-- Get the (preliminary) number of MPI processes and the local PE-id (in case
+!-- of a further communicator splitting in init_coupling, these numbers will
+!-- be changed in init_pegrid).
+    IF ( nested_run )  THEN
+!--    TO_DO: move the following two settings somewehere to the pmc_interface
+       IF ( cpl_id >= 2 )  THEN
+          nest_domain = .TRUE.
+          WRITE( coupling_char, '(A1,I1.1)') '_', cpl_id
+       ENDIF
+
+       CALL MPI_COMM_SIZE( comm_palm, numprocs, ierr )
+       CALL MPI_COMM_RANK( comm_palm, myid, ierr )
+
+    ELSE
+
+       CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
+       CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
+!
+!--    Initialize PE topology in case of coupled atmosphere-ocean runs (comm_palm
+!--    will be splitted in init_coupling)
+       CALL init_coupling
+    ENDIF
 #endif
 
@@ -316 +321 @@
     CALL init_3d_model
 
-#if defined( PMC_ACTIVE )
 !
 !-- Coupling protocol setup for nested-domain runs
-    CALL pmci_modelconfiguration
-#endif
+    IF ( nested_run )  THEN
+       CALL pmci_modelconfiguration
+    ENDIF
 
 !

palm/trunk/SOURCE/parin.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-!
+! cpp-statements for nesting removed, explicit settings of boundary conditions
+! in nest domains,
+! bugfix: npex/npey message moved from inipar to d3par
+! bugfix: check of lateral boundary conditions from check_parameters to here,
+! because they will be already used in init_pegrid and init_grid
 ! 
 ! Former revisions:
@@ -193 +197 @@
         ONLY:  nx, ny, nz
 
+    USE kinds
+
     USE model_1d,                                                              &
         ONLY:  damp_level_1d, dt_pr_1d, dt_run_control_1d, end_time_1d
 
     USE pegrid
+
+    USE pmc_interface,                                                         &
+        ONLY:  nested_run
 
     USE profil_parameter,                                                      &
@@ -345 +354 @@
           READ ( 11, inipar, ERR=10, END=11 )
 
-#if defined ( PMC_ACTIVE )
-!
-!--       In nested domains, npex or npey must not be given in \$inipar
-!--       because here the PE-grids are always defined in the nestpar-NAMELIST
-          IF ( ( npex /= -1 ) .OR. ( npey /= -1 ) )  THEN
-             message_string = 'npex or npey must not be given in \$inipar ' // &
-                              'in nested domains'
-             CALL message( 'parin', 'PAXXXX', 1, 2, 0, 6, 0 )
-          ENDIF
-#else
-!
-!--       Make sure that no nesting boundary conditions are defined if
-!--       PMC_ACTIVE is not defined. Otherwise initiate abort.
-          IF ( ( bc_lr == 'nested' ) .OR. ( bc_ns == 'nested' ) .OR. ( bc_uv_t == 'nested' ) .OR. &
-               ( bc_pt_t ==  'nested' ) .OR. ( bc_q_t == 'nested') .OR. ( bc_sa_t == 'nested') .OR. &
-               ( bc_p_t == 'nested' ) ) THEN
-             message_string = 'Nested boundary conditions are not allowed ' // &
-                              'since the cpp flag PMC_ACTIVE is not set'
-             CALL message( 'parin', 'PAXXXX', 1, 2, 0, 6, 0 )
-          ENDIF
-#endif
-
 #if defined ( __check )
 !
@@ -406 +393 @@
 
 !
+!--       In case of nested runs, explicitly set nesting boundary conditions
+!--       except for the root domain. This will overwrite the user settings.
+          IF ( nest_domain )  THEN
+             bc_lr   = 'nested'
+             bc_ns   = 'nested'
+             bc_uv_t = 'nested'
+             bc_pt_t = 'nested'
+             bc_p_t  = 'neumann'
+          ENDIF
+!
+!--       Check validity of lateral boundary conditions. This has to be done
+!--       here because they are already used in init_pegrid and init_grid and
+!--       therefore cannot be check in check_parameters
+          IF ( bc_lr /= 'cyclic'  .AND.  bc_lr /= 'dirichlet/radiation'  .AND. &
+               bc_lr /= 'radiation/dirichlet'  .AND.  bc_lr /= 'nested' )  THEN
+             message_string = 'unknown boundary condition: bc_lr = "' // &
+                              TRIM( bc_lr ) // '"'
+             CALL message( 'check_parameters', 'PA0049', 1, 2, 0, 6, 0 )
+          ENDIF
+          IF ( bc_ns /= 'cyclic'  .AND.  bc_ns /= 'dirichlet/radiation'  .AND. &
+               bc_ns /= 'radiation/dirichlet'  .AND.  bc_ns /= 'nested' )  THEN
+             message_string = 'unknown boundary condition: bc_ns = "' // &
+                              TRIM( bc_ns ) // '"'
+             CALL message( 'check_parameters', 'PA0050', 1, 2, 0, 6, 0 )
+          ENDIF
+
+!
+!--       Set internal variables used for speed optimization in if clauses
+          IF ( bc_lr /= 'cyclic' )               bc_lr_cyc    = .FALSE.
+          IF ( bc_lr == 'dirichlet/radiation' )  bc_lr_dirrad = .TRUE.
+          IF ( bc_lr == 'radiation/dirichlet' )  bc_lr_raddir = .TRUE.
+          IF ( bc_ns /= 'cyclic' )               bc_ns_cyc    = .FALSE.
+          IF ( bc_ns == 'dirichlet/radiation' )  bc_ns_dirrad = .TRUE.
+          IF ( bc_ns == 'radiation/dirichlet' )  bc_ns_raddir = .TRUE.
+
+!
 !--       Definition of names of areas used for computing statistics. They must
 !--       be defined at this place, because they are allowed to be redefined by
@@ -416 +439 @@
 !--       values are used for the parameters.
           READ ( 11, d3par, END=20 )
+
+          IF ( nested_run )  THEN
+!
+!--          In nested domains, npex or npey can not be given in the d3par-
+!--          NAMELIST because here the PE-grids are always defined in the
+!--          nestpar-NAMELIST. Settings will be ignored.
+             IF ( ( npex /= -1 ) .OR. ( npey /= -1 ) )  THEN
+                message_string = 'npex or npey can not be given in \$d3par ' // &
+                                 'for nested runs & they will be ignored'
+                CALL message( 'parin', 'PA0352', 0, 1, 0, 6, 0 )
+             ENDIF
+          ENDIF
 
 !

palm/trunk/SOURCE/pmc_client.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! cpp-statement added (nesting can only be used in parallel mode),
+! all kinds given in PALM style
 !
 ! Former revisions:
@@ -35 +36 @@
 !------------------------------------------------------------------------------!
 
+#if defined( __parallel )
 
     use, intrinsic :: iso_c_binding
 
-    USE  mpi
-    USE  kinds,         ONLY: wp, iwp
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
+    USE  kinds
     USE  PMC_general,   ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
                                          DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_G_GetName
@@ -51 +57 @@
 !   data local to this MODULE
     Type(ClientDef)                       :: me
-    INTEGER, PARAMETER                    :: dp = wp
+!-- TO_DO: what is the meaning of this? Could variables declared in this module
+!--        also have single precision?
+!    INTEGER, PARAMETER                    :: dp = wp
 
     INTEGER, save                         :: myIndex = 0                !Counter and unique number for Data Arrays
@@ -310 +318 @@
     SUBROUTINE PMC_C_Set_DataArray_2d (array)
        IMPLICIT none
+!--    TO_DO: is double precision absolutely required here?
        REAL(kind=dp),INTENT(IN),DIMENSION(:,:)    :: array
        !-- local variables
@@ -344 +353 @@
     SUBROUTINE PMC_C_Set_DataArray_3d (array)
        IMPLICIT none
+!--    TO_DO: is double precision absolutely required here?
        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
        !-- local variables
@@ -377 +387 @@
 
    SUBROUTINE PMC_C_setInd_and_AllocMem
+
       IMPLICIT none
 
       INTEGER                                 :: i, ierr
       INTEGER                                 :: arlen, myIndex, tag
-      INTEGER(kind=8)                         :: bufsize                   ! Size of MPI data Window
+      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
       TYPE(PeDef),POINTER                     :: aPE
       TYPE(ArrayDef),POINTER                  :: ar
@@ -574 +585 @@
     END SUBROUTINE PMC_C_PutBuffer
 
-
-! Private SUBROUTINEs
-
+#endif
 END MODULE pmc_client

palm/trunk/SOURCE/pmc_general.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! cpp-statement added (nesting can only be used in parallel mode),
+! all kinds given in PALM style
 !
 ! Former revisions:
@@ -35 +36 @@
 !------------------------------------------------------------------------------!
 
-
+#if defined( __parallel )
    use, intrinsic :: iso_c_binding
-   USE            :: MPI
+
+   USE kinds
+
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
 
    IMPLICIT none
@@ -65 +73 @@
       INTEGER                       :: dim_order                   ! Order of Dimensions: 2 = 2D array, 33 = 3D array
       TYPE (c_ptr)                  :: data                        ! Pointer of data in server space
-      INTEGER(kind=8)               :: BufIndex                    ! index in Send Buffer
+      INTEGER(idp)                  :: BufIndex                    ! index in Send Buffer
       INTEGER                       :: BufSize                     ! size in Send Buffer
       TYPE (c_ptr)                  :: SendBuf                     ! Pointer of Data in Send buffer
@@ -76 +84 @@
 
    TYPE, PUBLIC :: PeDef
-      INTEGER(KIND=8)                     :: NrEle                 ! Number of Elemets
+      INTEGER(idp)                        :: NrEle                 ! Number of Elemets
       TYPE (xy_ind), POINTER,DIMENSION(:) :: locInd                ! xy index local array for remote PE
       TYPE( ArrayDef), POINTER            :: Arrays                ! Pointer to Data Array List (Type ArrayDef)
@@ -83 +91 @@
 
    TYPE, PUBLIC :: ClientDef
-      INTEGER(KIND=8)               :: TotalBufferSize
+      INTEGER(idp)                  :: TotalBufferSize
       INTEGER                       :: model_comm                  ! Communicator of this model
       INTEGER                       :: inter_comm                  ! Inter communicator model and client
@@ -258 +266 @@
     END FUNCTION DA_List_next
 
+#endif
 end MODULE pmc_general

palm/trunk/SOURCE/pmc_handle_communicator.f90

@@ -1 @@
-MODULE PMC_handle_communicator
-
+ MODULE PMC_handle_communicator
 
 !--------------------------------------------------------------------------------!
@@ -21 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! pmc_layout type: comm_cpl and comm_parent removed, character "name" moved at
+! the beginning of the variable list,
+! domain layout is read with new NAMELIST nestpar from standard file PARIN,
+! MPI-datatype REAL8 replaced by REAL, kind=8 replaced by wp,
+! variable domain_layouts instead of m_couplers introduced for this NAMELIST,
+! general format changed to PALM style
 !
 ! Former revisions:
@@ -30 +34 @@
 ! Initial revision by K. Ketelsen
 !
-! Intoduction of the pure FORTRAN Palm Model Coupler     (PMC)  12.11.2015  K. Ketelsen
-!
 ! Description:
 ! ------------
-!
-! Handle MPI Communicator in Palm Model Coupler
+! Handle MPI communicator in PALM model coupler
 !------------------------------------------------------------------------------!
 
-   USE      mpi
-   USE      pmc_general,                        &
-      ONLY: PMC_STATUS_OK, PMC_STATUS_ERROR, PMC_MAX_MODELL
-
-   IMPLICIT none
-
-   ! Define Types
-
-   type PMC_layout
-      INTEGER                         :: comm_parent
-      INTEGER                         :: comm_cpl
-      INTEGER                         :: Id
-      INTEGER                         :: Parent_id
-
-      INTEGER                         :: npe_x
-      INTEGER                         :: npe_y
-
-      REAL(kind=8)                    :: lower_left_x
-      REAL(kind=8)                    :: lower_left_y
-
-      CHARACTER(len=32)               :: name
-   END type PMC_layout
-
-   ! return status
-   PUBLIC                               PMC_STATUS_OK, PMC_STATUS_ERROR
-   INTEGER,parameter,PUBLIC          :: PMC_ERROR_NPES = 1                       ! illegal Number of PEs
-   INTEGER,parameter,PUBLIC          :: PMC_ERROR_MPI  = 2                       ! MPI Error
-   INTEGER,parameter,PUBLIC          :: PMC_ERRO_NOF   = 3                       ! No couple layout file found
+#if defined( __parallel )
+    USE kinds
+
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
+
+   USE pmc_general,                                                            &
+       ONLY: pmc_status_ok, pmc_status_error, pmc_max_modell
+
+   IMPLICIT NONE
+
+   TYPE pmc_layout
+
+      CHARACTER(len=32) ::  name
+
+      INTEGER  ::  id
+      INTEGER  ::  parent_id
+      INTEGER  ::  npe_x
+      INTEGER  ::  npe_y
+
+      REAL(wp) ::  lower_left_x
+      REAL(wp) ::  lower_left_y
+
+   END TYPE pmc_layout
+
+   PUBLIC  pmc_status_ok, pmc_status_error
+
+   INTEGER, PARAMETER, PUBLIC ::  pmc_error_npes          = 1  ! illegal number of PEs
+   INTEGER, PARAMETER, PUBLIC ::  pmc_namelist_error      = 2  ! error(s) in nestpar namelist
+   INTEGER, PARAMETER, PUBLIC ::  pmc_no_namelist_found   = 3  ! No couple layout file found
 
    ! Coupler Setup
@@ -72 +78 @@
    INTEGER                                    :: m_Parent_id  !Coupler id of parent of this model
    INTEGER                                    :: m_NrOfCpl    !Number of Coupler in layout file
-   type(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all coupler
+   TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all coupler
 
    ! MPI settings
@@ -91 +97 @@
    INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
 
-   !INTERFACE Section
-
-   INTERFACE PMC_is_RootModel
-      MODULE PROCEDURE PMC_is_RootModel
-   END INTERFACE PMC_is_RootModel
+   INTERFACE pmc_is_rootmodel
+      MODULE PROCEDURE pmc_is_rootmodel
+   END INTERFACE pmc_is_rootmodel
 
    INTERFACE PMC_get_local_model_info
@@ -101 +105 @@
    END INTERFACE PMC_get_local_model_info
 
-   PUBLIC PMC_init_model,PMC_get_local_model_info, PMC_is_RootModel
-CONTAINS
-
-   SUBROUTINE PMC_init_model (comm, PMC_status)
-      IMPLICIT     none
-      INTEGER,INTENT(OUT)                 :: comm
-      INTEGER,INTENT(OUT)                 :: PMC_status
-
-      !-- local declarations
-      INTEGER                             :: i,istat, ierr
-      INTEGER,DIMENSION(PMC_MAX_MODELL+1) :: start_PE
-      INTEGER                             :: m_my_CPL_rank
-      INTEGER                             :: tag, ClientCount
-      INTEGER,DIMENSION(PMC_MAX_MODELL)   :: activeServer        !I am active server for this client ID
-
-      PMC_status   = PMC_STATUS_OK
+   PUBLIC pmc_get_local_model_info, pmc_init_model, pmc_is_rootmodel
+
+ CONTAINS
+
+   SUBROUTINE pmc_init_model( comm, nesting_mode, pmc_status )
+
+      USE control_parameters,                                                  &
+          ONLY:  message_string
+
+      USE pegrid,                                                              &
+          ONLY:  myid
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode
+
+      INTEGER, INTENT(OUT)                ::  comm
+      INTEGER, INTENT(OUT)                ::  pmc_status
+
+      INTEGER                             ::  i, ierr, istat
+      INTEGER,DIMENSION(pmc_max_modell+1) ::  start_pe
+      INTEGER                             ::  m_my_cpl_rank
+      INTEGER                             ::  tag, clientcount
+      INTEGER,DIMENSION(pmc_max_modell)   ::  activeserver  ! I am active server for this client ID
+
+      pmc_status   = pmc_status_ok
       comm         = -1
-      m_my_CPL_id  = -1
-      ClientCount  = 0
-      activeServer = -1
-      start_PE(:)  = 0
-
-      CALL  MPI_Comm_rank (MPI_COMM_WORLD, m_world_rank, istat)
-      CALL  MPI_Comm_size (MPI_COMM_WORLD, m_world_npes, istat)
-
-      if(m_world_rank == 0) then ! only PE 0 of root model reads
-
-         CALL read_coupling_layout (PMC_status)
-
-         IF (PMC_status /= PMC_ERRO_NOF  ) THEN
-            ! Compute Start PE of every model
-            start_PE(1) = 0
-            do i=2,m_NrOfCpl+1
-               start_pe(i) = start_PE(i-1) + m_couplers(i-1)%npe_x*m_couplers(i-1)%npe_y
-            END do
-            if(start_pe(m_NrOfCpl+1) /= m_world_npes)   then
-               if(m_world_rank == 0) then
-                  write(0,*) 'PMC ERROR: Coupler Setup Not equal Nr. MPI procs ',start_pe(m_NrOfCpl+1),m_world_npes
-               END if
-               CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
-            END if
-         END IF
-      END if
-
-      CALL MPI_Bcast (PMC_status, 1,          MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-      IF (PMC_status == PMC_ERRO_NOF  ) THEN
-         if(m_world_rank == 0)  write(0,*) 'PMC ERROR: file PMC_couple_layout not found'
-         CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
-      END IF
-
-      CALL MPI_Bcast (m_NrOfCpl, 1,          MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-      CALL MPI_Bcast (start_PE, m_NrOfCpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-
-      !   Broadcast coupling layout
-
-      do i=1,m_NrOfCpl
-         CALL MPI_Bcast (m_couplers(i)%name, len(m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%npe_x,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%npe_y,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%lower_left_x, 1, MPI_REAL8,   0, MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%lower_left_y, 1, MPI_REAL8,   0, MPI_COMM_WORLD, istat)
-      END do
-
-      ! Assign global MPI processes to individual models by setting the couple id
-
-      do i=1,m_NrOfCpl
-         if(m_world_rank >= start_PE(i) .and. m_world_rank < start_PE(i+1) ) then
-            m_my_CPL_id = i
+      m_my_cpl_id  = -1
+      clientcount  =  0
+      activeserver = -1
+      start_pe(:)  =  0
+
+      CALL  MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat )
+      CALL  MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat )
+!
+!--   Only PE 0 of root model reads
+      IF ( m_world_rank == 0 )  THEN
+
+         CALL read_coupling_layout( nesting_mode, pmc_status )
+
+         IF ( pmc_status /= pmc_no_namelist_found  .AND.                       &
+              pmc_status /= pmc_namelist_error )                               &
+         THEN
+!
+!--         Calculate start PE of every model
+            start_pe(1) = 0
+            DO  i = 2, m_nrofcpl+1
+               start_pe(i) = start_pe(i-1) +                                   &
+                             m_couplers(i-1)%npe_x * m_couplers(i-1)%npe_y
+            ENDDO
+
+!
+!--         The number of cores provided with the run must be the same as the
+!--         total sum of cores required by all nest domains
+!--         TO_DO: can we use > instead of /= ?
+            IF ( start_pe(m_nrofcpl+1) /= m_world_npes )  THEN
+!--            TO_DO: this IF statement is redundant
+               IF ( m_world_rank == 0 )  THEN
+                  WRITE ( message_string, '(A,I6,A,I6,A)' )                    &
+                                  'nesting-setup requires more MPI procs (',   &
+                                  start_pe(m_nrofcpl+1), ') than provided (',  &
+                                  m_world_npes,')'
+                  CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
+               ENDIF
+            ENDIF
+
+         ENDIF
+
+      ENDIF
+!
+!--   Broadcast the read status. This synchronises all other PEs with PE 0 of
+!--   the root model. Without synchronisation, they would not behave in the
+!--   correct way (e.g. they would not return in case of a missing NAMELIST)
+      CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+
+      IF ( pmc_status == pmc_no_namelist_found )  THEN
+!
+!--      Not a nested run; return the MPI_WORLD communicator
+         comm = MPI_COMM_WORLD
+         RETURN
+
+      ELSEIF ( pmc_status == pmc_namelist_error )  THEN
+!
+!--      Only the root model gives the error message. Others are aborted by the
+!--      message-routine with MPI_ABORT. Must be done this way since myid and
+!--      comm2d have not yet been assigned at this point.
+         IF ( m_world_rank == 0 )  THEN
+            message_string = 'errors in \$nestpar'
+            CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 )
+         ENDIF
+
+      ENDIF
+
+      CALL MPI_BCAST( m_nrofcpl, 1,          MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
+      CALL MPI_BCAST( start_pe, m_nrofcpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
+
+!
+!--   Broadcast coupling layout
+      DO  i = 1, m_nrofcpl
+         CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%npe_x,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%npe_y,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
+      ENDDO
+
+!
+!--   Assign global MPI processes to individual models by setting the couple id
+      DO  i = 1, m_nrofcpl
+         IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
+         THEN
+            m_my_cpl_id = i
             EXIT
-         END if
-      END do
-      m_my_CPL_rank = m_world_rank-start_PE(i)
-
-      !   MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach)
-      !   The communictors for the individual models a created by MPI_Comm_split
-      !   The color of the model is represented by the Coupler id
-
-      CALL MPI_Comm_split (MPI_COMM_WORLD, m_my_CPL_id, m_my_CPL_rank, comm, istat)
-      if(istat /= MPI_SUCCESS) then
-         if(m_world_rank == 0) write(0,*) 'PMC: Error in MPI_Comm_split '
-         CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
-      END if
-
-      !   Get size and rank of the model running on THIS PE
-
-      CALL  MPI_Comm_rank (comm, m_model_rank, istat)
-      CALL  MPI_Comm_size (comm, m_model_npes, istat)
-
-      !   Pe 0  brodcasts the Parent ID and Id of every model
-
-      do i=1,m_NrOfCpl
-         CALL MPI_Bcast (m_couplers(i)%Parent_Id,  1, MPI_INTEGER, 0,           MPI_COMM_WORLD, istat)
-         CALL MPI_Bcast (m_couplers(i)%Id,         1, MPI_INTEGER, 0,           MPI_COMM_WORLD, istat)
-      END do
-
+         ENDIF
+      ENDDO
+      m_my_cpl_rank = m_world_rank - start_pe(i)
+
+!
+!--   MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach).
+!--   The communictors for the individual models as created by MPI_COMM_SPLIT.
+!--   The color of the model is represented by the coupler id
+      CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,   &
+                           istat )
+      IF ( istat /= MPI_SUCCESS )  THEN
+!
+!--      TO_DO: replace by message-call
+!--      TO_DO: Can this really happen, or is this just for the debugging phase?
+         IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in MPI_Comm_split '
+         CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
+      ENDIF
+
+!
+!--   Get size and rank of the model running on this PE
+      CALL  MPI_COMM_RANK( comm, m_model_rank, istat )
+      CALL  MPI_COMM_SIZE( comm, m_model_npes, istat )
+
+!
+!--   Broadcast (from PE 0) the parent id and id of every model
+      DO  i = 1, m_nrofcpl
+         CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0,           &
+                         MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%id,        1, MPI_INTEGER, 0,           &
+                         MPI_COMM_WORLD, istat )
+      ENDDO
+
+!
+!--   TO_DO: describe what is happening here, and why
       m_model_comm = comm
 
-      !   create Intercommunicator to server and clients
-      !   MPI_Intercomm_create creates an intercommunicator between 2 groups of different colors
-      !   The grouping with done prior with MPI_Comm_split
-
-      do i=2,m_NrOfCpl
-         if(m_couplers(i)%Parent_Id == m_my_CPL_id)   then                         !collect server PEs
-            tag = 500+i
-!kk            write(0,'(a,6i4)') 'server Part ',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag,start_pe(i)
-            CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(i), &
-               tag, m_to_client_comm(i), istat)
-
-            clientCount = clientCount+1
-            activeServer(i) = 1
-         else if (i == m_my_CPL_id)   then                                         !collect client PEs
-            tag = 500+i
-            CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(m_couplers(i)%Parent_Id), &
-               tag, m_to_server_comm, istat)
-!kk            write(0,'(a,7i4)') 'client Part',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag, start_pe(m_couplers(i)%Parent_Id)
-         END if
-         if(istat /= MPI_SUCCESS) then
-            if(m_world_rank == 0) write(0,*) 'PMC: Error in Coupler Setup '
-            CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
-         END if
-      END do
-
-!     If I am server, count nr. of clients
-!     Although this loop is symetric on all processes, the active server flag is valid only on the individual PE.
-
-      ALLOCATE(PMC_Server_for_Client(ClientCount+1))
-      ClientCount = 0
-      do i=2,m_NrOfCpl
-         if(activeServer(i) == 1)  then
-            ClientCount = clientCount+1
-            PMC_Server_for_Client(ClientCount) = i
-         END if
-      END do
-      PMC_Server_for_Client(ClientCount+1) = -1
-
-      !   Get size of the server model
-
-      if(m_my_CPL_id > 1)  then
-         CALL MPI_Comm_remote_size (m_to_server_comm, m_server_remote_size, istat)
-      else
-         m_server_remote_size = -1             ! root model does not have a server
-      END if
-
-!      write(0,'(a,a,1x,9i7)') 'New Communicator ',trim(m_couplers(m_my_CPL_id)%name),m_world_npes,m_model_npes,m_world_rank, &
-!                                           m_model_rank,m_my_CPL_id,m_my_CPL_rank,m_server_remote_size,ClientCount
-
-      return
+!
+!--   Create intercommunicator between server and clients.
+!--   MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
+!--   different colors.
+!--   The grouping was done above with MPI_COMM_SPLIT
+      DO  i = 2, m_nrofcpl
+
+         IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
+!
+!--         Collect server PEs
+!--         TO_DO: explain in more details, what is done here
+            tag = 500 + i
+            CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),   &
+                                       tag, m_to_client_comm(i), istat)
+            clientcount = clientcount + 1
+            activeserver(i) = 1
+
+         ELSEIF ( i == m_my_cpl_id)  THEN
+!
+!--         Collect client PEs
+!--         TO_DO: explain in more detail, what is happening here
+            tag = 500 + i
+            CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                &
+                                       start_pe(m_couplers(i)%parent_id),      &
+                                       tag, m_to_server_comm, istat )
+         ENDIF
+
+         IF ( istat /= MPI_SUCCESS )  THEN
+!
+!--         TO_DO: replace by message-call
+!--         TO_DO: can this really happen, or is this just for debugging?
+            IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in Coupler Setup '
+            CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
+         ENDIF
+
+      ENDDO
+
+!
+!--   If I am server, count the number of clients that I have
+!--   Although this loop is symmetric on all processes, the "activeserver" flag
+!--   is true (==1) on the respective individual PE only.
+      ALLOCATE( pmc_server_for_client(clientcount+1) )
+
+      clientcount = 0
+      DO  i = 2, m_nrofcpl
+         IF ( activeserver(i) == 1 )  THEN
+            clientcount = clientcount + 1
+            pmc_server_for_client(clientcount) = i
+         ENDIF
+      ENDDO
+!--   TO_DO: explain why this is done
+      pmc_server_for_client(clientcount+1) = -1
+
+!
+!--   Get the size of the server model
+!--   TO_DO: what does "size" mean here? Number of PEs?
+      IF ( m_my_cpl_id > 1 )  THEN
+         CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,    &
+                                    istat)
+      ELSE
+!
+!--      The root model does not have a server
+         m_server_remote_size = -1             !
+      ENDIF
+!
+!--   Set myid to non-tero value except for the root domain. This is a setting
+!--   for the message routine which is called at the end of pmci_init. That
+!--   routine outputs messages for myid = 0, only. However, myid has not been
+!--   assigened so far, so that all PEs of the root model would output a
+!--   message. To avoid this, set myid to some other value except for PE0 of the
+!--   root domain.
+      IF ( m_world_rank /= 0 )  myid = 1
+
    END SUBROUTINE PMC_init_model
 
-!  Make module private variables available to palm
-
-   SUBROUTINE PMC_get_local_model_info (my_CPL_id, CPL_name,  npe_x, npe_y, lower_left_x, lower_left_y)
-      IMPLICIT     none
-      INTEGER,INTENT(OUT),optional             :: my_CPL_id
-      CHARACTER(len=*),INTENT(OUT),optional    :: CPL_name
-      INTEGER,INTENT(OUT),optional             :: npe_x
-      INTEGER,INTENT(OUT),optional             :: npe_y
-      REAL(kind=8),INTENT(OUT),optional        :: lower_left_x
-      REAL(kind=8),INTENT(OUT),optional        :: lower_left_y
-
-      if(present(my_CPL_id))    my_CPL_id    = m_my_CPL_id
-      if(present(CPL_name))     CPL_name     = m_couplers(my_CPL_id)%name
-      if(present(npe_x))        npe_x        = m_couplers(my_CPL_id)%npe_x
-      if(present(npe_y))        npe_y        = m_couplers(my_CPL_id)%npe_y
-      if(present(lower_left_x)) lower_left_x = m_couplers(my_CPL_id)%lower_left_x
-      if(present(lower_left_y)) lower_left_y = m_couplers(my_CPL_id)%lower_left_y
-
-      return
-   END  SUBROUTINE PMC_get_local_model_info
-
-   LOGICAL function PMC_is_RootModel ()
-      IMPLICIT     none
-
-      PMC_is_RootModel = (m_my_CPL_id == 1)
-
-      return
-   END  function PMC_is_RootModel
-
+
+!
+!-- Make module private variables available to palm
+!-- TO_DO: why can't they be available from the beginning, i.e. why do they
+!--        first have to be declared as different private variables?
+   SUBROUTINE pmc_get_local_model_info( my_cpl_id, my_cpl_parent_id, cpl_name, &
+                                        npe_x, npe_y, lower_left_x,            &
+                                        lower_left_y )
+
+      USE kinds
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name
+      INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_id
+      INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_parent_id
+      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_x
+      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_y
+      REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_x
+      REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_y
+
+!--   TO_DO: is the PRESENT clause really required here?
+      IF ( PRESENT( my_cpl_id )           )  my_cpl_id        = m_my_cpl_id
+      IF ( PRESENT( my_cpl_parent_id )    )  my_cpl_parent_id = m_couplers(my_cpl_id)%parent_id
+      IF ( PRESENT( cpl_name )            )  cpl_name         = m_couplers(my_cpl_id)%name
+      IF ( PRESENT( npe_x )               )  npe_x            = m_couplers(my_cpl_id)%npe_x
+      IF ( PRESENT( npe_y )               )  npe_y            = m_couplers(my_cpl_id)%npe_y
+      IF ( PRESENT( lower_left_x )        )  lower_left_x     = m_couplers(my_cpl_id)%lower_left_x
+      IF ( PRESENT( lower_left_y )        )  lower_left_y     = m_couplers(my_cpl_id)%lower_left_y
+
+   END SUBROUTINE pmc_get_local_model_info
+
+
+
+   LOGICAL function pmc_is_rootmodel( )
+
+      IMPLICIT NONE
+
+      pmc_is_rootmodel = ( m_my_cpl_id == 1 )
+
+   END FUNCTION pmc_is_rootmodel
+
+
+
+
+!-- TO_DO: what does this comment mean?
 ! Private SUBROUTINEs
-
-  SUBROUTINE read_coupling_layout (PMC_status)
-    IMPLICIT     none
-    INTEGER,INTENT(INOUT)           :: PMC_status
-    INTEGER                         :: i,iunit,istat
-    CHARACTER(LEN=*), PARAMETER     :: fname = 'PMC_couple_layout'
-    LOGICAL                         :: lex
-
-    m_NrOfCpl = 0
+ SUBROUTINE read_coupling_layout( nesting_mode, pmc_status )
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=7) ::  nesting_mode
+
+    INTEGER, INTENT(INOUT) ::  pmc_status
+    INTEGER                ::  i, istat, iunit
+
+    TYPE(pmc_layout), DIMENSION(pmc_max_modell) ::  domain_layouts
+
+
+    NAMELIST /nestpar/  domain_layouts, nesting_mode
+
+!
+!-- Initialize some coupling variables
+    domain_layouts(1:pmc_max_modell)%id = -1
+    m_nrofcpl =   0
     iunit     = 345
 
-    PMC_STATUS = PMC_STATUS_OK
-    INQUIRE(file=TRIM(fname), exist=lex)
-    IF (.NOT. lex) THEN
-       PMC_status = PMC_ERRO_NOF
+    pmc_status = pmc_status_ok
+
+!
+!-- Open the NAMELIST-file and read the nesting layout
+    CALL check_open( 11 )
+    READ ( 11, nestpar, IOSTAT=istat )
+
+    IF ( istat < 0 )  THEN
+!
+!--    No nestpar-NAMELIST found
+       pmc_status = pmc_no_namelist_found
+!
+!--    Set filepointer to the beginning of the file. Otherwise PE0 will later
+!--    be unable to read the inipar-NAMELIST
+       REWIND ( 11 )
        RETURN
-    END IF
-
-    open(iunit,file=TRIM(fname),status='OLD')
-    do i=1,PMC_MAX_MODELL
-      read(iunit,*,iostat=istat) m_couplers(i)%name                     &
-           , m_couplers(i)%id,m_couplers(i)%Parent_id                   &
-           , m_couplers(i)%npe_x,m_couplers(i)%npe_y                    &
-           , m_couplers(i)%lower_left_x, m_couplers(i)%lower_left_y
-      if(istat /= 0)  EXIT
-
-      write(0,'(a,a,1x,4i7,1x,2F10.2)') 'Set up Model  ',trim(m_couplers(i)%name),m_couplers(i)%id,m_couplers(i)%Parent_id, &
-                                                     m_couplers(i)%npe_x,m_couplers(i)%npe_y,                               &
-                                                     m_couplers(i)%lower_left_x,m_couplers(i)%lower_left_y
-
-      m_NrOfCpl = i
-    END do
-    close(iunit)
-
-    return
-  END SUBROUTINE read_coupling_layout
-
-END MODULE PMC_handle_communicator
+
+    ELSEIF ( istat > 0 )  THEN
+!
+!--    Errors in reading nestpar-NAMELIST
+       pmc_status = pmc_namelist_error
+       RETURN
+
+    ENDIF
+
+!
+!-- Output location message
+    CALL location_message( 'initialize communicators for nesting', .FALSE. )
+!
+!-- Assign the layout to the internally used variable
+    m_couplers = domain_layouts
+
+!
+!-- Get the number of nested models given in the nestpar-NAMELIST
+    DO  i = 1, pmc_max_modell
+
+       IF ( m_couplers(i)%id /= -1  .AND.  i <= pmc_max_modell )  THEN
+          WRITE ( 0, '(A,A,1X,4I7,1X,2F10.2)' )  'Set up Model  ',             &
+                              TRIM( m_couplers(i)%name ), m_couplers(i)%id,    &
+                              m_couplers(i)%Parent_id, m_couplers(i)%npe_x,    &
+                              m_couplers(i)%npe_y, m_couplers(i)%lower_left_x, &
+                              m_couplers(i)%lower_left_y
+       ELSE
+!
+!--       When id=-1 is found for the first time, the list of domains is
+!--       finished (or latest after pmc_max_modell entries
+          m_nrofcpl = i - 1
+          EXIT
+       ENDIF
+
+    ENDDO
+
+ END SUBROUTINE read_coupling_layout
+
+#endif
+ END MODULE pmc_handle_communicator

palm/trunk/SOURCE/pmc_interface.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-! 
+! +cpl_parent_id,
+! cpp-statements for nesting replaced by __parallel statements,
+! errors output with message-subroutine,
+! index bugfixes in pmci_interp_tril_all,
+! some adjustments to PALM style
 !
 ! Former revisions:
@@ -35 +39 @@
 !------------------------------------------------------------------------------!
 
-
-    USE mpi
-
-!
-!-- PALM modules
+    USE arrays_3d,                                                             &
+        ONLY:  dzu, dzw, e, e_p, pt, pt_p, q, q_p, te_m, tu_m, tv_m, tw_m, u,  &
+               u_p, v, v_p, w, w_p, zu, zw, z0
+
+    USE control_parameters,                                                    &
+        ONLY:  dt_3d, dz, humidity, message_string, nest_bound_l,              &
+               nest_bound_r, nest_bound_s, nest_bound_n, passive_scalar,       &
+               simulated_time, topography, volume_flow
+
+    USE cpulog,                                                                &
+        ONLY:  cpu_log, log_point_s
+
+    USE grid_variables,                                                        &
+        ONLY:  dx, dy
+
+    USE indices,                                                               &
+        ONLY:  nbgp, nx, nxl, nxlg, nxlu, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
+               nysv, nz, nzb, nzb_s_inner, nzb_u_inner, nzb_u_outer,           &
+               nzb_v_inner, nzb_v_outer, nzb_w_inner, nzb_w_outer, nzt
+
     USE kinds
-    USE pegrid,                                                                           &
-        ONLY:  myid, numprocs, comm2d, comm1dx, comm1dy, myidx, myidy, collective_wait
-    USE arrays_3d,                                                                        &
-        ONLY:  u, v, w, e, pt, q, u_p, v_p, w_p, e_p, pt_p, q_p, z0, dzu, dzw, zu, zw,    &
-               tu_m, tv_m, tw_m, te_m
-    USE indices,                                                                          &
-        ONLY:  nx, ny, nz, nxl, nxr, nys, nyn, nzb, nzt, nxlu, nysv, nxlg, nxrg,          &
-               nysg, nyng, nbgp, nzb_u_inner, nzb_v_inner, nzb_w_inner,                   &
-               nzb_s_inner, nzb_u_outer, nzb_v_outer, nzb_w_outer
-    USE control_parameters,                                                               &
-        ONLY:  dz, dt_3d, simulated_time, message_string, volume_flow,                    &
-               nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n,                    &
-               topography, humidity, passive_scalar
-    USE grid_variables,                                                                   &
-        ONLY:  dx, dy
-    USE cpulog,                                                                           &
-        ONLY:  cpu_log, log_point_s
-
-!
-!-- PMC modules
-    USE pmc_general,                                                                      &
-        ONLY:  pmc_status_ok, pmc_max_modell, da_namelen
-    USE pmc_handle_communicator,                                                          &
-        ONLY:  pmc_init_model, pmc_is_rootmodel, pmc_get_local_model_info,                &
-               pmc_server_for_client
-    USE pmc_mpi_Wrapper,                                                                  &
-        ONLY:  pmc_recv_from_client, pmc_send_to_server, pmc_recv_from_server,            &
-               pmc_send_to_client, pmc_bcast
-    USE pmc_server,                                                                       &
-        ONLY:  pmc_serverinit, pmc_s_getnextarray,                                        &
-               pmc_s_set_dataarray, pmc_s_setind_and_allocmem,                            &
-               pmc_s_set_2d_index_list, pmc_s_fillbuffer,pmc_s_getdata_from_buffer
-    USE pmc_client,                                                                       &
-        ONLY:  pmc_clientinit, pmc_set_dataarray_name, pmc_c_get_2d_index_list,           &
-               pmc_c_getnextarray, pmc_c_set_dataarray, pmc_c_setind_and_allocmem,        &
-               pmc_c_putbuffer, pmc_c_getbuffer
+
+#if defined( __parallel )
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
+
+    USE pegrid,                                                                &
+        ONLY:  collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy,  &
+               numprocs
+
+    USE pmc_client,                                                            &
+        ONLY:  pmc_clientinit, pmc_c_getnextarray, pmc_c_get_2d_index_list,    &
+               pmc_c_getbuffer, pmc_c_putbuffer, pmc_c_setind_and_allocmem,    &
+               pmc_c_set_dataarray, pmc_set_dataarray_name
+
+    USE pmc_general,                                                           &
+        ONLY:  da_namelen, pmc_max_modell, pmc_status_ok
+
+    USE pmc_handle_communicator,                                               &
+        ONLY:  pmc_get_local_model_info, pmc_init_model, pmc_is_rootmodel,     &
+               pmc_no_namelist_found, pmc_server_for_client
+
+    USE pmc_mpi_wrapper,                                                       &
+        ONLY:  pmc_bcast, pmc_recv_from_client, pmc_recv_from_server,          &
+               pmc_send_to_client, pmc_send_to_server
+
+    USE pmc_server,                                                            &
+        ONLY:  pmc_serverinit, pmc_s_fillbuffer, pmc_s_getdata_from_buffer,    &
+               pmc_s_getnextarray, pmc_s_setind_and_allocmem,                  &
+               pmc_s_set_dataarray, pmc_s_set_2d_index_list
+
+#endif
 
     IMPLICIT NONE
 
+!-- TO_DO: a lot of lines (including comments) in this file exceed the 80 char
+!--        limit. Try to reduce as much as possible
+
+!-- TO_DO: shouldn't we use public as default here? Only a minority of the
+!-- variables is private.
     PRIVATE    !:  Note that the default publicity is here set to private.
 
 !
 !-- Constants
-    INTEGER(iwp), PARAMETER, PUBLIC        ::  client_to_server = 2   !:
-    INTEGER(iwp), PARAMETER, PUBLIC        ::  server_to_client = 1   !:
+    INTEGER(iwp), PARAMETER, PUBLIC ::  client_to_server = 2   !:
+    INTEGER(iwp), PARAMETER, PUBLIC ::  server_to_client = 1   !:
 
 !
 !-- Coupler setup
-    INTEGER(iwp), PUBLIC, SAVE             ::  cpl_id                 !:
-    CHARACTER(LEN=32), PUBLIC, SAVE        ::  cpl_name               !:
-    INTEGER(iwp), PUBLIC, SAVE             ::  cpl_npex               !: 
-    INTEGER(iwp), PUBLIC, SAVE             ::  cpl_npey               !:
+    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_id  = 1            !:
+    CHARACTER(LEN=32), PUBLIC, SAVE ::  cpl_name               !:
+    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npex               !:
+    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npey               !:
+    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_parent_id          !:
 
 !
 !-- Control parameters, will be made input parameters later
-    CHARACTER(LEN=7), PUBLIC, SAVE         ::  nesting_mode = 'two-way'          !:
-    REAL(wp), PUBLIC, SAVE                 ::  anterp_relax_length_l = -1.0_wp   !:
-    REAL(wp), PUBLIC, SAVE                 ::  anterp_relax_length_r = -1.0_wp   !:
-    REAL(wp), PUBLIC, SAVE                 ::  anterp_relax_length_s = -1.0_wp   !:
-    REAL(wp), PUBLIC, SAVE                 ::  anterp_relax_length_n = -1.0_wp   !:
-    REAL(wp), PUBLIC, SAVE                 ::  anterp_relax_length_t = -1.0_wp   !:
+    CHARACTER(LEN=7), PUBLIC, SAVE ::  nesting_mode = 'two-way'  !: steering parameter for one- or two-way nesting
+
+    LOGICAL, PUBLIC, SAVE ::  nested_run = .FALSE.  !: general switch if nested run or not
+
+    REAL(wp), PUBLIC, SAVE ::  anterp_relax_length_l = -1.0_wp   !:
+    REAL(wp), PUBLIC, SAVE ::  anterp_relax_length_r = -1.0_wp   !:
+    REAL(wp), PUBLIC, SAVE ::  anterp_relax_length_s = -1.0_wp   !:
+    REAL(wp), PUBLIC, SAVE ::  anterp_relax_length_n = -1.0_wp   !:
+    REAL(wp), PUBLIC, SAVE ::  anterp_relax_length_t = -1.0_wp   !:
 
 !
@@ -120 +146 @@
     REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET, PUBLIC ::  qc   !:
 
-    INTEGER(iwp), DIMENSION(5)                          ::  coarse_bound   !: Moved here form map_fine_to_coarse.
+    INTEGER(iwp), DIMENSION(5)                          ::  coarse_bound   !:
     REAL(wp), PUBLIC, SAVE                              ::  xexl           !:
     REAL(wp), PUBLIC, SAVE                              ::  xexr           !:
@@ -229 +255 @@
        INTEGER(iwp)                        ::  nx
        INTEGER(iwp)                        ::  ny
-       INTEGER (iwp)                       ::  nz
+       INTEGER(iwp)                        ::  nz
        REAL(wp)                            ::  dx
        REAL(wp)                            ::  dy
@@ -247 +273 @@
     TYPE(coarsegrid_def), SAVE             ::  cg   !:
 
-!
-!-- Interface section.
+
+    INTERFACE pmci_client_datatrans
+       MODULE PROCEDURE pmci_client_datatrans
+    END INTERFACE
+
+    INTERFACE pmci_client_initialize
+       MODULE PROCEDURE pmci_client_initialize
+    END INTERFACE
+
+    INTERFACE pmci_client_synchronize
+       MODULE PROCEDURE pmci_client_synchronize
+    END INTERFACE
+
+    INTERFACE pmci_ensure_nest_mass_conservation
+       MODULE PROCEDURE pmci_ensure_nest_mass_conservation
+    END INTERFACE
+
     INTERFACE pmci_init
        MODULE PROCEDURE pmci_init
     END INTERFACE
-    
+
     INTERFACE pmci_modelconfiguration
        MODULE PROCEDURE pmci_modelconfiguration
     END INTERFACE
-    
+
+    INTERFACE pmci_server_initialize
+       MODULE PROCEDURE pmci_server_initialize
+    END INTERFACE
+
     INTERFACE pmci_server_synchronize
        MODULE PROCEDURE pmci_server_synchronize
     END INTERFACE
-    
-    INTERFACE pmci_client_synchronize
-       MODULE PROCEDURE pmci_client_synchronize
-    END INTERFACE
-    
-    INTERFACE pmci_server_datatrans
-       MODULE PROCEDURE pmci_server_datatrans
-    END INTERFACE
-    
-    INTERFACE pmci_client_datatrans
-       MODULE PROCEDURE pmci_client_datatrans
-    END INTERFACE
-    
+
     INTERFACE pmci_update_new
        MODULE PROCEDURE pmci_update_new
     END INTERFACE
 
-    INTERFACE pmci_ensure_nest_mass_conservation
-       MODULE PROCEDURE pmci_ensure_nest_mass_conservation
-    END INTERFACE
-    
-    INTERFACE pmci_server_initialize
-       MODULE PROCEDURE pmci_server_initialize
-    END INTERFACE
-    
-    INTERFACE pmci_client_initialize
-       MODULE PROCEDURE pmci_client_initialize
-    END INTERFACE
-    
+    PUBLIC pmci_client_datatrans
+    PUBLIC pmci_client_initialize
+    PUBLIC pmci_client_synchronize
+    PUBLIC pmci_ensure_nest_mass_conservation
     PUBLIC pmci_init
     PUBLIC pmci_modelconfiguration
+    PUBLIC pmci_server_datatrans
+    PUBLIC pmci_server_initialize
     PUBLIC pmci_server_synchronize
-    PUBLIC pmci_client_synchronize
-    PUBLIC pmci_server_datatrans
-    PUBLIC pmci_client_datatrans
     PUBLIC pmci_update_new
-    PUBLIC pmci_ensure_nest_mass_conservation
-    PUBLIC pmci_server_initialize
-    PUBLIC pmci_client_initialize
 
 
@@ -305 +326 @@
 
  SUBROUTINE pmci_init( world_comm )
+
     IMPLICIT NONE
 
-    INTEGER, INTENT(OUT)  ::  world_comm   !:
-
-    INTEGER(iwp)          ::  ierr         !:
-    INTEGER(iwp)          ::  istat        !:
-    INTEGER(iwp)          ::  PMC_status   !:
-
-
-#if defined PMC_ACTIVE
-    CALL pmc_init_model( world_comm, pmc_status )
-    IF ( pmc_status /= pmc_status_ok )  THEN
-       CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
+    INTEGER, INTENT(OUT) ::  world_comm   !:
+
+#if defined( __parallel )
+
+    INTEGER(iwp)         ::  ierr         !:
+    INTEGER(iwp)         ::  istat        !:
+    INTEGER(iwp)         ::  pmc_status   !:
+
+
+    CALL pmc_init_model( world_comm, nesting_mode, pmc_status )
+
+    IF ( pmc_status == pmc_no_namelist_found )  THEN
+!
+!--    This is not a nested run
+!
+!--    TO_DO: this wouldn't be required any more?
+       world_comm = MPI_COMM_WORLD
+       cpl_id     = 1
+       cpl_name   = ""
+       cpl_npex   = 2
+       cpl_npey   = 2
+       lower_left_coord_x = 0.0_wp
+       lower_left_coord_y = 0.0_wp
+       RETURN
+    ELSE
+!
+!--    Set the general steering switch which tells PALM that its a nested run
+       nested_run = .TRUE.
     ENDIF
-    CALL pmc_get_local_model_info( my_cpl_id = cpl_id, cpl_name = cpl_name,  npe_x=cpl_npex, npe_y = cpl_npey,  &
-                                   lower_left_x = lower_left_coord_x, lower_left_y = lower_left_coord_y )
+
+    CALL pmc_get_local_model_info( my_cpl_id = cpl_id,                         &
+                                   my_cpl_parent_id = cpl_parent_id,           &
+                                   cpl_name = cpl_name,                        &
+                                   npe_x = cpl_npex, npe_y = cpl_npey,         &
+                                   lower_left_x = lower_left_coord_x,          &
+                                   lower_left_y = lower_left_coord_y )
+!
+!-- Message that communicators for nesting are initialized.
+!-- Attention: myid has been set at the end of pmc_init_model in order to
+!-- guarantee that only PE0 of the root domain does the output.
+    CALL location_message( 'finished', .TRUE. )
+!
+!-- Reset myid to its default value
+    myid = 0
 #else
-    world_comm = MPI_COMM_WORLD
+!
+!-- Nesting cannot be used in serial mode. cpl_id is set to root domain (1)
+!-- because no location messages would be generated otherwise.
+!-- world_comm is given a dummy value to avoid compiler warnings (INTENT(OUT)
+!-- should get an explicit value)
     cpl_id     = 1
-    cpl_name   = ""
-    cpl_npex   = 2
-    cpl_npey   = 2
-    lower_left_coord_x = 0.0_wp
-    lower_left_coord_y = 0.0_wp
+    nested_run = .FALSE.
+    world_comm = 1
 #endif
 
@@ -336 +389 @@
 
  SUBROUTINE pmci_modelconfiguration
+
     IMPLICIT NONE
 
+    CALL location_message( 'setup the nested model configuration', .FALSE. )
     CALL pmci_setup_coordinates   !:  Compute absolute coordinates valid for all models
-    CALL pmci_setup_client        !:  Initialize PMC Client (Must be called before pmc_palm_SetUp_Server)
+    CALL pmci_setup_client        !:  Initialize PMC Client (Must be called before pmc_setup_server)
     CALL pmci_setup_server        !:  Initialize PMC Server
+    CALL location_message( 'finished', .TRUE. )
 
  END SUBROUTINE pmci_modelconfiguration
@@ -347 +403 @@
 
  SUBROUTINE pmci_setup_server
+
+#if defined( __parallel )
     IMPLICIT NONE
 
@@ -371 +429 @@
     
 
-#if defined PMC_ACTIVE
-    CALL pmc_serverinit                                !  Initialize PMC Server
-
-!
-!-- Get coordinates from all Clients.
+!
+!   Initialize the PMC server
+    CALL pmc_serverinit
+
+!
+!-- Get coordinates from all clients
     DO  m = 1, SIZE( pmc_server_for_client ) - 1
        client_id = pmc_server_for_client(m)
@@ -391 +450 @@
 
 !
-!--       Find the highest client level in the coarse grid for the reduced z transfer
+!--       Find the highest client level in the coarse grid for the reduced z
+!--       transfer
           DO  k = 1, nz                 
              IF ( zw(k) > fval(1) )  THEN
@@ -404 +464 @@
           ALLOCATE( cl_coord_y(-nbgp:ny_cl+nbgp) )
          
-          CALL pmc_recv_from_client( client_id, cl_coord_x, SIZE( cl_coord_x ), 0, 11, ierr )
-          CALL pmc_recv_from_client( client_id, cl_coord_y, SIZE( cl_coord_y ), 0, 12, ierr )
+          CALL pmc_recv_from_client( client_id, cl_coord_x, SIZE( cl_coord_x ),&
+                                     0, 11, ierr )
+          CALL pmc_recv_from_client( client_id, cl_coord_y, SIZE( cl_coord_y ),&
+                                     0, 12, ierr )
           WRITE ( 0, * )  'receive from pmc Client ', client_id, nx_cl, ny_cl
          
           define_coarse_grid_real(1) = lower_left_coord_x
           define_coarse_grid_real(2) = lower_left_coord_y
-          define_coarse_grid_real(3) = 0                                      !  KK currently not used.
+!--       TO_DO: remove this?
+          define_coarse_grid_real(3) = 0             !  KK currently not used.
           define_coarse_grid_real(4) = 0
           define_coarse_grid_real(5) = dx
           define_coarse_grid_real(6) = dy
-          define_coarse_grid_real(7) = lower_left_coord_x + ( nx + 1 ) * dx   !  AH: corrected 6.2.2015
-          define_coarse_grid_real(8) = lower_left_coord_y + ( ny + 1 ) * dy   !  AH: corrected 6.2.2015
-          define_coarse_grid_real(9) = dz                                     !  AH: added 24.2.2015
+          define_coarse_grid_real(7) = lower_left_coord_x + ( nx + 1 ) * dx
+          define_coarse_grid_real(8) = lower_left_coord_y + ( ny + 1 ) * dy
+          define_coarse_grid_real(9) = dz
 
           define_coarse_grid_int(1)  = nx
@@ -437 +500 @@
 !
 !--       Send coarse grid information to client
-          CALL pmc_send_to_client( client_id, Define_coarse_grid_real, 9, 0, 21, ierr )
-          CALL pmc_send_to_client( client_id, Define_coarse_grid_int,  3, 0, 22, ierr )
-
-!
-!--       Send local grid to client.
+          CALL pmc_send_to_client( client_id, Define_coarse_grid_real, 9, 0,   &
+                                   21, ierr )
+          CALL pmc_send_to_client( client_id, Define_coarse_grid_int,  3, 0,   &
+                                   22, ierr )
+
+!
+!--       Send local grid to client
           CALL pmc_send_to_client( client_id, coord_x, nx+1+2*nbgp, 0, 24, ierr )
           CALL pmc_send_to_client( client_id, coord_y, ny+1+2*nbgp, 0, 25, ierr )
 
 !
-!--       Also send the dzu-, dzw-, zu- and zw-arrays here.    
+!--       Also send the dzu-, dzw-, zu- and zw-arrays here
           CALL pmc_send_to_client( client_id, dzu, nz_cl + 1, 0, 26, ierr )
           CALL pmc_send_to_client( client_id, dzw, nz_cl + 1, 0, 27, ierr )
@@ -454 +519 @@
        ENDIF
 
-       CALL MPI_Bcast( nomatch, 1, MPI_INTEGER, 0, comm2d, ierr )
+       CALL MPI_BCAST( nomatch, 1, MPI_INTEGER, 0, comm2d, ierr )
        IF ( nomatch /= 0 ) THEN
-          WRITE ( message_string, * )  'Error: nested client domain does not fit ',    &
-                                       'into its server domain'
+          WRITE ( message_string, * )  'Error: nested client domain does ',    &
+                                       'not fit into its server domain'
           CALL message( 'pmc_palm_setup_server', 'PA0XYZ', 1, 2, 0, 6, 0 )
        ENDIF
       
-       CALL MPI_Bcast( nz_cl, 1, MPI_INTEGER, 0, comm2d, ierr )
+       CALL MPI_BCAST( nz_cl, 1, MPI_INTEGER, 0, comm2d, ierr )
        
        CALL pmci_create_index_list
@@ -468 +533 @@
 !--    Include couple arrays into server content
        DO  WHILE ( pmc_s_getnextarray( client_id, myname ) )
-          CALL pmci_set_array_pointer( myName, client_id = client_id, nz_cl = nz_cl )
+          CALL pmci_set_array_pointer( myname, client_id = client_id,          &
+                                       nz_cl = nz_cl )
        ENDDO
        CALL pmc_s_setind_and_allocmem( client_id )
     ENDDO
 
-#endif
-
-
  CONTAINS
 
 
    SUBROUTINE pmci_create_index_list
+
        IMPLICIT NONE
+
        INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  ::  coarse_bound_all   !:
        INTEGER(iwp)                               ::  i                  !:
@@ -504 +569 @@
           CALL pmc_recv_from_client( client_id, size_of_array, 2, 0, 40, ierr )
           ALLOCATE( coarse_bound_all(size_of_array(1),size_of_array(2)) )
-          CALL pmc_recv_from_client( client_id, coarse_bound_all, SIZE( coarse_bound_all ), 0, 41, ierr )
+          CALL pmc_recv_from_client( client_id, coarse_bound_all,              &
+                                     SIZE( coarse_bound_all ), 0, 41, ierr )
 
 !
@@ -519 +585 @@
           ALLOCATE( index_list(6,ic) )
 
-          CALL MPI_Comm_size( comm1dx, npx, ierr )
-          CALL MPI_Comm_size( comm1dy, npy, ierr )
+          CALL MPI_COMM_SIZE( comm1dx, npx, ierr )
+          CALL MPI_COMM_SIZE( comm1dy, npy, ierr )
 
           nrx = nxr - nxl + 1   !  +1 in index because FORTRAN indexing starts with 1, palm with 0
@@ -532 +598 @@
                    scoord(1) = px
                    scoord(2) = py
-                   CALL MPI_Cart_rank( comm2d, scoord, server_pe, ierr )
+                   CALL MPI_CART_RANK( comm2d, scoord, server_pe, ierr )
                   
                    ic = ic + 1
@@ -546 +612 @@
           CALL pmc_s_set_2d_index_list( client_id, index_list(:,1:ic) )
        ELSE
-          ALLOCATE( index_list(6,1) )                                   !  Dummy allocate
+          ALLOCATE( index_list(6,1) )    !  Dummy allocate
           CALL pmc_s_set_2d_index_list( client_id, index_list )
        ENDIF
@@ -554 +620 @@
      END SUBROUTINE pmci_create_index_list
 
-
+#endif
  END SUBROUTINE pmci_setup_server
 
@@ -560 +626 @@
 
  SUBROUTINE pmci_setup_client
+
+#if defined( __parallel )
     IMPLICIT NONE
+
+    CHARACTER(LEN=DA_Namelen)  ::  myname     !:
+
     INTEGER(iwp)               ::  i          !:
     INTEGER(iwp)               ::  ierr       !:
@@ -579 +650 @@
     REAL(wp), DIMENSION(4)     ::  ztt        !:
                                              
-    CHARACTER(LEN=DA_Namelen)  ::  myname     !:
-
-
-#if defined PMC_ACTIVE
-    IF ( .not. pmc_is_rootmodel() )  THEN     !  Root Model does not have Server and is not a client
+
+!-- TO_DO: describe what is happening in this if-clause
+!-- Root Model does not have Server and is not a client
+    IF ( .NOT. pmc_is_rootmodel() )  THEN
        CALL pmc_clientinit
        
@@ -596 +666 @@
 
 !
-!--    Update this list appropritely and also in create_client_arrays and in pmci_set_array_pointer.
-!--    If a variable is removed, it only has tobe removed from here.
-       CALL pmc_set_dataarray_name( lastentry = .true. )
-
-!
-!--    Send grid to Server
+!--    Update this list appropritely and also in create_client_arrays and in
+!--    pmci_set_array_pointer.
+!--    If a variable is removed, it only has to be removed from here.
+       CALL pmc_set_dataarray_name( lastentry = .TRUE. )
+
+!
+!--    Send grid to server
        val(1)  = nx
        val(2)  = ny
@@ -621 +692 @@
 
 !
-!--       Receive also the dz-,zu- and zw-arrays here.         
+!--       Receive also the dz-,zu- and zw-arrays here.
+!--       TO_DO: what is the meaning of above comment + remove write statements
+!--              and give this informations in header
           WRITE(0,*) 'Coarse grid from Server '
           WRITE(0,*) 'startx_tot    = ',define_coarse_grid_real(1)
@@ -635 +708 @@
        ENDIF
 
-       CALL MPI_Bcast( define_coarse_grid_real, 9, MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( define_coarse_grid_int,  3, MPI_INTEGER, 0, comm2d, ierr )
+       CALL MPI_BCAST( define_coarse_grid_real, 9, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr )
 
        cg%dx = define_coarse_grid_real(5)
@@ -658 +731 @@
 !--    Get coarse grid coordinates and vales of the z-direction from server
        IF ( myid == 0) THEN
-          CALL pmc_recv_from_server( cg%coord_x, cg%nx + 1 + 2 * nbgp, 0, 24, ierr )
-          CALL pmc_recv_from_server( cg%coord_y, cg%ny + 1 + 2 * nbgp, 0, 25, ierr )         
+          CALL pmc_recv_from_server( cg%coord_x, cg%nx + 1 + 2 * nbgp, 0, 24,  &
+                                     ierr )
+          CALL pmc_recv_from_server( cg%coord_y, cg%ny + 1 + 2 * nbgp, 0, 25,  &
+                                     ierr )
           CALL pmc_recv_from_server( cg%dzu, cg%nz + 1, 0, 26, ierr )
           CALL pmc_recv_from_server( cg%dzw, cg%nz + 1, 0, 27, ierr )
@@ -668 +743 @@
 !
 !--    and broadcast this information
-       CALL MPI_Bcast( cg%coord_x, cg%nx + 1 + 2 * nbgp, MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( cg%coord_y, cg%ny + 1 + 2 * nbgp, MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( cg%dzu, cg%nz + 1, MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( cg%dzw, cg%nz + 1, MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( cg%zu, cg%nz + 2,  MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_Bcast( cg%zw, cg%nz + 2,  MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( cg%coord_x, cg%nx + 1 + 2 * nbgp, MPI_REAL, 0, comm2d,  &
+                       ierr )
+       CALL MPI_BCAST( cg%coord_y, cg%ny + 1 + 2 * nbgp, MPI_REAL, 0, comm2d,  &
+                       ierr )
+       CALL MPI_BCAST( cg%dzu, cg%nz + 1, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( cg%dzw, cg%nz + 1, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( cg%zu, cg%nz + 2,  MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( cg%zw, cg%nz + 2,  MPI_REAL, 0, comm2d, ierr )
        
        CALL pmci_map_fine_to_coarse_grid
-
        CALL pmc_c_get_2d_index_list
 
@@ -682 +758 @@
 !--    Include couple arrays into client content.
        DO  WHILE ( pmc_c_getnextarray( myname ) )
-          CALL pmci_create_client_arrays ( myName, icl, icr, jcs, jcn,  cg%nz )   !  Klaus, why the c-arrays are still up to cg%nz??
+!--       TO_DO: Klaus, why the c-arrays are still up to cg%nz??
+          CALL pmci_create_client_arrays ( myname, icl, icr, jcs, jcn, cg%nz )
        ENDDO
        CALL pmc_c_setind_and_allocmem
 
 !
-!--    Precompute interpolation coefficients and client-array indices.
+!--    Precompute interpolation coefficients and client-array indices
        CALL pmci_init_interp_tril
 
@@ -695 +772 @@
 
 !
-!--    Define the SGS-TKE scaling factor based on the grid-spacing ratio. 
+!--    Define the SGS-TKE scaling factor based on the grid-spacing ratio
        CALL pmci_init_tkefactor
 
 !
 !--    Two-way coupling      
-       IF ( nesting_mode == 'two-way' ) THEN
+       IF ( nesting_mode == 'two-way' )  THEN
           CALL pmci_init_anterp_tophat
        ENDIF
@@ -712 +789 @@
 
 !
-!--    Why not just simply? test this!
+!--    TO_DO: Why not just simply? test this!
        !area_t_l = ( nx + 1 ) * (ny + 1 ) * dx * dy            
 
-    ENDIF   !  IF ( .not. PMC_is_RootModel ) 
-#endif
-
+    ENDIF
 
  CONTAINS
@@ -723 +798 @@
 
     SUBROUTINE pmci_map_fine_to_coarse_grid
+
         IMPLICIT NONE
+
         INTEGER(iwp), DIMENSION(5,numprocs)  ::  coarse_bound_all   !:
         INTEGER(iwp), DIMENSION(2)           ::  size_of_array      !:
@@ -730 +807 @@
         REAL(wp)                             ::  coarse_dy   !:
         REAL(wp)                             ::  loffset     !:
+        REAL(wp)                             ::  noffset     !:
         REAL(wp)                             ::  roffset     !:
-        REAL(wp)                             ::  noffset     !:
         REAL(wp)                             ::  soffset     !:
 
@@ -792 +869 @@
 !
 !--     Note that MPI_Gather receives data from all processes in the rank order. 
-        CALL MPI_Gather( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &
+        CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &
                          MPI_INTEGER, 0, comm2d, ierr )
 
@@ -968 +1045 @@
          DO  i = nxl - 1, nxl
             DO  j = nys, nyn
-               nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, nzb_u_inner(j,i), nzb_v_inner(j,i), nzb_w_inner(j,i) )
+               nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, nzb_u_inner(j,i),   &
+                                        nzb_v_inner(j,i), nzb_w_inner(j,i) )
             ENDDO
          ENDDO
@@ -978 +1056 @@
          i = nxr + 1
          DO  j = nys, nyn
-            nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, nzb_u_inner(j,i), nzb_v_inner(j,i), nzb_w_inner(j,i) )
+            nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, nzb_u_inner(j,i),      &
+                                     nzb_v_inner(j,i), nzb_w_inner(j,i) )
          ENDDO
          nzt_topo_nestbc_r = nzt_topo_nestbc_r + 1       
@@ -987 +1066 @@
          DO  j = nys - 1, nys
             DO  i = nxl, nxr
-               nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, nzb_u_inner(j,i), nzb_v_inner(j,i), nzb_w_inner(j,i) )
+               nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, nzb_u_inner(j,i),   &
+                                        nzb_v_inner(j,i), nzb_w_inner(j,i) )
             ENDDO
          ENDDO
@@ -997 +1077 @@
          j = nyn + 1
          DO  i = nxl, nxr
-            nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, nzb_u_inner(j,i), nzb_v_inner(j,i), nzb_w_inner(j,i) )
+            nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, nzb_u_inner(j,i),      &
+                                     nzb_v_inner(j,i), nzb_w_inner(j,i) )
          ENDDO
          nzt_topo_nestbc_n = nzt_topo_nestbc_n + 1
@@ -1003 +1084 @@
 
 !
-!--  Then determine the maximum number of near-wall nodes per wall point based on the grid-spacing ratios.
-      nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r, nzt_topo_nestbc_s, nzt_topo_nestbc_n )
-      ni = CEILING( cg%dx / dx ) / 2   !  Note that the outer division must be integer division.
-      nj = CEILING( cg%dy / dy ) / 2   !  Note that the outer division must be integer division.
+!--   Then determine the maximum number of near-wall nodes per wall point based
+!--   on the grid-spacing ratios.
+      nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r,                &
+                          nzt_topo_nestbc_s, nzt_topo_nestbc_n )
+
+!
+!--   Note that the outer division must be integer division.
+      ni = CEILING( cg%dx / dx ) / 2
+      nj = CEILING( cg%dy / dy ) / 2
       nk = 1
       DO  k = 1, nzt_topo_max
@@ -1018 +1104 @@
 
 !
-!--   First horizontal walls.
-!--   Left boundary.
+!--   First horizontal walls
+!--   Left boundary
       IF ( nest_bound_l )   THEN
          ALLOCATE( logc_u_l(nzb:nzt_topo_nestbc_l, nys:nyn, 1:2) )
@@ -1033 +1119 @@
 
          DO  j = nys, nyn      
-
-!
-!--         Left boundary for u.
+!
+!--         Left boundary for u
             i   = 0
             kb  = nzb_u_inner(j,i)
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_u_l(k,j,1) = lc
             logc_ratio_u_l(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
@@ -1046 +1132 @@
 
 !
-!--         Left boundary for v.
+!--         Left boundary for v
             i   = -1
             kb  =  nzb_v_inner(j,i)
             k   =  kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_v_l(k,j,1) = lc
             logc_ratio_v_l(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
             lcr(0:ncorr-1) = 1.0_wp
-         ENDDO
-      ENDIF
-
-!
-!--   Right boundary.
+
+         ENDDO
+      ENDIF
+
+!
+!--   Right boundary
       IF ( nest_bound_r )  THEN
          ALLOCATE( logc_u_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
@@ -1071 +1159 @@
          direction      = 1
          inc            = 1  
-         DO  j = nys, nyn          
-
+         DO  j = nys, nyn
 !
 !--         Right boundary for u.
@@ -1079 +1166 @@
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_u_r(k,j,1) = lc
             logc_ratio_u_r(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
@@ -1090 +1178 @@
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_v_r(k,j,1) = lc
             logc_ratio_v_r(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
             lcr(0:ncorr-1) = 1.0_wp
-         ENDDO
-      ENDIF
-
-!
-!--   South boundary.
+
+         ENDDO
+      ENDIF
+
+!
+!--   South boundary
       IF ( nest_bound_s )  THEN
          ALLOCATE( logc_u_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2) )
@@ -1111 +1201 @@
          inc            = 1 
          DO  i = nxl, nxr
-
 !
 !--         South boundary for u.
@@ -1118 +1207 @@
             k   =  kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_u_s(k,i,1) = lc
             logc_ratio_u_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
@@ -1124 +1214 @@
 
 !
-!--         South boundary for v.
+!--         South boundary for v
             j   = 0
             kb  = nzb_v_inner(j,i)
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_v_s(k,i,1) = lc
             logc_ratio_v_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
@@ -1137 +1228 @@
 
 !
-!--   North boundary.
+!--   North boundary
       IF ( nest_bound_n )  THEN
          ALLOCATE( logc_u_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2) )
@@ -1149 +1240 @@
          direction      = 1
          inc            = 1 
-         DO  i = nxl, nxr       
-
+         DO  i = nxl, nxr
 !
 !--         North boundary for u.
@@ -1157 +1247 @@
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_u_n(k,i,1) = lc
             logc_ratio_u_n(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
@@ -1168 +1259 @@
             k   = kb + 1
             wall_index = kb 
-            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+            CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, j, inc, &
+                                     wall_index, z0(j,i), kb, direction, ncorr )
             logc_v_n(k,i,1) = lc
             logc_ratio_v_n(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
             lcr(0:ncorr-1) = 1.0_wp
+
          ENDDO
       ENDIF
@@ -2011 +2104 @@
     END SUBROUTINE pmci_init_tkefactor
 
-
+#endif
  END SUBROUTINE pmci_setup_client
 
@@ -2017 +2110 @@
 
  SUBROUTINE pmci_setup_coordinates
+
+#if defined( __parallel )
     IMPLICIT NONE
+
     INTEGER(iwp) ::  i   !:
     INTEGER(iwp) ::  j   !:
@@ -2033 +2129 @@
        coord_y(j) = lower_left_coord_y + j * dy
     ENDDO
-     
+
+#endif
  END SUBROUTINE pmci_setup_coordinates
 
@@ -2040 +2137 @@
  SUBROUTINE pmci_server_synchronize
 
+#if defined( __parallel )
 !
 !-- Unify the time steps for each model and synchronize.
@@ -2066 +2164 @@
 !
 !-- Broadcast the unified time step to all server processes.
-    CALL MPI_Bcast( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+    CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
 
 !
@@ -2076 +2174 @@
        ENDIF
     ENDDO
-    
+
+#endif
  END SUBROUTINE pmci_server_synchronize
 
@@ -2083 +2182 @@
  SUBROUTINE pmci_client_synchronize
 
+#if defined( __parallel )
 !
 !-- Unify the time steps for each model and synchronize.
@@ -2105 +2205 @@
 !
 !--    Broadcast the unified time step to all server processes.
-       CALL MPI_Bcast( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
     ENDIF
 
+#endif
  END SUBROUTINE pmci_client_synchronize
                 
@@ -2113 +2214 @@
 
  SUBROUTINE pmci_server_datatrans( direction )
+
     IMPLICIT NONE
+
     INTEGER(iwp),INTENT(IN) ::  direction   !:
+
+#if defined( __parallel )
     INTEGER(iwp)            ::  client_id   !:
     INTEGER(iwp)            ::  i           !:
@@ -2138 +2243 @@
 !
 !-- Broadcast the unified time step to all server processes.
-    CALL MPI_Bcast( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+    CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
 
     DO  m = 1, SIZE( PMC_Server_for_Client ) - 1
@@ -2185 +2290 @@
     ENDDO
 
+#endif
  END SUBROUTINE pmci_server_datatrans
 
@@ -2190 +2296 @@
 
  SUBROUTINE pmci_client_datatrans( direction )
+
     IMPLICIT NONE
+
     INTEGER(iwp), INTENT(IN) ::  direction   !:
+
+#if defined( __parallel )
     INTEGER(iwp)             ::  ierr        !:
     INTEGER(iwp)             ::  icl         !:
@@ -2214 +2324 @@
 !
 !--    Broadcast the unified time step to all server processes.
-       CALL MPI_Bcast( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
        CALL cpu_log( log_point_s(70), 'PMC model sync', 'stop' )
 
@@ -3179 +3289 @@
 !--            Spatial under-relaxation.
                fra  = frax(l) * fray(m) * fraz(n)
+!--            TO_DO: why not KIND=wp ?
                fc(n,m,l) = ( 1.0_wp - fra ) * fc(n,m,l) + fra * cellsum / REAL( nfc, KIND=KIND(cellsum) )  
             ENDDO
@@ -3186 +3297 @@
    END SUBROUTINE pmci_anterp_tophat
 
-
+#endif
  END SUBROUTINE pmci_client_datatrans
 
@@ -3193 +3304 @@
  SUBROUTINE pmci_update_new
 
+#if defined( __parallel )
 !
 !-- Copy the interpolated/anterpolated boundary values to the _p 
@@ -3219 +3331 @@
 
 !
-!-- Find out later if nesting would work without __nopointer.
+!-- TO_DO: Find out later if nesting would work without __nopointer.
+#endif
 
  END SUBROUTINE pmci_update_new
@@ -3226 +3339 @@
 
  SUBROUTINE pmci_set_array_pointer( name, client_id, nz_cl )
+
     IMPLICIT NONE
 
@@ -3232 +3346 @@
     CHARACTER(LEN=*), INTENT(IN)         ::  name        !:
     
+#if defined( __parallel )
     REAL(wp), POINTER, DIMENSION(:,:)    ::  p_2d        !:
     REAL(wp), POINTER, DIMENSION(:,:,:)  ::  p_3d        !:
@@ -3238 +3353 @@
     
 
-#if defined PMC_ACTIVE
     NULLIFY( p_3d )
     NULLIFY( p_2d )
@@ -3257 +3371 @@
        CALL pmc_s_set_dataarray( client_id, p_2d )
     ELSE
-       IF ( myid == 0 ) WRITE( 0, * )  'PMC set_array_Pointer -> no pointer p_2d or p_3d associated '
-       CALL MPI_Abort( MPI_COMM_WORLD, istat, ierr )
+!
+!--    Give only one message for the root domain
+       IF ( myid == 0  .AND.  cpl_id == 1 )  THEN
+
+          message_string = 'pointer for array "' // TRIM( name ) //            &
+                           '" can''t be associated'
+          CALL message( 'pmci_set_array_pointer', 'PA0117', 3, 2, 0, 6, 0 )
+       ELSE
+!
+!--       Avoid others to continue
+          CALL MPI_BARRIER( comm2d, ierr )
+       ENDIF
     ENDIF
 
 #endif
-
  END SUBROUTINE pmci_set_array_pointer
 
@@ -3268 +3391 @@
 
  SUBROUTINE pmci_create_client_arrays( name, is, ie, js, je, nzc  )
+
     IMPLICIT NONE
+
     INTEGER(iwp), INTENT(IN)              ::  ie      !:
     INTEGER(iwp), INTENT(IN)              ::  is      !:
@@ -3276 +3401 @@
     CHARACTER(LEN=*), INTENT(IN)          ::  name    !:
      
+#if defined( __parallel )
     REAL(wp), POINTER,DIMENSION(:,:)      ::  p_2d    !:
     REAL(wp), POINTER,DIMENSION(:,:,:)    ::  p_3d    !:
@@ -3282 +3408 @@
 
 
-#if defined PMC_ACTIVE
     NULLIFY( p_3d )
     NULLIFY( p_2d )
@@ -3317 +3442 @@
        CALL pmc_c_set_dataarray( p_2d )
     ELSE
-       IF ( myid == 0 ) WRITE( 0 , * )  'PMC create_client_arrays -> no pointer p_2d or p_3d associated '
-       CALL MPI_Abort( MPI_COMM_WORLD, istat, ierr )
+!
+!--    Give only one message for the first client domain
+       IF ( myid == 0  .AND.  cpl_id == 2 )  THEN
+
+          message_string = 'pointer for array "' // TRIM( name ) //            &
+                           '" can''t be associated'
+          CALL message( 'pmci_create_client_arrays', 'PA0170', 3, 2, 0, 6, 0 )
+       ELSE
+!
+!--       Avoid others to continue
+          CALL MPI_BARRIER( comm2d, ierr )
+       ENDIF
     ENDIF
+
 #endif
-
  END SUBROUTINE pmci_create_client_arrays
 
@@ -3327 +3462 @@
 
  SUBROUTINE pmci_server_initialize
+
+#if defined( __parallel )
     IMPLICIT NONE
+
     INTEGER(iwp)   ::  client_id   !:
     INTEGER(iwp)   ::  m           !:
@@ -3338 +3476 @@
     ENDDO
 
+#endif
  END SUBROUTINE pmci_server_initialize
 
@@ -3344 +3483 @@
  SUBROUTINE pmci_client_initialize
 
+#if defined( __parallel )
     IMPLICIT NONE
+
     INTEGER(iwp)   ::  i          !:
     INTEGER(iwp)   ::  icl        !:
@@ -3428 +3569 @@
       INTEGER(iwp) ::  i      !:
       INTEGER(iwp) ::  ib     !:
+      INTEGER(iwp) ::  ie     !:
       INTEGER(iwp) ::  j      !:
       INTEGER(iwp) ::  jb     !:
+      INTEGER(iwp) ::  je     !:
       INTEGER(iwp) ::  k      !:
       INTEGER(iwp) ::  k1     !:
@@ -3448 +3591 @@
       
       ib = nxl
-      jb = nys     
+      ie = nxr
+      jb = nys   
+      je = nyn
       IF ( nest_bound_l )  THEN
+         ib = nxl - 1 
          IF ( var == 'u' )  THEN   !  For u, nxl is a ghost node, but not for the other variables.
-            ib = nxl + 1
+            ib = nxl
          ENDIF
       ENDIF
       IF ( nest_bound_s )  THEN
+         jb = nys - 1 
          IF ( var == 'v' )  THEN   !  For v, nys is a ghost node, but not for the other variables.
-            jb = nys + 1
+            jb = nys
          ENDIF
       ENDIF
+      IF ( nest_bound_r )  THEN
+         ie = nxr + 1
+      ENDIF
+      IF ( nest_bound_n )  THEN
+         je = nyn + 1
+      ENDIF
 
 !
 !--   Trilinear interpolation.
-      DO  i = ib, nxr
-         DO  j = jb, nyn
-            DO  k = kb(j,i), nzt 
+      DO  i = ib, ie
+         DO  j = jb, je
+            DO  k = kb(j,i), nzt + 1 
                l = ic(i)
                m = jc(j)
@@ -3517 +3670 @@
    END SUBROUTINE pmci_interp_tril_all
 
+#endif
  END SUBROUTINE pmci_client_initialize
 
@@ -3523 +3677 @@
  SUBROUTINE pmci_ensure_nest_mass_conservation
 
+#if defined( __parallel )
 !
 !-- Adjust the volume-flow rate through the top boundary 
@@ -3635 +3790 @@
     ENDDO
 
+#endif
  END SUBROUTINE pmci_ensure_nest_mass_conservation
 

palm/trunk/SOURCE/pmc_mpi_wrapper.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! cpp-statement added (nesting can only be used in parallel mode),
+! kind-parameters adjusted to PALM-kinds
 !
 ! Former revisions:
@@ -35 +36 @@
 !------------------------------------------------------------------------------!
 
+#if defined( __parallel )
    use, intrinsic :: iso_c_binding
 
-   USE  mpi
-   USE  kinds,         ONLY: wp
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
+   USE  kinds
    USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
    IMPLICIT none
@@ -44 +50 @@
    SAVE
 
-   INTEGER, PARAMETER :: dp = wp
+!-- TO_DO: what is the meaning of this? Could variables declared in this module
+!--        also have single precision?
+!   INTEGER, PARAMETER :: dp = wp
 
 
@@ -149 +157 @@
    SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
       IMPLICIT     none
+!--   TO_DO: has buf always to be of dp-kind, or can wp used here
+!--          this effects all respective declarations in this file
       REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
       INTEGER, INTENT(IN)                       :: n
@@ -485 +495 @@
       IMPLICIT     none
       REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
-      INTEGER(kind=8),INTENT(IN)                       :: idim1
+      INTEGER(idp),INTENT(IN)                          :: idim1
       Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
 
@@ -516 +526 @@
     END FUNCTION PMC_TIME
 
+#endif
  END MODULE pmc_mpi_wrapper

palm/trunk/SOURCE/pmc_server.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! cpp-statement added (nesting can only be used in parallel mode)
 !
 ! Former revisions:
@@ -35 +35 @@
 !------------------------------------------------------------------------------!
 
+#if defined( __parallel )
    use, intrinsic :: iso_c_binding
 
-   USE  mpi
-   USE  kinds,                     ONLY: wp, iwp
+#if defined( __lc )
+    USE MPI
+#else
+    INCLUDE "mpif.h"
+#endif
+   USE  kinds
    USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
                                          PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
@@ -60 +65 @@
    PUBLIC PMC_Server_for_Client
 
-   INTEGER, PARAMETER :: dp = wp
+!-- TO_DO: what is the meaning of this? Could variables declared in this module
+!--        also have single precision?
+!   INTEGER, PARAMETER :: dp = wp
 
    ! INTERFACE section
@@ -225 +232 @@
         IMPLICIT none
         INTEGER,INTENT(IN)                         :: ClientId
+!--   TO_DO: has array always to be of dp-kind, or can wp used here
+!--          this effects all respective declarations in this file
         REAL(kind=dp),INTENT(IN),DIMENSION(:,:)    :: array
         !-- local variables
@@ -282 +291 @@
       INTEGER                                 :: arlen, myIndex, tag
       INTEGER                                 :: rCount                    ! count MPI requests
-      INTEGER(kind=8)                         :: bufsize                   ! Size of MPI data Window
+      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
       TYPE(PeDef),POINTER                     :: aPE
       TYPE(ArrayDef),POINTER                  :: ar
@@ -347 +356 @@
          do while (PMC_S_GetNextArray ( ClientId, myName,i))
             ar  => aPE%Arrays
+!--         TO_DO:  Adressrechnung ueberlegen?
             ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
             if(ar%BufIndex+ar%BufSize > bufsize) then
+!--            TO_DO: can this error really happen, and what can be the reason?
                write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
@@ -402 +413 @@
                end do
             else
+!--            TO_DO: can this error really happen, and what can be the reason?
                write(0,*) "Illegal Order of Dimension ",ar%dim_order
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
@@ -458 +470 @@
                end do
             else
+!--            TO_DO: can this error really happen, and what can be the reason?
                write(0,*) "Illegal Order of Dimension ",ar%dim_order
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
@@ -624 +637 @@
     END SUBROUTINE Set_PE_index_list
 
+#endif
 END MODULE pmc_server

palm/trunk/SOURCE/time_integration.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-!
+! PMC_ACTIVE flags removed,
+! nest synchronization after first call of timestep
 !
 ! Former revisions:
@@ -238 +239 @@
     USE pegrid
 
-#if defined( PMC_ACTIVE )
     USE pmc_interface,                                                         &
-        ONLY:  client_to_server, nesting_mode,                                 &
+        ONLY:  client_to_server, nested_run, nesting_mode,                     &
                pmci_ensure_nest_mass_conservation, pmci_client_datatrans,      &
                pmci_client_initialize, pmci_client_synchronize,                &
                pmci_server_datatrans, pmci_server_initialize,                  &
                pmci_server_synchronize, pmci_update_new, server_to_client
-#endif
 
     USE production_e_mod,                                                      &
@@ -282 +281 @@
     IF ( simulated_time == 0.0_wp )  CALL timestep
 
+!
+!-- Synchronize the timestep in case of nested run.
+!-- The server side must be called first
+    IF ( nested_run )  THEN
+       CALL pmci_server_synchronize
+       CALL pmci_client_synchronize
+    ENDIF
+
     CALL run_control
-
 
 !
@@ -302 +308 @@
     ENDIF
 
-#if defined( PMC_ACTIVE )
-!
-!-- TO_DO: try to give more meaningful comments here
-!-- Domain nesting: From server to client commmunication
-!-- ( direction=SERVER_TO_CLIENT )
-!-- Nest initial conditions
-!
-!-- Send initial condition data from server to client
-    CALL pmci_server_initialize
-!
-!-- Receive and interpolate initial data on client
-    CALL pmci_client_initialize
-!
-!-- TO_DO, maybe removed
-!-- Obs. Nesting may be unnecessary at this point.
-!
-!-- Nest boundary conditions
-    CALL pmci_server_datatrans( server_to_client )
-    CALL pmci_client_datatrans( server_to_client )
-
-    IF ( nesting_mode == 'two-way' )  THEN
-       CALL pmci_server_datatrans( client_to_server )
-       CALL pmci_client_datatrans( client_to_server )
-!
-!--    Exchange_horiz is needed for all server-domains after the anterpolation
-       CALL exchange_horiz( u, nbgp )
-       CALL exchange_horiz( v, nbgp )
-       CALL exchange_horiz( w, nbgp )
-       CALL exchange_horiz( pt, nbgp )
-       IF ( .NOT. constant_diffusion )  CALL exchange_horiz( e, nbgp )
-       intermediate_timestep_count = 0
-       CALL pres
+    IF ( nested_run )  THEN
+!
+!--    TO_DO: try to give more meaningful comments here
+!--    Domain nesting: From server to client commmunication
+!--    ( direction=SERVER_TO_CLIENT )
+!--    Nest initial conditions
+!
+!--    Send initial condition data from server to client
+       CALL pmci_server_initialize
+!
+!--    Receive and interpolate initial data on client
+       CALL pmci_client_initialize
+!
+!--    TO_DO, maybe removed
+!--    Obs. Nesting may be unnecessary at this point.
+!
+!--    Nest boundary conditions
+       CALL pmci_server_datatrans( server_to_client )
+       CALL pmci_client_datatrans( server_to_client )
+
+       IF ( nesting_mode == 'two-way' )  THEN
+          CALL pmci_server_datatrans( client_to_server )
+          CALL pmci_client_datatrans( client_to_server )
+!
+!--       Exchange_horiz is needed for all server-domains after the anterpolation
+          CALL exchange_horiz( u, nbgp )
+          CALL exchange_horiz( v, nbgp )
+          CALL exchange_horiz( w, nbgp )
+          CALL exchange_horiz( pt, nbgp )
+          IF ( .NOT. constant_diffusion )  CALL exchange_horiz( e, nbgp )
+          intermediate_timestep_count = 0
+          CALL pres
+       ENDIF
+!
+!--    Correct the w top-BC in nest domains to ensure mass conservation.
+!--    Copy the interpolated/anterpolated boundary values to the _p
+!--    arrays, too, to make sure the interpolated/anterpolated boundary
+!--    values are carried over from one RK inner step to another.
+!--    These actions must not be done for the root domain.
+       IF ( nest_domain )  THEN
+          CALL pmci_ensure_nest_mass_conservation
+          CALL pmci_update_new
+       ENDIF
+
     ENDIF
-!
-!-- Correct the w top-BC in nest domains to ensure mass conservation.
-!-- Copy the interpolated/anterpolated boundary values to the _p
-!-- arrays, too, to make sure the interpolated/anterpolated boundary
-!-- values are carried over from one RK inner step to another.
-!-- These actions must not be done for the root domain.
-    IF ( nest_domain )  THEN
-       CALL pmci_ensure_nest_mass_conservation
-       CALL pmci_update_new
-    ENDIF
-#endif
 
 #if defined( __dvrp_graphics )
@@ -366 +373 @@
           CALL timestep
 
-#if defined( PMC_ACTIVE )
-!
-!--       TO_DO: try to give more detailed and meaningful comments here
-!--       Server side must be called first
-          CALL pmci_server_synchronize
-          CALL pmci_client_synchronize
-#endif
+          IF ( nested_run )  THEN
+!
+!--          TO_DO: try to give more detailed and meaningful comments here
+!--          Server side must be called first
+             CALL pmci_server_synchronize
+             CALL pmci_client_synchronize
+          ENDIF
        ENDIF
 
@@ -694 +701 @@
           CALL swap_timelevel
 
-#if defined( PMC_ACTIVE )
-!
-!--       TO_DO: try to give more meaningful comments here
-!--       Domain nesting
-!--       Note that the nesting operations are omitted intentionally on the
-!--       first two RK-substeps.
-          CALL cpu_log( log_point(60), 'nesting', 'start' )
-!
-!--       From server to client commmunication ( direction=SERVER_TO_CLIENT )
-          CALL pmci_server_datatrans( server_to_client )
-          CALL pmci_client_datatrans( server_to_client )
-
-          IF ( nesting_mode == 'two-way' )  THEN
-!
-!--          From client to server commmunication ( direction=CLIENT_TO_SERVER )
-             CALL pmci_server_datatrans( client_to_server )
-             CALL pmci_client_datatrans( client_to_server )
-!
-!--          Exchange_horiz is needed for all server-domains after the
-!--          anterpolation
-             CALL exchange_horiz( u, nbgp )
-             CALL exchange_horiz( v, nbgp )
-             CALL exchange_horiz( w, nbgp )
-             CALL exchange_horiz( pt, nbgp )
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                CALL exchange_horiz( q, nbgp )
-             ENDIF
-             IF ( .NOT. constant_diffusion )  CALL exchange_horiz( e, nbgp )
-          ENDIF
-!
-!--       Correct the w top-BC in nest domains to ensure mass conservation.
-!--       This action must never be done for the root domain.
-          IF ( nest_domain )  THEN
-             CALL pmci_ensure_nest_mass_conservation
-!
-!--          pmc_update_new is not necessary if nesting is made at each substep.
-             CALL pmci_update_new
-          ENDIF
-
-          CALL cpu_log( log_point(60), 'nesting', 'stop' )
-#endif
+          IF ( nested_run )  THEN
+!
+!--          TO_DO: try to give more meaningful comments here
+!--          Domain nesting
+!--          Note that the nesting operations are omitted intentionally on the
+!--          first two RK-substeps.
+             CALL cpu_log( log_point(60), 'nesting', 'start' )
+!
+!--          From server to client commmunication ( direction=SERVER_TO_CLIENT )
+             CALL pmci_server_datatrans( server_to_client )
+             CALL pmci_client_datatrans( server_to_client )
+
+             IF ( nesting_mode == 'two-way' )  THEN
+!
+!--             From client to server commmunication ( direction=CLIENT_TO_SERVER )
+                CALL pmci_server_datatrans( client_to_server )
+                CALL pmci_client_datatrans( client_to_server )
+!
+!--             Exchange_horiz is needed for all server-domains after the
+!--             anterpolation
+                CALL exchange_horiz( u, nbgp )
+                CALL exchange_horiz( v, nbgp )
+                CALL exchange_horiz( w, nbgp )
+                CALL exchange_horiz( pt, nbgp )
+                IF ( humidity  .OR.  passive_scalar )  THEN
+                   CALL exchange_horiz( q, nbgp )
+                ENDIF
+                IF ( .NOT. constant_diffusion )  CALL exchange_horiz( e, nbgp )
+             ENDIF
+!
+!--          Correct the w top-BC in nest domains to ensure mass conservation.
+!--          This action must never be done for the root domain.
+             IF ( nest_domain )  THEN
+                CALL pmci_ensure_nest_mass_conservation
+!
+!--             pmc_update_new is not necessary if nesting is made at each
+!--             substep
+                CALL pmci_update_new
+             ENDIF
+
+             CALL cpu_log( log_point(60), 'nesting', 'stop' )
+
+          ENDIF
 
 !
@@ -1148 +1157 @@
 !
 !--    Output elapsed simulated time in form of a progress bar on stdout
-!--    TO_DO: should be done by root domain later
-#if ! defined( PMC_ACTIVE )
        IF ( myid == 0 )  CALL output_progress_bar
-#endif
 
        CALL cpu_log( log_point_s(10), 'timesteps', 'stop' )
@@ -1158 +1164 @@
     ENDDO   ! time loop
 
-!-- TO_DO: should be done by root domain later
-#if ! defined( PMC_ACTIVE )
     IF ( myid == 0 )  CALL finish_progress_bar
-#endif
 
 #if defined( __dvrp_graphics )